diff options
Diffstat (limited to 'src')
86 files changed, 5833 insertions, 2001 deletions
diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index e36326f6a..a8a175f7c 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -3,7 +3,7 @@ module GF.Command.Commands ( PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands, options,flags, ) where -import Prelude hiding (putStrLn) +import Prelude hiding (putStrLn,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF @@ -275,6 +275,7 @@ pgfCommands = Map.fromList [ ("list","show all forms and variants, comma-separated on one line (cf. l -all)"), ("multi","linearize to all languages (default)"), ("table","show all forms labelled by parameters"), + ("tabtreebank","show the tree and its linearizations on a tab-separated line"), ("treebank","show the tree and tag linearizations with language names") ] ++ stringOpOptions, flags = [ @@ -425,8 +426,7 @@ pgfCommands = Map.fromList [ "are type checking and semantic computation." ], examples = [ - mkEx "pt -compute (plus one two) -- compute value", - mkEx "p \"4 dogs love 5 cats\" | pt -transfer=digits2numeral | l -- four...five..." + mkEx "pt -compute (plus one two) -- compute value" ], exec = getEnv $ \ opts arg (Env pgf mos) -> returnFromExprs . takeOptNum opts . treeOps pgf opts $ toExprs arg, @@ -792,6 +792,9 @@ pgfCommands = Map.fromList [ _ | isOpt "treebank" opts -> (showCId (abstractName pgf) ++ ": " ++ showExpr [] t) : [showCId lang ++ ": " ++ s | lang <- optLangs pgf opts, s<-linear pgf opts lang t] + _ | isOpt "tabtreebank" opts -> + return $ concat $ intersperse "\t" $ (showExpr [] t) : + [s | lang <- optLangs pgf opts, s <- linear pgf opts lang t] _ | isOpt "chunks" opts -> map snd $ linChunks pgf opts t _ -> [s | lang <- optLangs pgf opts, s<-linear pgf opts lang t] linChunks pgf opts t = diff --git a/src/compiler/GF/Command/Commands2.hs b/src/compiler/GF/Command/Commands2.hs index c8e6fbff3..b5335479c 100644 --- a/src/compiler/GF/Command/Commands2.hs +++ b/src/compiler/GF/Command/Commands2.hs @@ -3,7 +3,7 @@ module GF.Command.Commands2 ( PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands, options, flags, ) where -import Prelude hiding (putStrLn) +import Prelude hiding (putStrLn,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF2 import qualified PGF as H @@ -612,7 +612,7 @@ pgfCommands = Map.fromList [ Nothing -> let funs = functionsByCat pgf id in showCat id funs)) where - showCat c funs = "cat "++showCategory pgf c++ + showCat c funs = "cat "++c++ " ;\n\n"++ unlines [showFun f ty| f<-funs, Just ty <- [functionType pgf f]] @@ -636,10 +636,12 @@ pgfCommands = Map.fromList [ cncs = optConcs env opts parsed rs = Piped (Exprs ts,unlines msgs) where - ts = [hsExpr t|Right ts<-rs,(t,p)<-takeOptNum opts ts] - msgs = concatMap (either err ok) rs - err msg = ["Parse failed: "++msg] - ok = map (PGF2.showExpr [] . fst).takeOptNum opts + ts = [hsExpr t|ParseOk ts<-rs,(t,p)<-takeOptNum opts ts] + msgs = concatMap mkMsg rs + + mkMsg (ParseOk ts) = (map (PGF2.showExpr [] . fst).takeOptNum opts) ts + mkMsg (ParseFailed _ tok) = ["Parse failed: "++tok] + mkMsg (ParseIncomplete) = ["The sentence is incomplete"] optLins env opts ts = case opts of _ | isOpt "groups" opts -> diff --git a/src/compiler/GF/Command/TreeOperations.hs b/src/compiler/GF/Command/TreeOperations.hs index 221881f44..fc0e6616d 100644 --- a/src/compiler/GF/Command/TreeOperations.hs +++ b/src/compiler/GF/Command/TreeOperations.hs @@ -4,8 +4,7 @@ module GF.Command.TreeOperations ( treeChunks ) where -import PGF(PGF,CId,compute,unApp) -import PGF.Internal(Expr(..),unAppForm) +import PGF(Expr,PGF,CId,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions) import Data.List type TreeOp = [Expr] -> [Expr] @@ -17,8 +16,6 @@ allTreeOps :: PGF -> [(String,(String,Either TreeOp (CId -> TreeOp)))] allTreeOps pgf = [ ("compute",("compute by using semantic definitions (def)", Left $ map (compute pgf))), - ("transfer",("syntactic transfer by applying function, recursively in subtrees", - Right $ \f -> map (transfer pgf f))), ("largest",("sort trees from largest to smallest, in number of nodes", Left $ largest)), ("nub",("remove duplicate trees", @@ -28,49 +25,26 @@ allTreeOps pgf = [ ("subtrees",("return all fully applied subtrees (stopping at abstractions), by default sorted from the largest", Left $ concatMap subtrees)), ("funs",("return all fun functions appearing in the tree, with duplications", - Left $ concatMap funNodes)) + Left $ \es -> [mkApp f [] | e <- es, f <- exprFunctions e])) ] largest :: [Expr] -> [Expr] largest = reverse . smallest smallest :: [Expr] -> [Expr] -smallest = sortBy (\t u -> compare (size t) (size u)) where - size t = case t of - EAbs _ _ e -> size e + 1 - EApp e1 e2 -> size e1 + size e2 + 1 - _ -> 1 +smallest = sortBy (\t u -> compare (exprSize t) (exprSize u)) treeChunks :: Expr -> [Expr] treeChunks = snd . cks where - cks t = case unAppForm t of - (EFun f, ts) -> case unzip (map cks ts) of - (bs,_) | and bs -> (True, [t]) - (_,cts) -> (False,concat cts) - (EMeta _, ts) -> (False,concatMap (snd . cks) ts) - _ -> (True, [t]) + cks t = + case unapply t of + (t, ts) -> case unMeta t of + Just _ -> (False,concatMap (snd . cks) ts) + Nothing -> case unzip (map cks ts) of + (bs,_) | and bs -> (True, [t]) + (_,cts) -> (False,concat cts) subtrees :: Expr -> [Expr] subtrees t = t : case unApp t of Just (f,ts) -> concatMap subtrees ts _ -> [] -- don't go under abstractions - -funNodes :: Expr -> [Expr] -funNodes t = case t of - EAbs _ _ e -> funNodes e - EApp e1 e2 -> funNodes e1 ++ funNodes e2 - EFun _ -> [t] - _ -> [] -- not literals, metas, etc - ---- simple-minded transfer; should use PGF.Expr.match - -transfer :: PGF -> CId -> Expr -> Expr -transfer pgf f e = case transf e of - v | v /= appf e -> v - _ -> case e of - EApp g a -> EApp (transfer pgf f g) (transfer pgf f a) - _ -> e - where - appf = EApp (EFun f) - transf = compute pgf . appf - diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 5c1743b74..1348d8e41 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -21,6 +21,7 @@ ----------------------------------------------------------------------------- module GF.Compile.CheckGrammar(checkModule) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import GF.Infra.Ident import GF.Infra.Option diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs index a77da88bf..f9edc931c 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs @@ -5,6 +5,7 @@ module GF.Compile.Compute.ConcreteNew normalForm, Value(..), Bind(..), Env, value2term, eval, vapply ) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import GF.Grammar hiding (Env, VGen, VApp, VRecType) import GF.Grammar.Lookup(lookupResDefLoc,allParamValues) diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs index b8b8ed1ac..d844e300a 100644 --- a/src/compiler/GF/Compile/Export.hs +++ b/src/compiler/GF/Compile/Export.hs @@ -5,7 +5,6 @@ import PGF.Internal(ppPGF) import GF.Compile.PGFtoHaskell import GF.Compile.PGFtoJava import GF.Compile.PGFtoProlog -import GF.Compile.PGFtoLProlog import GF.Compile.PGFtoJS import GF.Compile.PGFtoPython import GF.Infra.Option @@ -40,7 +39,6 @@ exportPGF opts fmt pgf = FmtHaskell -> multi "hs" (grammar2haskell opts name) FmtJava -> multi "java" (grammar2java opts name) FmtProlog -> multi "pl" grammar2prolog - FmtLambdaProlog -> multi "mod" grammar2lambdaprolog_mod ++ multi "sig" grammar2lambdaprolog_sig FmtBNF -> single "bnf" bnfPrinter FmtEBNF -> single "ebnf" (ebnfPrinter opts) FmtSRGS_XML -> single "grxml" (srgsXmlPrinter opts) diff --git a/src/compiler/GF/Compile/GetGrammar.hs b/src/compiler/GF/Compile/GetGrammar.hs index 0813d15d2..191c3aff9 100644 --- a/src/compiler/GF/Compile/GetGrammar.hs +++ b/src/compiler/GF/Compile/GetGrammar.hs @@ -52,9 +52,11 @@ getSourceModule opts file0 = let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0} optCoding' = renameEncoding `fmap` flag optEncoding (mflags mi0) case (optCoding,optCoding') of + {- (Nothing,Nothing) -> unless (BS.all isAscii raw) $ ePutStrLn $ file0++":\n Warning: default encoding has changed from Latin-1 to UTF-8" + -} (_,Just coding') -> when (coding/=coding') $ raise $ "Encoding mismatch: "++coding++" /= "++coding' diff --git a/src/compiler/GF/Compile/Instructions.hs b/src/compiler/GF/Compile/Instructions.hs deleted file mode 100644 index 138fabe97..000000000 --- a/src/compiler/GF/Compile/Instructions.hs +++ /dev/null @@ -1,1168 +0,0 @@ -module GF.Compile.Instructions where - ---import Data.IORef -import PGF.Internal -- Binary -import PGF(CId) ---import PGF.CId ---import PGF.Binary - -type IntRef = Int -type AConstant = CId -type AKind = CId - -ppE = undefined -ppF = undefined -ppL = undefined -ppC = undefined -ppN = undefined -ppR = undefined -ppK = undefined -ppS = undefined -ppI = undefined -ppI1 = undefined -ppIT = undefined -ppCE = undefined -ppMT = undefined -ppHT = undefined -ppSEG = undefined -ppBVT = undefined - -wordSize = 4 :: Int - -rSize = 255 :: Int -eSize = 255 :: Int -nSize = 255 :: Int -i1Size = 255 :: Int -ceSize = 255 :: Int -segSize = 255 :: Int -cSize = 65535 :: Int -kSize = 65535 :: Int -sSize = 65535 :: Int -mtSize = 65535 :: Int -itSize = 65535 :: Int -htSize = 65535 :: Int -bvtSize = 65535 :: Int -opcodeSize = 255 :: Int - - -type Rtype = Int -type Etype = Int -type Ntype = Int -type I1type = Int -type CEtype = Int -type SEGtype = Int -type Ctype = AConstant -type Ktype = AKind -type Ltype = IntRef -type Itype = Int -type Ftype = Float -type Stype = Int -type MTtype = Int -type ITtype = Int -type HTtype = Int -type BVTtype = Int - -putR = putWord8 . fromIntegral -putE = putWord8 . fromIntegral -putN = putWord8 . fromIntegral -putI1 = putWord8 . fromIntegral -putCE = putWord8 . fromIntegral -putSEG = putWord8 . fromIntegral -putC = put -putK = put -putL = putWord32be . fromIntegral -putI = putWord32be . fromIntegral -putF = putFloat32be -putS = putWord16be . fromIntegral -putMT = putWord16be . fromIntegral -putIT = putWord16be . fromIntegral -putHT = putWord16be . fromIntegral -putBVT = putWord16be . fromIntegral -putopcode = putWord8 . fromIntegral - - -getR = fmap fromIntegral $ getWord8 -getE = fmap fromIntegral $ getWord8 -getN = fmap fromIntegral $ getWord8 -getI1 = fmap fromIntegral $ getWord8 -getCE = fmap fromIntegral $ getWord8 -getSEG = fmap fromIntegral $ getWord8 -getC = get -getK = get -getL = fmap fromIntegral $ getWord32be -getI = fmap fromIntegral $ getWord32be -getF = getFloat32be -getS = fmap fromIntegral $ getWord16be -getMT = fmap fromIntegral $ getWord16be -getIT = fmap fromIntegral $ getWord16be -getHT = fmap fromIntegral $ getWord16be -getBVT = fmap fromIntegral $ getWord16be -getopcode = fmap fromIntegral $ getWord8 - - -type InscatRX = (Rtype) -type InscatEX = (Etype) -type InscatI1X = (I1type) -type InscatCX = (Ctype) -type InscatKX = (Ktype) -type InscatIX = (Itype) -type InscatFX = (Ftype) -type InscatSX = (Stype) -type InscatMTX = (MTtype) -type InscatLX = (Ltype) -type InscatRRX = (Rtype, Rtype) -type InscatERX = (Etype, Rtype) -type InscatRCX = (Rtype, Ctype) -type InscatRIX = (Rtype, Itype) -type InscatRFX = (Rtype, Ftype) -type InscatRSX = (Rtype, Stype) -type InscatRI1X = (Rtype, I1type) -type InscatRCEX = (Rtype, CEtype) -type InscatECEX = (Etype, CEtype) -type InscatCLX = (Ctype, Ltype) -type InscatRKX = (Rtype, Ktype) -type InscatECX = (Etype, Ctype) -type InscatI1ITX = (I1type, ITtype) -type InscatI1LX = (I1type, Ltype) -type InscatSEGLX = (SEGtype, Ltype) -type InscatI1LWPX = (I1type, Ltype) -type InscatI1NX = (I1type, Ntype) -type InscatI1HTX = (I1type, HTtype) -type InscatI1BVTX = (I1type, BVTtype) -type InscatCWPX = (Ctype) -type InscatI1WPX = (I1type) -type InscatRRI1X = (Rtype, Rtype, I1type) -type InscatRCLX = (Rtype, Ctype, Ltype) -type InscatRCI1X = (Rtype, Ctype, I1type) -type InscatSEGI1LX = (SEGtype, I1type, Ltype) -type InscatI1LLX = (I1type, Ltype, Ltype) -type InscatNLLX = (Ntype, Ltype, Ltype) -type InscatLLLLX = (Ltype, Ltype, Ltype, Ltype) -type InscatI1CWPX = (I1type, Ctype) -type InscatI1I1WPX = (I1type, I1type) - - -putRX (arg1) = putR arg1 -putEX (arg1) = putE arg1 -putI1X (arg1) = putI1 arg1 -putCX (arg1) = putC arg1 -putKX (arg1) = putK arg1 -putIX (arg1) = putI arg1 -putFX (arg1) = putF arg1 -putSX (arg1) = putS arg1 -putMTX (arg1) = putMT arg1 -putLX (arg1) = putL arg1 -putRRX (arg1, arg2) = putR arg1 >> putR arg2 -putERX (arg1, arg2) = putE arg1 >> putR arg2 -putRCX (arg1, arg2) = putR arg1 >> putC arg2 -putRIX (arg1, arg2) = putR arg1 >> putI arg2 -putRFX (arg1, arg2) = putR arg1 >> putF arg2 -putRSX (arg1, arg2) = putR arg1 >> putS arg2 -putRI1X (arg1, arg2) = putR arg1 >> putI1 arg2 -putRCEX (arg1, arg2) = putR arg1 >> putCE arg2 -putECEX (arg1, arg2) = putE arg1 >> putCE arg2 -putCLX (arg1, arg2) = putC arg1 >> putL arg2 -putRKX (arg1, arg2) = putR arg1 >> putK arg2 -putECX (arg1, arg2) = putE arg1 >> putC arg2 -putI1ITX (arg1, arg2) = putI1 arg1 >> putIT arg2 -putI1LX (arg1, arg2) = putI1 arg1 >> putL arg2 -putSEGLX (arg1, arg2) = putSEG arg1 >> putL arg2 -putI1LWPX (arg1, arg2) = putI1 arg1 >> putL arg2 -putI1NX (arg1, arg2) = putI1 arg1 >> putN arg2 -putI1HTX (arg1, arg2) = putI1 arg1 >> putHT arg2 -putI1BVTX (arg1, arg2) = putI1 arg1 >> putBVT arg2 -putCWPX (arg1) = putC arg1 -putI1WPX (arg1) = putI1 arg1 -putRRI1X (arg1, arg2, arg3) = putR arg1 >> putR arg2 >> putI1 arg3 -putRCLX (arg1, arg2, arg3) = putR arg1 >> putC arg2 >> putL arg3 -putRCI1X (arg1, arg2, arg3) = putR arg1 >> putC arg2 >> putI1 arg3 -putSEGI1LX (arg1, arg2, arg3) = putSEG arg1 >> putI1 arg2 >> putL arg3 -putI1LLX (arg1, arg2, arg3) = putI1 arg1 >> putL arg2 >> putL arg3 -putNLLX (arg1, arg2, arg3) = putN arg1 >> putL arg2 >> putL arg3 -putLLLLX (arg1, arg2, arg3, arg4) = putL arg1 >> putL arg2 >> putL arg3 >> putL arg4 -putI1CWPX (arg1, arg2) = putI1 arg1 >> putC arg2 -putI1I1WPX (arg1, arg2) = putI1 arg1 >> putI1 arg2 - -getRX = do - arg1 <- getR - return (arg1) -getEX = do - arg1 <- getE - return (arg1) -getI1X = do - arg1 <- getI1 - return (arg1) -getCX = do - arg1 <- getC - return (arg1) -getKX = do - arg1 <- getK - return (arg1) -getIX = do - arg1 <- getI - return (arg1) -getFX = do - arg1 <- getF - return (arg1) -getSX = do - arg1 <- getS - return (arg1) -getMTX = do - arg1 <- getMT - return (arg1) -getLX = do - arg1 <- getL - return (arg1) -getRRX = do - arg1 <- getR - arg2 <- getR - return (arg1, arg2) -getERX = do - arg1 <- getE - arg2 <- getR - return (arg1, arg2) -getRCX = do - arg1 <- getR - arg2 <- getC - return (arg1, arg2) -getRIX = do - arg1 <- getR - arg2 <- getI - return (arg1, arg2) -getRFX = do - arg1 <- getR - arg2 <- getF - return (arg1, arg2) -getRSX = do - arg1 <- getR - arg2 <- getS - return (arg1, arg2) -getRI1X = do - arg1 <- getR - arg2 <- getI1 - return (arg1, arg2) -getRCEX = do - arg1 <- getR - arg2 <- getCE - return (arg1, arg2) -getECEX = do - arg1 <- getE - arg2 <- getCE - return (arg1, arg2) -getCLX = do - arg1 <- getC - arg2 <- getL - return (arg1, arg2) -getRKX = do - arg1 <- getR - arg2 <- getK - return (arg1, arg2) -getECX = do - arg1 <- getE - arg2 <- getC - return (arg1, arg2) -getI1ITX = do - arg1 <- getI1 - arg2 <- getIT - return (arg1, arg2) -getI1LX = do - arg1 <- getI1 - arg2 <- getL - return (arg1, arg2) -getSEGLX = do - arg1 <- getSEG - arg2 <- getL - return (arg1, arg2) -getI1LWPX = do - arg1 <- getI1 - arg2 <- getL - return (arg1, arg2) -getI1NX = do - arg1 <- getI1 - arg2 <- getN - return (arg1, arg2) -getI1HTX = do - arg1 <- getI1 - arg2 <- getHT - return (arg1, arg2) -getI1BVTX = do - arg1 <- getI1 - arg2 <- getBVT - return (arg1, arg2) -getCWPX = do - arg1 <- getC - return (arg1) -getI1WPX = do - arg1 <- getI1 - return (arg1) -getRRI1X = do - arg1 <- getR - arg2 <- getR - arg3 <- getI1 - return (arg1, arg2, arg3) -getRCLX = do - arg1 <- getR - arg2 <- getC - arg3 <- getL - return (arg1, arg2, arg3) -getRCI1X = do - arg1 <- getR - arg2 <- getC - arg3 <- getI1 - return (arg1, arg2, arg3) -getSEGI1LX = do - arg1 <- getSEG - arg2 <- getI1 - arg3 <- getL - return (arg1, arg2, arg3) -getI1LLX = do - arg1 <- getI1 - arg2 <- getL - arg3 <- getL - return (arg1, arg2, arg3) -getNLLX = do - arg1 <- getN - arg2 <- getL - arg3 <- getL - return (arg1, arg2, arg3) -getLLLLX = do - arg1 <- getL - arg2 <- getL - arg3 <- getL - arg4 <- getL - return (arg1, arg2, arg3, arg4) -getI1CWPX = do - arg1 <- getI1 - arg2 <- getC - return (arg1, arg2) -getI1I1WPX = do - arg1 <- getI1 - arg2 <- getI1 - return (arg1, arg2) - -displayRX (arg1) = ppR arg1 -displayEX (arg1) = ppE arg1 -displayI1X (arg1) = ppI1 arg1 -displayCX (arg1) = ppC arg1 -displayKX (arg1) = ppK arg1 -displayIX (arg1) = ppI arg1 -displayFX (arg1) = ppF arg1 -displaySX (arg1) = ppS arg1 -displayMTX (arg1) = ppMT arg1 -displayLX (arg1) = ppL arg1 -displayRRX (arg1, arg2) = (ppR arg1) ++ ", " ++ (ppR arg2) -displayERX (arg1, arg2) = (ppE arg1) ++ ", " ++ (ppR arg2) -displayRCX (arg1, arg2) = (ppR arg1) ++ ", " ++ (ppC arg2) -displayRIX (arg1, arg2) = (ppR arg1) ++ ", " ++ (ppI arg2) -displayRFX (arg1, arg2) = (ppR arg1) ++ ", " ++ (ppF arg2) -displayRSX (arg1, arg2) = (ppR arg1) ++ ", " ++ (ppS arg2) -displayRI1X (arg1, arg2) = (ppR arg1) ++ ", " ++ (ppI1 arg2) -displayRCEX (arg1, arg2) = (ppR arg1) ++ ", " ++ (ppCE arg2) -displayECEX (arg1, arg2) = (ppE arg1) ++ ", " ++ (ppCE arg2) -displayCLX (arg1, arg2) = (ppC arg1) ++ ", " ++ (ppL arg2) -displayRKX (arg1, arg2) = (ppR arg1) ++ ", " ++ (ppK arg2) -displayECX (arg1, arg2) = (ppE arg1) ++ ", " ++ (ppC arg2) -displayI1ITX (arg1, arg2) = (ppI1 arg1) ++ ", " ++ (ppIT arg2) -displayI1LX (arg1, arg2) = (ppI1 arg1) ++ ", " ++ (ppL arg2) -displaySEGLX (arg1, arg2) = (ppSEG arg1) ++ ", " ++ (ppL arg2) -displayI1LWPX (arg1, arg2) = (ppI1 arg1) ++ ", " ++ (ppL arg2) -displayI1NX (arg1, arg2) = (ppI1 arg1) ++ ", " ++ (ppN arg2) -displayI1HTX (arg1, arg2) = (ppI1 arg1) ++ ", " ++ (ppHT arg2) -displayI1BVTX (arg1, arg2) = (ppI1 arg1) ++ ", " ++ (ppBVT arg2) -displayCWPX (arg1) = ppC arg1 -displayI1WPX (arg1) = ppI1 arg1 -displayRRI1X (arg1, arg2, arg3) = ((ppR arg1) ++ ", " ++ (ppR arg2)) ++ ", " ++ (ppI1 arg3) -displayRCLX (arg1, arg2, arg3) = ((ppR arg1) ++ ", " ++ (ppC arg2)) ++ ", " ++ (ppL arg3) -displayRCI1X (arg1, arg2, arg3) = ((ppR arg1) ++ ", " ++ (ppC arg2)) ++ ", " ++ (ppI1 arg3) -displaySEGI1LX (arg1, arg2, arg3) = ((ppSEG arg1) ++ ", " ++ (ppI1 arg2)) ++ ", " ++ (ppL arg3) -displayI1LLX (arg1, arg2, arg3) = ((ppI1 arg1) ++ ", " ++ (ppL arg2)) ++ ", " ++ (ppL arg3) -displayNLLX (arg1, arg2, arg3) = ((ppN arg1) ++ ", " ++ (ppL arg2)) ++ ", " ++ (ppL arg3) -displayLLLLX (arg1, arg2, arg3, arg4) = (((ppL arg1) ++ ", " ++ (ppL arg2)) ++ ", " ++ (ppL arg3)) ++ ", " ++ (ppL arg4) -displayI1CWPX (arg1, arg2) = (ppI1 arg1) ++ ", " ++ (ppC arg2) -displayI1I1WPX (arg1, arg2) = (ppI1 arg1) ++ ", " ++ (ppI1 arg2) - -inscatX_LEN = 4 :: Int -inscatRX_LEN = 4 :: Int -inscatEX_LEN = 4 :: Int -inscatI1X_LEN = 4 :: Int -inscatCX_LEN = 4 :: Int -inscatKX_LEN = 4 :: Int -inscatIX_LEN = 8 :: Int -inscatFX_LEN = 8 :: Int -inscatSX_LEN = 8 :: Int -inscatMTX_LEN = 8 :: Int -inscatLX_LEN = 8 :: Int -inscatRRX_LEN = 4 :: Int -inscatERX_LEN = 4 :: Int -inscatRCX_LEN = 4 :: Int -inscatRIX_LEN = 8 :: Int -inscatRFX_LEN = 8 :: Int -inscatRSX_LEN = 8 :: Int -inscatRI1X_LEN = 4 :: Int -inscatRCEX_LEN = 4 :: Int -inscatECEX_LEN = 4 :: Int -inscatCLX_LEN = 8 :: Int -inscatRKX_LEN = 4 :: Int -inscatECX_LEN = 4 :: Int -inscatI1ITX_LEN = 8 :: Int -inscatI1LX_LEN = 8 :: Int -inscatSEGLX_LEN = 8 :: Int -inscatI1LWPX_LEN = 12 :: Int -inscatI1NX_LEN = 4 :: Int -inscatI1HTX_LEN = 8 :: Int -inscatI1BVTX_LEN = 8 :: Int -inscatCWPX_LEN = 8 :: Int -inscatI1WPX_LEN = 8 :: Int -inscatRRI1X_LEN = 4 :: Int -inscatRCLX_LEN = 8 :: Int -inscatRCI1X_LEN = 8 :: Int -inscatSEGI1LX_LEN = 8 :: Int -inscatI1LLX_LEN = 12 :: Int -inscatNLLX_LEN = 12 :: Int -inscatLLLLX_LEN = 20 :: Int -inscatI1CWPX_LEN = 8 :: Int -inscatI1I1WPX_LEN = 8 :: Int - - - -data Instruction - = Ins_put_variable_t InscatRRX - | Ins_put_variable_p InscatERX - | Ins_put_value_t InscatRRX - | Ins_put_value_p InscatERX - | Ins_put_unsafe_value InscatERX - | Ins_copy_value InscatERX - | Ins_put_m_const InscatRCX - | Ins_put_p_const InscatRCX - | Ins_put_nil InscatRX - | Ins_put_integer InscatRIX - | Ins_put_float InscatRFX - | Ins_put_string InscatRSX - | Ins_put_index InscatRI1X - | Ins_put_app InscatRRI1X - | Ins_put_list InscatRX - | Ins_put_lambda InscatRRI1X - | Ins_set_variable_t InscatRX - | Ins_set_variable_te InscatRX - | Ins_set_variable_p InscatEX - | Ins_set_value_t InscatRX - | Ins_set_value_p InscatEX - | Ins_globalize_pt InscatERX - | Ins_globalize_t InscatRX - | Ins_set_m_const InscatCX - | Ins_set_p_const InscatCX - | Ins_set_nil - | Ins_set_integer InscatIX - | Ins_set_float InscatFX - | Ins_set_string InscatSX - | Ins_set_index InscatI1X - | Ins_set_void InscatI1X - | Ins_deref InscatRX - | Ins_set_lambda InscatRI1X - | Ins_get_variable_t InscatRRX - | Ins_get_variable_p InscatERX - | Ins_init_variable_t InscatRCEX - | Ins_init_variable_p InscatECEX - | Ins_get_m_constant InscatRCX - | Ins_get_p_constant InscatRCLX - | Ins_get_integer InscatRIX - | Ins_get_float InscatRFX - | Ins_get_string InscatRSX - | Ins_get_nil InscatRX - | Ins_get_m_structure InscatRCI1X - | Ins_get_p_structure InscatRCI1X - | Ins_get_list InscatRX - | Ins_unify_variable_t InscatRX - | Ins_unify_variable_p InscatEX - | Ins_unify_value_t InscatRX - | Ins_unify_value_p InscatEX - | Ins_unify_local_value_t InscatRX - | Ins_unify_local_value_p InscatEX - | Ins_unify_m_constant InscatCX - | Ins_unify_p_constant InscatCLX - | Ins_unify_integer InscatIX - | Ins_unify_float InscatFX - | Ins_unify_string InscatSX - | Ins_unify_nil - | Ins_unify_void InscatI1X - | Ins_put_type_variable_t InscatRRX - | Ins_put_type_variable_p InscatERX - | Ins_put_type_value_t InscatRRX - | Ins_put_type_value_p InscatERX - | Ins_put_type_unsafe_value InscatERX - | Ins_put_type_const InscatRKX - | Ins_put_type_structure InscatRKX - | Ins_put_type_arrow InscatRX - | Ins_set_type_variable_t InscatRX - | Ins_set_type_variable_p InscatEX - | Ins_set_type_value_t InscatRX - | Ins_set_type_value_p InscatEX - | Ins_set_type_local_value_t InscatRX - | Ins_set_type_local_value_p InscatEX - | Ins_set_type_constant InscatKX - | Ins_get_type_variable_t InscatRRX - | Ins_get_type_variable_p InscatERX - | Ins_init_type_variable_t InscatRCEX - | Ins_init_type_variable_p InscatECEX - | Ins_get_type_value_t InscatRRX - | Ins_get_type_value_p InscatERX - | Ins_get_type_constant InscatRKX - | Ins_get_type_structure InscatRKX - | Ins_get_type_arrow InscatRX - | Ins_unify_type_variable_t InscatRX - | Ins_unify_type_variable_p InscatEX - | Ins_unify_type_value_t InscatRX - | Ins_unify_type_value_p InscatEX - | Ins_unify_envty_value_t InscatRX - | Ins_unify_envty_value_p InscatEX - | Ins_unify_type_local_value_t InscatRX - | Ins_unify_type_local_value_p InscatEX - | Ins_unify_envty_local_value_t InscatRX - | Ins_unify_envty_local_value_p InscatEX - | Ins_unify_type_constant InscatKX - | Ins_pattern_unify_t InscatRRX - | Ins_pattern_unify_p InscatERX - | Ins_finish_unify - | Ins_head_normalize_t InscatRX - | Ins_head_normalize_p InscatEX - | Ins_incr_universe - | Ins_decr_universe - | Ins_set_univ_tag InscatECX - | Ins_tag_exists_t InscatRX - | Ins_tag_exists_p InscatEX - | Ins_tag_variable InscatEX - | Ins_push_impl_point InscatI1ITX - | Ins_pop_impl_point - | Ins_add_imports InscatSEGI1LX - | Ins_remove_imports InscatSEGLX - | Ins_push_import InscatMTX - | Ins_pop_imports InscatI1X - | Ins_allocate InscatI1X - | Ins_deallocate - | Ins_call InscatI1LX - | Ins_call_name InscatI1CWPX - | Ins_execute InscatLX - | Ins_execute_name InscatCWPX - | Ins_proceed - | Ins_try_me_else InscatI1LX - | Ins_retry_me_else InscatI1LX - | Ins_trust_me InscatI1WPX - | Ins_try InscatI1LX - | Ins_retry InscatI1LX - | Ins_trust InscatI1LWPX - | Ins_trust_ext InscatI1NX - | Ins_try_else InscatI1LLX - | Ins_retry_else InscatI1LLX - | Ins_branch InscatLX - | Ins_switch_on_term InscatLLLLX - | Ins_switch_on_constant InscatI1HTX - | Ins_switch_on_bvar InscatI1BVTX - | Ins_switch_on_reg InscatNLLX - | Ins_neck_cut - | Ins_get_level InscatEX - | Ins_put_level InscatEX - | Ins_cut InscatEX - | Ins_call_builtin InscatI1I1WPX - | Ins_builtin InscatI1X - | Ins_stop - | Ins_halt - | Ins_fail - | Ins_create_type_variable InscatEX - | Ins_execute_link_only InscatCWPX - | Ins_call_link_only InscatI1CWPX - | Ins_put_variable_te InscatRRX - -getSize_put_variable_t = inscatRRX_LEN :: Int -getSize_put_variable_p = inscatERX_LEN :: Int -getSize_put_value_t = inscatRRX_LEN :: Int -getSize_put_value_p = inscatERX_LEN :: Int -getSize_put_unsafe_value = inscatERX_LEN :: Int -getSize_copy_value = inscatERX_LEN :: Int -getSize_put_m_const = inscatRCX_LEN :: Int -getSize_put_p_const = inscatRCX_LEN :: Int -getSize_put_nil = inscatRX_LEN :: Int -getSize_put_integer = inscatRIX_LEN :: Int -getSize_put_float = inscatRFX_LEN :: Int -getSize_put_string = inscatRSX_LEN :: Int -getSize_put_index = inscatRI1X_LEN :: Int -getSize_put_app = inscatRRI1X_LEN :: Int -getSize_put_list = inscatRX_LEN :: Int -getSize_put_lambda = inscatRRI1X_LEN :: Int -getSize_set_variable_t = inscatRX_LEN :: Int -getSize_set_variable_te = inscatRX_LEN :: Int -getSize_set_variable_p = inscatEX_LEN :: Int -getSize_set_value_t = inscatRX_LEN :: Int -getSize_set_value_p = inscatEX_LEN :: Int -getSize_globalize_pt = inscatERX_LEN :: Int -getSize_globalize_t = inscatRX_LEN :: Int -getSize_set_m_const = inscatCX_LEN :: Int -getSize_set_p_const = inscatCX_LEN :: Int -getSize_set_nil = inscatX_LEN :: Int -getSize_set_integer = inscatIX_LEN :: Int -getSize_set_float = inscatFX_LEN :: Int -getSize_set_string = inscatSX_LEN :: Int -getSize_set_index = inscatI1X_LEN :: Int -getSize_set_void = inscatI1X_LEN :: Int -getSize_deref = inscatRX_LEN :: Int -getSize_set_lambda = inscatRI1X_LEN :: Int -getSize_get_variable_t = inscatRRX_LEN :: Int -getSize_get_variable_p = inscatERX_LEN :: Int -getSize_init_variable_t = inscatRCEX_LEN :: Int -getSize_init_variable_p = inscatECEX_LEN :: Int -getSize_get_m_constant = inscatRCX_LEN :: Int -getSize_get_p_constant = inscatRCLX_LEN :: Int -getSize_get_integer = inscatRIX_LEN :: Int -getSize_get_float = inscatRFX_LEN :: Int -getSize_get_string = inscatRSX_LEN :: Int -getSize_get_nil = inscatRX_LEN :: Int -getSize_get_m_structure = inscatRCI1X_LEN :: Int -getSize_get_p_structure = inscatRCI1X_LEN :: Int -getSize_get_list = inscatRX_LEN :: Int -getSize_unify_variable_t = inscatRX_LEN :: Int -getSize_unify_variable_p = inscatEX_LEN :: Int -getSize_unify_value_t = inscatRX_LEN :: Int -getSize_unify_value_p = inscatEX_LEN :: Int -getSize_unify_local_value_t = inscatRX_LEN :: Int -getSize_unify_local_value_p = inscatEX_LEN :: Int -getSize_unify_m_constant = inscatCX_LEN :: Int -getSize_unify_p_constant = inscatCLX_LEN :: Int -getSize_unify_integer = inscatIX_LEN :: Int -getSize_unify_float = inscatFX_LEN :: Int -getSize_unify_string = inscatSX_LEN :: Int -getSize_unify_nil = inscatX_LEN :: Int -getSize_unify_void = inscatI1X_LEN :: Int -getSize_put_type_variable_t = inscatRRX_LEN :: Int -getSize_put_type_variable_p = inscatERX_LEN :: Int -getSize_put_type_value_t = inscatRRX_LEN :: Int -getSize_put_type_value_p = inscatERX_LEN :: Int -getSize_put_type_unsafe_value = inscatERX_LEN :: Int -getSize_put_type_const = inscatRKX_LEN :: Int -getSize_put_type_structure = inscatRKX_LEN :: Int -getSize_put_type_arrow = inscatRX_LEN :: Int -getSize_set_type_variable_t = inscatRX_LEN :: Int -getSize_set_type_variable_p = inscatEX_LEN :: Int -getSize_set_type_value_t = inscatRX_LEN :: Int -getSize_set_type_value_p = inscatEX_LEN :: Int -getSize_set_type_local_value_t = inscatRX_LEN :: Int -getSize_set_type_local_value_p = inscatEX_LEN :: Int -getSize_set_type_constant = inscatKX_LEN :: Int -getSize_get_type_variable_t = inscatRRX_LEN :: Int -getSize_get_type_variable_p = inscatERX_LEN :: Int -getSize_init_type_variable_t = inscatRCEX_LEN :: Int -getSize_init_type_variable_p = inscatECEX_LEN :: Int -getSize_get_type_value_t = inscatRRX_LEN :: Int -getSize_get_type_value_p = inscatERX_LEN :: Int -getSize_get_type_constant = inscatRKX_LEN :: Int -getSize_get_type_structure = inscatRKX_LEN :: Int -getSize_get_type_arrow = inscatRX_LEN :: Int -getSize_unify_type_variable_t = inscatRX_LEN :: Int -getSize_unify_type_variable_p = inscatEX_LEN :: Int -getSize_unify_type_value_t = inscatRX_LEN :: Int -getSize_unify_type_value_p = inscatEX_LEN :: Int -getSize_unify_envty_value_t = inscatRX_LEN :: Int -getSize_unify_envty_value_p = inscatEX_LEN :: Int -getSize_unify_type_local_value_t = inscatRX_LEN :: Int -getSize_unify_type_local_value_p = inscatEX_LEN :: Int -getSize_unify_envty_local_value_t = inscatRX_LEN :: Int -getSize_unify_envty_local_value_p = inscatEX_LEN :: Int -getSize_unify_type_constant = inscatKX_LEN :: Int -getSize_pattern_unify_t = inscatRRX_LEN :: Int -getSize_pattern_unify_p = inscatERX_LEN :: Int -getSize_finish_unify = inscatX_LEN :: Int -getSize_head_normalize_t = inscatRX_LEN :: Int -getSize_head_normalize_p = inscatEX_LEN :: Int -getSize_incr_universe = inscatX_LEN :: Int -getSize_decr_universe = inscatX_LEN :: Int -getSize_set_univ_tag = inscatECX_LEN :: Int -getSize_tag_exists_t = inscatRX_LEN :: Int -getSize_tag_exists_p = inscatEX_LEN :: Int -getSize_tag_variable = inscatEX_LEN :: Int -getSize_push_impl_point = inscatI1ITX_LEN :: Int -getSize_pop_impl_point = inscatX_LEN :: Int -getSize_add_imports = inscatSEGI1LX_LEN :: Int -getSize_remove_imports = inscatSEGLX_LEN :: Int -getSize_push_import = inscatMTX_LEN :: Int -getSize_pop_imports = inscatI1X_LEN :: Int -getSize_allocate = inscatI1X_LEN :: Int -getSize_deallocate = inscatX_LEN :: Int -getSize_call = inscatI1LX_LEN :: Int -getSize_call_name = inscatI1CWPX_LEN :: Int -getSize_execute = inscatLX_LEN :: Int -getSize_execute_name = inscatCWPX_LEN :: Int -getSize_proceed = inscatX_LEN :: Int -getSize_try_me_else = inscatI1LX_LEN :: Int -getSize_retry_me_else = inscatI1LX_LEN :: Int -getSize_trust_me = inscatI1WPX_LEN :: Int -getSize_try = inscatI1LX_LEN :: Int -getSize_retry = inscatI1LX_LEN :: Int -getSize_trust = inscatI1LWPX_LEN :: Int -getSize_trust_ext = inscatI1NX_LEN :: Int -getSize_try_else = inscatI1LLX_LEN :: Int -getSize_retry_else = inscatI1LLX_LEN :: Int -getSize_branch = inscatLX_LEN :: Int -getSize_switch_on_term = inscatLLLLX_LEN :: Int -getSize_switch_on_constant = inscatI1HTX_LEN :: Int -getSize_switch_on_bvar = inscatI1BVTX_LEN :: Int -getSize_switch_on_reg = inscatNLLX_LEN :: Int -getSize_neck_cut = inscatX_LEN :: Int -getSize_get_level = inscatEX_LEN :: Int -getSize_put_level = inscatEX_LEN :: Int -getSize_cut = inscatEX_LEN :: Int -getSize_call_builtin = inscatI1I1WPX_LEN :: Int -getSize_builtin = inscatI1X_LEN :: Int -getSize_stop = inscatX_LEN :: Int -getSize_halt = inscatX_LEN :: Int -getSize_fail = inscatX_LEN :: Int -getSize_create_type_variable = inscatEX_LEN :: Int -getSize_execute_link_only = inscatCWPX_LEN :: Int -getSize_call_link_only = inscatI1CWPX_LEN :: Int -getSize_put_variable_te = inscatRRX_LEN :: Int - -putInstruction :: Instruction -> Put -putInstruction inst = - case inst of - Ins_put_variable_t arg -> putopcode 0 >> putRRX arg - Ins_put_variable_p arg -> putopcode 1 >> putERX arg - Ins_put_value_t arg -> putopcode 2 >> putRRX arg - Ins_put_value_p arg -> putopcode 3 >> putERX arg - Ins_put_unsafe_value arg -> putopcode 4 >> putERX arg - Ins_copy_value arg -> putopcode 5 >> putERX arg - Ins_put_m_const arg -> putopcode 6 >> putRCX arg - Ins_put_p_const arg -> putopcode 7 >> putRCX arg - Ins_put_nil arg -> putopcode 8 >> putRX arg - Ins_put_integer arg -> putopcode 9 >> putRIX arg - Ins_put_float arg -> putopcode 10 >> putRFX arg - Ins_put_string arg -> putopcode 11 >> putRSX arg - Ins_put_index arg -> putopcode 12 >> putRI1X arg - Ins_put_app arg -> putopcode 13 >> putRRI1X arg - Ins_put_list arg -> putopcode 14 >> putRX arg - Ins_put_lambda arg -> putopcode 15 >> putRRI1X arg - Ins_set_variable_t arg -> putopcode 16 >> putRX arg - Ins_set_variable_te arg -> putopcode 17 >> putRX arg - Ins_set_variable_p arg -> putopcode 18 >> putEX arg - Ins_set_value_t arg -> putopcode 19 >> putRX arg - Ins_set_value_p arg -> putopcode 20 >> putEX arg - Ins_globalize_pt arg -> putopcode 21 >> putERX arg - Ins_globalize_t arg -> putopcode 22 >> putRX arg - Ins_set_m_const arg -> putopcode 23 >> putCX arg - Ins_set_p_const arg -> putopcode 24 >> putCX arg - Ins_set_nil -> putopcode 25 - Ins_set_integer arg -> putopcode 26 >> putIX arg - Ins_set_float arg -> putopcode 27 >> putFX arg - Ins_set_string arg -> putopcode 28 >> putSX arg - Ins_set_index arg -> putopcode 29 >> putI1X arg - Ins_set_void arg -> putopcode 30 >> putI1X arg - Ins_deref arg -> putopcode 31 >> putRX arg - Ins_set_lambda arg -> putopcode 32 >> putRI1X arg - Ins_get_variable_t arg -> putopcode 33 >> putRRX arg - Ins_get_variable_p arg -> putopcode 34 >> putERX arg - Ins_init_variable_t arg -> putopcode 35 >> putRCEX arg - Ins_init_variable_p arg -> putopcode 36 >> putECEX arg - Ins_get_m_constant arg -> putopcode 37 >> putRCX arg - Ins_get_p_constant arg -> putopcode 38 >> putRCLX arg - Ins_get_integer arg -> putopcode 39 >> putRIX arg - Ins_get_float arg -> putopcode 40 >> putRFX arg - Ins_get_string arg -> putopcode 41 >> putRSX arg - Ins_get_nil arg -> putopcode 42 >> putRX arg - Ins_get_m_structure arg -> putopcode 43 >> putRCI1X arg - Ins_get_p_structure arg -> putopcode 44 >> putRCI1X arg - Ins_get_list arg -> putopcode 45 >> putRX arg - Ins_unify_variable_t arg -> putopcode 46 >> putRX arg - Ins_unify_variable_p arg -> putopcode 47 >> putEX arg - Ins_unify_value_t arg -> putopcode 48 >> putRX arg - Ins_unify_value_p arg -> putopcode 49 >> putEX arg - Ins_unify_local_value_t arg -> putopcode 50 >> putRX arg - Ins_unify_local_value_p arg -> putopcode 51 >> putEX arg - Ins_unify_m_constant arg -> putopcode 52 >> putCX arg - Ins_unify_p_constant arg -> putopcode 53 >> putCLX arg - Ins_unify_integer arg -> putopcode 54 >> putIX arg - Ins_unify_float arg -> putopcode 55 >> putFX arg - Ins_unify_string arg -> putopcode 56 >> putSX arg - Ins_unify_nil -> putopcode 57 - Ins_unify_void arg -> putopcode 58 >> putI1X arg - Ins_put_type_variable_t arg -> putopcode 59 >> putRRX arg - Ins_put_type_variable_p arg -> putopcode 60 >> putERX arg - Ins_put_type_value_t arg -> putopcode 61 >> putRRX arg - Ins_put_type_value_p arg -> putopcode 62 >> putERX arg - Ins_put_type_unsafe_value arg -> putopcode 63 >> putERX arg - Ins_put_type_const arg -> putopcode 64 >> putRKX arg - Ins_put_type_structure arg -> putopcode 65 >> putRKX arg - Ins_put_type_arrow arg -> putopcode 66 >> putRX arg - Ins_set_type_variable_t arg -> putopcode 67 >> putRX arg - Ins_set_type_variable_p arg -> putopcode 68 >> putEX arg - Ins_set_type_value_t arg -> putopcode 69 >> putRX arg - Ins_set_type_value_p arg -> putopcode 70 >> putEX arg - Ins_set_type_local_value_t arg -> putopcode 71 >> putRX arg - Ins_set_type_local_value_p arg -> putopcode 72 >> putEX arg - Ins_set_type_constant arg -> putopcode 73 >> putKX arg - Ins_get_type_variable_t arg -> putopcode 74 >> putRRX arg - Ins_get_type_variable_p arg -> putopcode 75 >> putERX arg - Ins_init_type_variable_t arg -> putopcode 76 >> putRCEX arg - Ins_init_type_variable_p arg -> putopcode 77 >> putECEX arg - Ins_get_type_value_t arg -> putopcode 78 >> putRRX arg - Ins_get_type_value_p arg -> putopcode 79 >> putERX arg - Ins_get_type_constant arg -> putopcode 80 >> putRKX arg - Ins_get_type_structure arg -> putopcode 81 >> putRKX arg - Ins_get_type_arrow arg -> putopcode 82 >> putRX arg - Ins_unify_type_variable_t arg -> putopcode 83 >> putRX arg - Ins_unify_type_variable_p arg -> putopcode 84 >> putEX arg - Ins_unify_type_value_t arg -> putopcode 85 >> putRX arg - Ins_unify_type_value_p arg -> putopcode 86 >> putEX arg - Ins_unify_envty_value_t arg -> putopcode 87 >> putRX arg - Ins_unify_envty_value_p arg -> putopcode 88 >> putEX arg - Ins_unify_type_local_value_t arg -> putopcode 89 >> putRX arg - Ins_unify_type_local_value_p arg -> putopcode 90 >> putEX arg - Ins_unify_envty_local_value_t arg -> putopcode 91 >> putRX arg - Ins_unify_envty_local_value_p arg -> putopcode 92 >> putEX arg - Ins_unify_type_constant arg -> putopcode 93 >> putKX arg - Ins_pattern_unify_t arg -> putopcode 94 >> putRRX arg - Ins_pattern_unify_p arg -> putopcode 95 >> putERX arg - Ins_finish_unify -> putopcode 96 - Ins_head_normalize_t arg -> putopcode 97 >> putRX arg - Ins_head_normalize_p arg -> putopcode 98 >> putEX arg - Ins_incr_universe -> putopcode 99 - Ins_decr_universe -> putopcode 100 - Ins_set_univ_tag arg -> putopcode 101 >> putECX arg - Ins_tag_exists_t arg -> putopcode 102 >> putRX arg - Ins_tag_exists_p arg -> putopcode 103 >> putEX arg - Ins_tag_variable arg -> putopcode 104 >> putEX arg - Ins_push_impl_point arg -> putopcode 105 >> putI1ITX arg - Ins_pop_impl_point -> putopcode 106 - Ins_add_imports arg -> putopcode 107 >> putSEGI1LX arg - Ins_remove_imports arg -> putopcode 108 >> putSEGLX arg - Ins_push_import arg -> putopcode 109 >> putMTX arg - Ins_pop_imports arg -> putopcode 110 >> putI1X arg - Ins_allocate arg -> putopcode 111 >> putI1X arg - Ins_deallocate -> putopcode 112 - Ins_call arg -> putopcode 113 >> putI1LX arg - Ins_call_name arg -> putopcode 114 >> putI1CWPX arg - Ins_execute arg -> putopcode 115 >> putLX arg - Ins_execute_name arg -> putopcode 116 >> putCWPX arg - Ins_proceed -> putopcode 117 - Ins_try_me_else arg -> putopcode 118 >> putI1LX arg - Ins_retry_me_else arg -> putopcode 119 >> putI1LX arg - Ins_trust_me arg -> putopcode 120 >> putI1WPX arg - Ins_try arg -> putopcode 121 >> putI1LX arg - Ins_retry arg -> putopcode 122 >> putI1LX arg - Ins_trust arg -> putopcode 123 >> putI1LWPX arg - Ins_trust_ext arg -> putopcode 124 >> putI1NX arg - Ins_try_else arg -> putopcode 125 >> putI1LLX arg - Ins_retry_else arg -> putopcode 126 >> putI1LLX arg - Ins_branch arg -> putopcode 127 >> putLX arg - Ins_switch_on_term arg -> putopcode 128 >> putLLLLX arg - Ins_switch_on_constant arg -> putopcode 129 >> putI1HTX arg - Ins_switch_on_bvar arg -> putopcode 130 >> putI1BVTX arg - Ins_switch_on_reg arg -> putopcode 131 >> putNLLX arg - Ins_neck_cut -> putopcode 132 - Ins_get_level arg -> putopcode 133 >> putEX arg - Ins_put_level arg -> putopcode 134 >> putEX arg - Ins_cut arg -> putopcode 135 >> putEX arg - Ins_call_builtin arg -> putopcode 136 >> putI1I1WPX arg - Ins_builtin arg -> putopcode 137 >> putI1X arg - Ins_stop -> putopcode 138 - Ins_halt -> putopcode 139 - Ins_fail -> putopcode 140 - Ins_create_type_variable arg -> putopcode 141 >> putEX arg - Ins_execute_link_only arg -> putopcode 142 >> putCWPX arg - Ins_call_link_only arg -> putopcode 143 >> putI1CWPX arg - Ins_put_variable_te arg -> putopcode 144 >> putRRX arg - -getInstruction :: Get (Instruction,Int) -getInstruction = do - opcode <- getopcode - case opcode of - 0 -> getRRX >>= \x -> return (Ins_put_variable_t x, inscatRRX_LEN) - 1 -> getERX >>= \x -> return (Ins_put_variable_p x, inscatERX_LEN) - 2 -> getRRX >>= \x -> return (Ins_put_value_t x, inscatRRX_LEN) - 3 -> getERX >>= \x -> return (Ins_put_value_p x, inscatERX_LEN) - 4 -> getERX >>= \x -> return (Ins_put_unsafe_value x, inscatERX_LEN) - 5 -> getERX >>= \x -> return (Ins_copy_value x, inscatERX_LEN) - 6 -> getRCX >>= \x -> return (Ins_put_m_const x, inscatRCX_LEN) - 7 -> getRCX >>= \x -> return (Ins_put_p_const x, inscatRCX_LEN) - 8 -> getRX >>= \x -> return (Ins_put_nil x, inscatRX_LEN) - 9 -> getRIX >>= \x -> return (Ins_put_integer x, inscatRIX_LEN) - 10 -> getRFX >>= \x -> return (Ins_put_float x, inscatRFX_LEN) - 11 -> getRSX >>= \x -> return (Ins_put_string x, inscatRSX_LEN) - 12 -> getRI1X >>= \x -> return (Ins_put_index x, inscatRI1X_LEN) - 13 -> getRRI1X >>= \x -> return (Ins_put_app x, inscatRRI1X_LEN) - 14 -> getRX >>= \x -> return (Ins_put_list x, inscatRX_LEN) - 15 -> getRRI1X >>= \x -> return (Ins_put_lambda x, inscatRRI1X_LEN) - 16 -> getRX >>= \x -> return (Ins_set_variable_t x, inscatRX_LEN) - 17 -> getRX >>= \x -> return (Ins_set_variable_te x, inscatRX_LEN) - 18 -> getEX >>= \x -> return (Ins_set_variable_p x, inscatEX_LEN) - 19 -> getRX >>= \x -> return (Ins_set_value_t x, inscatRX_LEN) - 20 -> getEX >>= \x -> return (Ins_set_value_p x, inscatEX_LEN) - 21 -> getERX >>= \x -> return (Ins_globalize_pt x, inscatERX_LEN) - 22 -> getRX >>= \x -> return (Ins_globalize_t x, inscatRX_LEN) - 23 -> getCX >>= \x -> return (Ins_set_m_const x, inscatCX_LEN) - 24 -> getCX >>= \x -> return (Ins_set_p_const x, inscatCX_LEN) - 25 -> return (Ins_set_nil, inscatX_LEN) - 26 -> getIX >>= \x -> return (Ins_set_integer x, inscatIX_LEN) - 27 -> getFX >>= \x -> return (Ins_set_float x, inscatFX_LEN) - 28 -> getSX >>= \x -> return (Ins_set_string x, inscatSX_LEN) - 29 -> getI1X >>= \x -> return (Ins_set_index x, inscatI1X_LEN) - 30 -> getI1X >>= \x -> return (Ins_set_void x, inscatI1X_LEN) - 31 -> getRX >>= \x -> return (Ins_deref x, inscatRX_LEN) - 32 -> getRI1X >>= \x -> return (Ins_set_lambda x, inscatRI1X_LEN) - 33 -> getRRX >>= \x -> return (Ins_get_variable_t x, inscatRRX_LEN) - 34 -> getERX >>= \x -> return (Ins_get_variable_p x, inscatERX_LEN) - 35 -> getRCEX >>= \x -> return (Ins_init_variable_t x, inscatRCEX_LEN) - 36 -> getECEX >>= \x -> return (Ins_init_variable_p x, inscatECEX_LEN) - 37 -> getRCX >>= \x -> return (Ins_get_m_constant x, inscatRCX_LEN) - 38 -> getRCLX >>= \x -> return (Ins_get_p_constant x, inscatRCLX_LEN) - 39 -> getRIX >>= \x -> return (Ins_get_integer x, inscatRIX_LEN) - 40 -> getRFX >>= \x -> return (Ins_get_float x, inscatRFX_LEN) - 41 -> getRSX >>= \x -> return (Ins_get_string x, inscatRSX_LEN) - 42 -> getRX >>= \x -> return (Ins_get_nil x, inscatRX_LEN) - 43 -> getRCI1X >>= \x -> return (Ins_get_m_structure x, inscatRCI1X_LEN) - 44 -> getRCI1X >>= \x -> return (Ins_get_p_structure x, inscatRCI1X_LEN) - 45 -> getRX >>= \x -> return (Ins_get_list x, inscatRX_LEN) - 46 -> getRX >>= \x -> return (Ins_unify_variable_t x, inscatRX_LEN) - 47 -> getEX >>= \x -> return (Ins_unify_variable_p x, inscatEX_LEN) - 48 -> getRX >>= \x -> return (Ins_unify_value_t x, inscatRX_LEN) - 49 -> getEX >>= \x -> return (Ins_unify_value_p x, inscatEX_LEN) - 50 -> getRX >>= \x -> return (Ins_unify_local_value_t x, inscatRX_LEN) - 51 -> getEX >>= \x -> return (Ins_unify_local_value_p x, inscatEX_LEN) - 52 -> getCX >>= \x -> return (Ins_unify_m_constant x, inscatCX_LEN) - 53 -> getCLX >>= \x -> return (Ins_unify_p_constant x, inscatCLX_LEN) - 54 -> getIX >>= \x -> return (Ins_unify_integer x, inscatIX_LEN) - 55 -> getFX >>= \x -> return (Ins_unify_float x, inscatFX_LEN) - 56 -> getSX >>= \x -> return (Ins_unify_string x, inscatSX_LEN) - 57 -> return (Ins_unify_nil, inscatX_LEN) - 58 -> getI1X >>= \x -> return (Ins_unify_void x, inscatI1X_LEN) - 59 -> getRRX >>= \x -> return (Ins_put_type_variable_t x, inscatRRX_LEN) - 60 -> getERX >>= \x -> return (Ins_put_type_variable_p x, inscatERX_LEN) - 61 -> getRRX >>= \x -> return (Ins_put_type_value_t x, inscatRRX_LEN) - 62 -> getERX >>= \x -> return (Ins_put_type_value_p x, inscatERX_LEN) - 63 -> getERX >>= \x -> return (Ins_put_type_unsafe_value x, inscatERX_LEN) - 64 -> getRKX >>= \x -> return (Ins_put_type_const x, inscatRKX_LEN) - 65 -> getRKX >>= \x -> return (Ins_put_type_structure x, inscatRKX_LEN) - 66 -> getRX >>= \x -> return (Ins_put_type_arrow x, inscatRX_LEN) - 67 -> getRX >>= \x -> return (Ins_set_type_variable_t x, inscatRX_LEN) - 68 -> getEX >>= \x -> return (Ins_set_type_variable_p x, inscatEX_LEN) - 69 -> getRX >>= \x -> return (Ins_set_type_value_t x, inscatRX_LEN) - 70 -> getEX >>= \x -> return (Ins_set_type_value_p x, inscatEX_LEN) - 71 -> getRX >>= \x -> return (Ins_set_type_local_value_t x, inscatRX_LEN) - 72 -> getEX >>= \x -> return (Ins_set_type_local_value_p x, inscatEX_LEN) - 73 -> getKX >>= \x -> return (Ins_set_type_constant x, inscatKX_LEN) - 74 -> getRRX >>= \x -> return (Ins_get_type_variable_t x, inscatRRX_LEN) - 75 -> getERX >>= \x -> return (Ins_get_type_variable_p x, inscatERX_LEN) - 76 -> getRCEX >>= \x -> return (Ins_init_type_variable_t x, inscatRCEX_LEN) - 77 -> getECEX >>= \x -> return (Ins_init_type_variable_p x, inscatECEX_LEN) - 78 -> getRRX >>= \x -> return (Ins_get_type_value_t x, inscatRRX_LEN) - 79 -> getERX >>= \x -> return (Ins_get_type_value_p x, inscatERX_LEN) - 80 -> getRKX >>= \x -> return (Ins_get_type_constant x, inscatRKX_LEN) - 81 -> getRKX >>= \x -> return (Ins_get_type_structure x, inscatRKX_LEN) - 82 -> getRX >>= \x -> return (Ins_get_type_arrow x, inscatRX_LEN) - 83 -> getRX >>= \x -> return (Ins_unify_type_variable_t x, inscatRX_LEN) - 84 -> getEX >>= \x -> return (Ins_unify_type_variable_p x, inscatEX_LEN) - 85 -> getRX >>= \x -> return (Ins_unify_type_value_t x, inscatRX_LEN) - 86 -> getEX >>= \x -> return (Ins_unify_type_value_p x, inscatEX_LEN) - 87 -> getRX >>= \x -> return (Ins_unify_envty_value_t x, inscatRX_LEN) - 88 -> getEX >>= \x -> return (Ins_unify_envty_value_p x, inscatEX_LEN) - 89 -> getRX >>= \x -> return (Ins_unify_type_local_value_t x, inscatRX_LEN) - 90 -> getEX >>= \x -> return (Ins_unify_type_local_value_p x, inscatEX_LEN) - 91 -> getRX >>= \x -> return (Ins_unify_envty_local_value_t x, inscatRX_LEN) - 92 -> getEX >>= \x -> return (Ins_unify_envty_local_value_p x, inscatEX_LEN) - 93 -> getKX >>= \x -> return (Ins_unify_type_constant x, inscatKX_LEN) - 94 -> getRRX >>= \x -> return (Ins_pattern_unify_t x, inscatRRX_LEN) - 95 -> getERX >>= \x -> return (Ins_pattern_unify_p x, inscatERX_LEN) - 96 -> return (Ins_finish_unify, inscatX_LEN) - 97 -> getRX >>= \x -> return (Ins_head_normalize_t x, inscatRX_LEN) - 98 -> getEX >>= \x -> return (Ins_head_normalize_p x, inscatEX_LEN) - 99 -> return (Ins_incr_universe, inscatX_LEN) - 100 -> return (Ins_decr_universe, inscatX_LEN) - 101 -> getECX >>= \x -> return (Ins_set_univ_tag x, inscatECX_LEN) - 102 -> getRX >>= \x -> return (Ins_tag_exists_t x, inscatRX_LEN) - 103 -> getEX >>= \x -> return (Ins_tag_exists_p x, inscatEX_LEN) - 104 -> getEX >>= \x -> return (Ins_tag_variable x, inscatEX_LEN) - 105 -> getI1ITX >>= \x -> return (Ins_push_impl_point x, inscatI1ITX_LEN) - 106 -> return (Ins_pop_impl_point, inscatX_LEN) - 107 -> getSEGI1LX >>= \x -> return (Ins_add_imports x, inscatSEGI1LX_LEN) - 108 -> getSEGLX >>= \x -> return (Ins_remove_imports x, inscatSEGLX_LEN) - 109 -> getMTX >>= \x -> return (Ins_push_import x, inscatMTX_LEN) - 110 -> getI1X >>= \x -> return (Ins_pop_imports x, inscatI1X_LEN) - 111 -> getI1X >>= \x -> return (Ins_allocate x, inscatI1X_LEN) - 112 -> return (Ins_deallocate, inscatX_LEN) - 113 -> getI1LX >>= \x -> return (Ins_call x, inscatI1LX_LEN) - 114 -> getI1CWPX >>= \x -> return (Ins_call_name x, inscatI1CWPX_LEN) - 115 -> getLX >>= \x -> return (Ins_execute x, inscatLX_LEN) - 116 -> getCWPX >>= \x -> return (Ins_execute_name x, inscatCWPX_LEN) - 117 -> return (Ins_proceed, inscatX_LEN) - 118 -> getI1LX >>= \x -> return (Ins_try_me_else x, inscatI1LX_LEN) - 119 -> getI1LX >>= \x -> return (Ins_retry_me_else x, inscatI1LX_LEN) - 120 -> getI1WPX >>= \x -> return (Ins_trust_me x, inscatI1WPX_LEN) - 121 -> getI1LX >>= \x -> return (Ins_try x, inscatI1LX_LEN) - 122 -> getI1LX >>= \x -> return (Ins_retry x, inscatI1LX_LEN) - 123 -> getI1LWPX >>= \x -> return (Ins_trust x, inscatI1LWPX_LEN) - 124 -> getI1NX >>= \x -> return (Ins_trust_ext x, inscatI1NX_LEN) - 125 -> getI1LLX >>= \x -> return (Ins_try_else x, inscatI1LLX_LEN) - 126 -> getI1LLX >>= \x -> return (Ins_retry_else x, inscatI1LLX_LEN) - 127 -> getLX >>= \x -> return (Ins_branch x, inscatLX_LEN) - 128 -> getLLLLX >>= \x -> return (Ins_switch_on_term x, inscatLLLLX_LEN) - 129 -> getI1HTX >>= \x -> return (Ins_switch_on_constant x, inscatI1HTX_LEN) - 130 -> getI1BVTX >>= \x -> return (Ins_switch_on_bvar x, inscatI1BVTX_LEN) - 131 -> getNLLX >>= \x -> return (Ins_switch_on_reg x, inscatNLLX_LEN) - 132 -> return (Ins_neck_cut, inscatX_LEN) - 133 -> getEX >>= \x -> return (Ins_get_level x, inscatEX_LEN) - 134 -> getEX >>= \x -> return (Ins_put_level x, inscatEX_LEN) - 135 -> getEX >>= \x -> return (Ins_cut x, inscatEX_LEN) - 136 -> getI1I1WPX >>= \x -> return (Ins_call_builtin x, inscatI1I1WPX_LEN) - 137 -> getI1X >>= \x -> return (Ins_builtin x, inscatI1X_LEN) - 138 -> return (Ins_stop, inscatX_LEN) - 139 -> return (Ins_halt, inscatX_LEN) - 140 -> return (Ins_fail, inscatX_LEN) - 141 -> getEX >>= \x -> return (Ins_create_type_variable x, inscatEX_LEN) - 142 -> getCWPX >>= \x -> return (Ins_execute_link_only x, inscatCWPX_LEN) - 143 -> getI1CWPX >>= \x -> return (Ins_call_link_only x, inscatI1CWPX_LEN) - 144 -> getRRX >>= \x -> return (Ins_put_variable_te x, inscatRRX_LEN) - - -showInstruction :: Instruction -> (String, Int) -showInstruction inst = - case inst of - Ins_put_variable_t arg -> ("put_variable_t " ++ displayRRX arg, inscatRRX_LEN) - Ins_put_variable_p arg -> ("put_variable_p " ++ displayERX arg, inscatERX_LEN) - Ins_put_value_t arg -> ("put_value_t " ++ displayRRX arg, inscatRRX_LEN) - Ins_put_value_p arg -> ("put_value_p " ++ displayERX arg, inscatERX_LEN) - Ins_put_unsafe_value arg -> ("put_unsafe_value " ++ displayERX arg, inscatERX_LEN) - Ins_copy_value arg -> ("copy_value " ++ displayERX arg, inscatERX_LEN) - Ins_put_m_const arg -> ("put_m_const " ++ displayRCX arg, inscatRCX_LEN) - Ins_put_p_const arg -> ("put_p_const " ++ displayRCX arg, inscatRCX_LEN) - Ins_put_nil arg -> ("put_nil " ++ displayRX arg, inscatRX_LEN) - Ins_put_integer arg -> ("put_integer " ++ displayRIX arg, inscatRIX_LEN) - Ins_put_float arg -> ("put_float " ++ displayRFX arg, inscatRFX_LEN) - Ins_put_string arg -> ("put_string " ++ displayRSX arg, inscatRSX_LEN) - Ins_put_index arg -> ("put_index " ++ displayRI1X arg, inscatRI1X_LEN) - Ins_put_app arg -> ("put_app " ++ displayRRI1X arg, inscatRRI1X_LEN) - Ins_put_list arg -> ("put_list " ++ displayRX arg, inscatRX_LEN) - Ins_put_lambda arg -> ("put_lambda " ++ displayRRI1X arg, inscatRRI1X_LEN) - Ins_set_variable_t arg -> ("set_variable_t " ++ displayRX arg, inscatRX_LEN) - Ins_set_variable_te arg -> ("set_variable_te " ++ displayRX arg, inscatRX_LEN) - Ins_set_variable_p arg -> ("set_variable_p " ++ displayEX arg, inscatEX_LEN) - Ins_set_value_t arg -> ("set_value_t " ++ displayRX arg, inscatRX_LEN) - Ins_set_value_p arg -> ("set_value_p " ++ displayEX arg, inscatEX_LEN) - Ins_globalize_pt arg -> ("globalize_pt " ++ displayERX arg, inscatERX_LEN) - Ins_globalize_t arg -> ("globalize_t " ++ displayRX arg, inscatRX_LEN) - Ins_set_m_const arg -> ("set_m_const " ++ displayCX arg, inscatCX_LEN) - Ins_set_p_const arg -> ("set_p_const " ++ displayCX arg, inscatCX_LEN) - Ins_set_nil -> ("set_nil ", inscatX_LEN) - Ins_set_integer arg -> ("set_integer " ++ displayIX arg, inscatIX_LEN) - Ins_set_float arg -> ("set_float " ++ displayFX arg, inscatFX_LEN) - Ins_set_string arg -> ("set_string " ++ displaySX arg, inscatSX_LEN) - Ins_set_index arg -> ("set_index " ++ displayI1X arg, inscatI1X_LEN) - Ins_set_void arg -> ("set_void " ++ displayI1X arg, inscatI1X_LEN) - Ins_deref arg -> ("deref " ++ displayRX arg, inscatRX_LEN) - Ins_set_lambda arg -> ("set_lambda " ++ displayRI1X arg, inscatRI1X_LEN) - Ins_get_variable_t arg -> ("get_variable_t " ++ displayRRX arg, inscatRRX_LEN) - Ins_get_variable_p arg -> ("get_variable_p " ++ displayERX arg, inscatERX_LEN) - Ins_init_variable_t arg -> ("init_variable_t " ++ displayRCEX arg, inscatRCEX_LEN) - Ins_init_variable_p arg -> ("init_variable_p " ++ displayECEX arg, inscatECEX_LEN) - Ins_get_m_constant arg -> ("get_m_constant " ++ displayRCX arg, inscatRCX_LEN) - Ins_get_p_constant arg -> ("get_p_constant " ++ displayRCLX arg, inscatRCLX_LEN) - Ins_get_integer arg -> ("get_integer " ++ displayRIX arg, inscatRIX_LEN) - Ins_get_float arg -> ("get_float " ++ displayRFX arg, inscatRFX_LEN) - Ins_get_string arg -> ("get_string " ++ displayRSX arg, inscatRSX_LEN) - Ins_get_nil arg -> ("get_nil " ++ displayRX arg, inscatRX_LEN) - Ins_get_m_structure arg -> ("get_m_structure " ++ displayRCI1X arg, inscatRCI1X_LEN) - Ins_get_p_structure arg -> ("get_p_structure " ++ displayRCI1X arg, inscatRCI1X_LEN) - Ins_get_list arg -> ("get_list " ++ displayRX arg, inscatRX_LEN) - Ins_unify_variable_t arg -> ("unify_variable_t " ++ displayRX arg, inscatRX_LEN) - Ins_unify_variable_p arg -> ("unify_variable_p " ++ displayEX arg, inscatEX_LEN) - Ins_unify_value_t arg -> ("unify_value_t " ++ displayRX arg, inscatRX_LEN) - Ins_unify_value_p arg -> ("unify_value_p " ++ displayEX arg, inscatEX_LEN) - Ins_unify_local_value_t arg -> ("unify_local_value_t " ++ displayRX arg, inscatRX_LEN) - Ins_unify_local_value_p arg -> ("unify_local_value_p " ++ displayEX arg, inscatEX_LEN) - Ins_unify_m_constant arg -> ("unify_m_constant " ++ displayCX arg, inscatCX_LEN) - Ins_unify_p_constant arg -> ("unify_p_constant " ++ displayCLX arg, inscatCLX_LEN) - Ins_unify_integer arg -> ("unify_integer " ++ displayIX arg, inscatIX_LEN) - Ins_unify_float arg -> ("unify_float " ++ displayFX arg, inscatFX_LEN) - Ins_unify_string arg -> ("unify_string " ++ displaySX arg, inscatSX_LEN) - Ins_unify_nil -> ("unify_nil ", inscatX_LEN) - Ins_unify_void arg -> ("unify_void " ++ displayI1X arg, inscatI1X_LEN) - Ins_put_type_variable_t arg -> ("put_type_variable_t " ++ displayRRX arg, inscatRRX_LEN) - Ins_put_type_variable_p arg -> ("put_type_variable_p " ++ displayERX arg, inscatERX_LEN) - Ins_put_type_value_t arg -> ("put_type_value_t " ++ displayRRX arg, inscatRRX_LEN) - Ins_put_type_value_p arg -> ("put_type_value_p " ++ displayERX arg, inscatERX_LEN) - Ins_put_type_unsafe_value arg -> ("put_type_unsafe_value " ++ displayERX arg, inscatERX_LEN) - Ins_put_type_const arg -> ("put_type_const " ++ displayRKX arg, inscatRKX_LEN) - Ins_put_type_structure arg -> ("put_type_structure " ++ displayRKX arg, inscatRKX_LEN) - Ins_put_type_arrow arg -> ("put_type_arrow " ++ displayRX arg, inscatRX_LEN) - Ins_set_type_variable_t arg -> ("set_type_variable_t " ++ displayRX arg, inscatRX_LEN) - Ins_set_type_variable_p arg -> ("set_type_variable_p " ++ displayEX arg, inscatEX_LEN) - Ins_set_type_value_t arg -> ("set_type_value_t " ++ displayRX arg, inscatRX_LEN) - Ins_set_type_value_p arg -> ("set_type_value_p " ++ displayEX arg, inscatEX_LEN) - Ins_set_type_local_value_t arg -> ("set_type_local_value_t " ++ displayRX arg, inscatRX_LEN) - Ins_set_type_local_value_p arg -> ("set_type_local_value_p " ++ displayEX arg, inscatEX_LEN) - Ins_set_type_constant arg -> ("set_type_constant " ++ displayKX arg, inscatKX_LEN) - Ins_get_type_variable_t arg -> ("get_type_variable_t " ++ displayRRX arg, inscatRRX_LEN) - Ins_get_type_variable_p arg -> ("get_type_variable_p " ++ displayERX arg, inscatERX_LEN) - Ins_init_type_variable_t arg -> ("init_type_variable_t " ++ displayRCEX arg, inscatRCEX_LEN) - Ins_init_type_variable_p arg -> ("init_type_variable_p " ++ displayECEX arg, inscatECEX_LEN) - Ins_get_type_value_t arg -> ("get_type_value_t " ++ displayRRX arg, inscatRRX_LEN) - Ins_get_type_value_p arg -> ("get_type_value_p " ++ displayERX arg, inscatERX_LEN) - Ins_get_type_constant arg -> ("get_type_constant " ++ displayRKX arg, inscatRKX_LEN) - Ins_get_type_structure arg -> ("get_type_structure " ++ displayRKX arg, inscatRKX_LEN) - Ins_get_type_arrow arg -> ("get_type_arrow " ++ displayRX arg, inscatRX_LEN) - Ins_unify_type_variable_t arg -> ("unify_type_variable_t " ++ displayRX arg, inscatRX_LEN) - Ins_unify_type_variable_p arg -> ("unify_type_variable_p " ++ displayEX arg, inscatEX_LEN) - Ins_unify_type_value_t arg -> ("unify_type_value_t " ++ displayRX arg, inscatRX_LEN) - Ins_unify_type_value_p arg -> ("unify_type_value_p " ++ displayEX arg, inscatEX_LEN) - Ins_unify_envty_value_t arg -> ("unify_envty_value_t " ++ displayRX arg, inscatRX_LEN) - Ins_unify_envty_value_p arg -> ("unify_envty_value_p " ++ displayEX arg, inscatEX_LEN) - Ins_unify_type_local_value_t arg -> ("unify_type_local_value_t " ++ displayRX arg, inscatRX_LEN) - Ins_unify_type_local_value_p arg -> ("unify_type_local_value_p " ++ displayEX arg, inscatEX_LEN) - Ins_unify_envty_local_value_t arg -> ("unify_envty_local_value_t " ++ displayRX arg, inscatRX_LEN) - Ins_unify_envty_local_value_p arg -> ("unify_envty_local_value_p " ++ displayEX arg, inscatEX_LEN) - Ins_unify_type_constant arg -> ("unify_type_constant " ++ displayKX arg, inscatKX_LEN) - Ins_pattern_unify_t arg -> ("pattern_unify_t " ++ displayRRX arg, inscatRRX_LEN) - Ins_pattern_unify_p arg -> ("pattern_unify_p " ++ displayERX arg, inscatERX_LEN) - Ins_finish_unify -> ("finish_unify ", inscatX_LEN) - Ins_head_normalize_t arg -> ("head_normalize_t " ++ displayRX arg, inscatRX_LEN) - Ins_head_normalize_p arg -> ("head_normalize_p " ++ displayEX arg, inscatEX_LEN) - Ins_incr_universe -> ("incr_universe ", inscatX_LEN) - Ins_decr_universe -> ("decr_universe ", inscatX_LEN) - Ins_set_univ_tag arg -> ("set_univ_tag " ++ displayECX arg, inscatECX_LEN) - Ins_tag_exists_t arg -> ("tag_exists_t " ++ displayRX arg, inscatRX_LEN) - Ins_tag_exists_p arg -> ("tag_exists_p " ++ displayEX arg, inscatEX_LEN) - Ins_tag_variable arg -> ("tag_variable " ++ displayEX arg, inscatEX_LEN) - Ins_push_impl_point arg -> ("push_impl_point " ++ displayI1ITX arg, inscatI1ITX_LEN) - Ins_pop_impl_point -> ("pop_impl_point ", inscatX_LEN) - Ins_add_imports arg -> ("add_imports " ++ displaySEGI1LX arg, inscatSEGI1LX_LEN) - Ins_remove_imports arg -> ("remove_imports " ++ displaySEGLX arg, inscatSEGLX_LEN) - Ins_push_import arg -> ("push_import " ++ displayMTX arg, inscatMTX_LEN) - Ins_pop_imports arg -> ("pop_imports " ++ displayI1X arg, inscatI1X_LEN) - Ins_allocate arg -> ("allocate " ++ displayI1X arg, inscatI1X_LEN) - Ins_deallocate -> ("deallocate ", inscatX_LEN) - Ins_call arg -> ("call " ++ displayI1LX arg, inscatI1LX_LEN) - Ins_call_name arg -> ("call_name " ++ displayI1CWPX arg, inscatI1CWPX_LEN) - Ins_execute arg -> ("execute " ++ displayLX arg, inscatLX_LEN) - Ins_execute_name arg -> ("execute_name " ++ displayCWPX arg, inscatCWPX_LEN) - Ins_proceed -> ("proceed ", inscatX_LEN) - Ins_try_me_else arg -> ("try_me_else " ++ displayI1LX arg, inscatI1LX_LEN) - Ins_retry_me_else arg -> ("retry_me_else " ++ displayI1LX arg, inscatI1LX_LEN) - Ins_trust_me arg -> ("trust_me " ++ displayI1WPX arg, inscatI1WPX_LEN) - Ins_try arg -> ("try " ++ displayI1LX arg, inscatI1LX_LEN) - Ins_retry arg -> ("retry " ++ displayI1LX arg, inscatI1LX_LEN) - Ins_trust arg -> ("trust " ++ displayI1LWPX arg, inscatI1LWPX_LEN) - Ins_trust_ext arg -> ("trust_ext " ++ displayI1NX arg, inscatI1NX_LEN) - Ins_try_else arg -> ("try_else " ++ displayI1LLX arg, inscatI1LLX_LEN) - Ins_retry_else arg -> ("retry_else " ++ displayI1LLX arg, inscatI1LLX_LEN) - Ins_branch arg -> ("branch " ++ displayLX arg, inscatLX_LEN) - Ins_switch_on_term arg -> ("switch_on_term " ++ displayLLLLX arg, inscatLLLLX_LEN) - Ins_switch_on_constant arg -> ("switch_on_constant " ++ displayI1HTX arg, inscatI1HTX_LEN) - Ins_switch_on_bvar arg -> ("switch_on_bvar " ++ displayI1BVTX arg, inscatI1BVTX_LEN) - Ins_switch_on_reg arg -> ("switch_on_reg " ++ displayNLLX arg, inscatNLLX_LEN) - Ins_neck_cut -> ("neck_cut ", inscatX_LEN) - Ins_get_level arg -> ("get_level " ++ displayEX arg, inscatEX_LEN) - Ins_put_level arg -> ("put_level " ++ displayEX arg, inscatEX_LEN) - Ins_cut arg -> ("cut " ++ displayEX arg, inscatEX_LEN) - Ins_call_builtin arg -> ("call_builtin " ++ displayI1I1WPX arg, inscatI1I1WPX_LEN) - Ins_builtin arg -> ("builtin " ++ displayI1X arg, inscatI1X_LEN) - Ins_stop -> ("stop ", inscatX_LEN) - Ins_halt -> ("halt ", inscatX_LEN) - Ins_fail -> ("fail ", inscatX_LEN) - Ins_create_type_variable arg -> ("create_type_variable " ++ displayEX arg, inscatEX_LEN) - Ins_execute_link_only arg -> ("execute_link_only " ++ displayCWPX arg, inscatCWPX_LEN) - Ins_call_link_only arg -> ("call_link_only " ++ displayI1CWPX arg, inscatI1CWPX_LEN) - Ins_put_variable_te arg -> ("put_variable_te " ++ displayRRX arg, inscatRRX_LEN)
\ No newline at end of file diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs index f4e3a0297..89366568d 100644 --- a/src/compiler/GF/Compile/PGFtoHaskell.hs +++ b/src/compiler/GF/Compile/PGFtoHaskell.hs @@ -56,7 +56,7 @@ haskPreamble gadt name = "import Data.Monoid" ] else []) ++ [ - "import PGF", + "import PGF hiding (Tree)", "----------------------------------------------------", "-- automatic translation from GF to Haskell", "----------------------------------------------------", diff --git a/src/compiler/GF/Compile/PGFtoLProlog.hs b/src/compiler/GF/Compile/PGFtoLProlog.hs deleted file mode 100644 index 28ee6afaf..000000000 --- a/src/compiler/GF/Compile/PGFtoLProlog.hs +++ /dev/null @@ -1,164 +0,0 @@ -module GF.Compile.PGFtoLProlog(grammar2lambdaprolog_mod, grammar2lambdaprolog_sig) where - -import PGF(mkCId,ppCId,showCId,wildCId) -import PGF.Internal hiding (ppExpr,ppType,ppHypo,ppCat,ppFun) ---import PGF.Macros -import Data.List -import Data.Maybe -import GF.Text.Pretty -import qualified Data.Map as Map ---import Debug.Trace - -grammar2lambdaprolog_mod pgf = render $ - "module" <+> ppCId (absname pgf) <> '.' $$ - ' ' $$ - vcat [ppClauses cat fns | (cat,(_,fs,_)) <- Map.toList (cats (abstract pgf)), - let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | (_,f) <- fs]] - where - ppClauses cat fns = - "/*" <+> ppCId cat <+> "*/" $$ - vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_)) <- fns] $$ - ' ' $$ - vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just (eqs,_),_)) <- fns] $$ - ' ' - -grammar2lambdaprolog_sig pgf = render $ - "sig" <+> ppCId (absname pgf) <> '.' $$ - ' ' $$ - vcat [ppCat c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$ - ' ' $$ - vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_)) <- Map.toList (funs (abstract pgf))] $$ - ' ' $$ - vcat [ppExport c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$ - vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_)) <- Map.toList (funs (abstract pgf))] - -ppCat :: CId -> [Hypo] -> Doc -ppCat c hyps = "kind" <+> ppKind c <+> "type" - -ppFun :: CId -> Type -> Doc -ppFun f ty = "type" <+> ppCId f <+> ppType 0 ty - -ppExport :: CId -> [Hypo] -> Doc -ppExport c hyps = "exportdef" <+> ppPred c <+> foldr (\hyp doc -> ppHypo 1 hyp <+> "->" <+> doc) (pp "o") (hyp:hyps) - where - hyp = (Explicit,wildCId,DTyp [] c []) - -ppFunPred :: CId -> [Hypo] -> Doc -ppFunPred c hyps = "exportdef" <+> ppCId c <+> foldr (\hyp doc -> ppHypo 1 hyp <+> "->" <+> doc) (pp "o") hyps - -ppClause :: Abstr -> Int -> Int -> [CId] -> CId -> Type -> (Int,Doc) -ppClause abstr d i scope f ty@(DTyp hyps cat args) - | null hyps = let res = EFun f - (goals,i',head) = ppRes i scope cat (res : args) - in (i',(if null goals - then empty - else hsep (punctuate ',' (map (ppExpr 0 i' scope) goals)) <> ',') - <+> - head) - | otherwise = let (i',vars,scope',hdocs) = ppHypos i [] scope hyps (depType [] ty) - res = foldl EApp (EFun f) (map EFun (reverse vars)) - quants = if d > 0 - then hsep (map (\v -> "pi" <+> ppCId v <+> '\\') vars) - else empty - (goals,i'',head) = ppRes i' scope' cat (res : args) - docs = map (ppExpr 0 i'' scope') goals ++ hdocs - in (i'',ppParens (d > 0) (quants <+> head <+> - (if null docs - then empty - else ":-" <+> hsep (punctuate ',' docs)))) - where - ppRes i scope cat es = - let ((goals,i'),es') = mapAccumL (\(goals,i) e -> let (goals',i',e') = expr2goal abstr scope goals i e [] - in ((goals',i'),e')) ([],i) es - in (goals,i',ppParens (d > 3) (ppPred cat <+> hsep (map (ppExpr 4 i' scope) es'))) - - ppHypos :: Int -> [CId] -> [CId] -> [(BindType,CId,Type)] -> [Int] -> (Int,[CId],[CId],[Doc]) - ppHypos i vars scope [] [] - = (i,vars,scope,[]) - ppHypos i vars scope ((_,x,typ):hyps) (c:cs) - | x /= wildCId = let v = mkVar i - (i',doc) = ppClause abstr 1 (i+1) scope v typ - (i'',vars',scope',docs) = ppHypos i' (v:vars) (v:scope) hyps cs - in (i'',vars',scope',if c == 0 then doc : docs else docs) - ppHypos i vars scope ((_,x,typ):hyps) cs - = let v = mkVar i - (i',doc) = ppClause abstr 1 (i+1) scope v typ - (i'',vars',scope',docs) = ppHypos i' (v:vars) scope hyps cs - in (i'',vars',scope',doc : docs) - -mkVar i = mkCId ("X_"++show i) - -ppPred :: CId -> Doc -ppPred cat = "p_" <> ppCId cat - -ppKind :: CId -> Doc -ppKind cat = "k_" <> ppCId cat - -ppType :: Int -> Type -> Doc -ppType d (DTyp hyps cat args) - | null hyps = ppKind cat - | otherwise = ppParens (d > 0) (foldr (\hyp doc -> ppHypo 1 hyp <+> "->" <+> doc) (ppKind cat) hyps) - -ppHypo d (_,_,typ) = ppType d typ - -ppExpr d i scope (EAbs b x e) = let v = mkVar i - in ppParens (d > 1) (ppCId v <+> '\\' <+> ppExpr 1 (i+1) (v:scope) e) -ppExpr d i scope (EApp e1 e2) = ppParens (d > 3) ((ppExpr 3 i scope e1) <+> (ppExpr 4 i scope e2)) -ppExpr d i scope (ELit l) = ppLit l -ppExpr d i scope (EMeta n) = ppMeta n -ppExpr d i scope (EFun f) = ppCId f -ppExpr d i scope (EVar j) = ppCId (scope !! j) -ppExpr d i scope (ETyped e ty)= ppExpr d i scope e -ppExpr d i scope (EImplArg e) = ppExpr 0 i scope e - -dot = '.' - -depType counts (DTyp hyps cat es) = - foldl' depExpr (foldl' depHypo counts hyps) es - -depHypo counts (_,x,ty) - | x == wildCId = depType counts ty - | otherwise = 0:depType counts ty - -depExpr counts (EAbs b x e) = tail (depExpr (0:counts) e) -depExpr counts (EApp e1 e2) = depExpr (depExpr counts e1) e2 -depExpr counts (ELit l) = counts -depExpr counts (EMeta n) = counts -depExpr counts (EFun f) = counts -depExpr counts (EVar j) = let (xs,c:ys) = splitAt j counts - in xs++(c+1):ys -depExpr counts (ETyped e ty)= depExpr counts e -depExpr counts (EImplArg e) = depExpr counts e - -equation2clause abstr f (Equ ps e) = - let scope0 = foldl pattScope [] ps - scope = [mkVar i | i <- [0..n-1]] - n = length scope0 - - es = map (patt2expr scope0) ps - - (goals,_,goal) = expr2goal abstr scope [] n e [] - - in ppCId f <+> hsep (map (ppExpr 4 n scope) (es++[goal])) <+> - if null goals - then empty - else ":-" <+> hsep (punctuate ',' (map (ppExpr 0 n scope) (reverse goals))) - - -patt2expr scope (PApp f ps) = foldl EApp (EFun f) (map (patt2expr scope) ps) -patt2expr scope (PLit l) = ELit l -patt2expr scope (PVar x) = case findIndex (==x) scope of - Just i -> EVar i - Nothing -> error ("unknown variable "++showCId x) -patt2expr scope (PImplArg p)= EImplArg (patt2expr scope p) - -expr2goal abstr scope goals i (EApp e1 e2) args = - let (goals',i',e2') = expr2goal abstr scope goals i e2 [] - in expr2goal abstr scope goals' i' e1 (e2':args) -expr2goal abstr scope goals i (EFun f) args = - case Map.lookup f (funs abstr) of - Just (_,_,Just _,_) -> let e = EFun (mkVar i) - in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e) - _ -> (goals,i,foldl EApp (EFun f) args) -expr2goal abstr scope goals i (EVar j) args = - (goals,i,foldl EApp (EVar j) args) diff --git a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs index 2fe08b256..88e324ff3 100644 --- a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs @@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards #-} module GF.Compile.TypeCheck.RConcrete( checkLType, inferLType, computeLType, ppType ) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import GF.Infra.CheckM import GF.Data.Operations diff --git a/src/compiler/GF/CompileInParallel.hs b/src/compiler/GF/CompileInParallel.hs index 7986656ec..8420b1771 100644 --- a/src/compiler/GF/CompileInParallel.hs +++ b/src/compiler/GF/CompileInParallel.hs @@ -1,6 +1,6 @@ -- | Parallel grammar compilation module GF.CompileInParallel(parallelBatchCompile) where -import Prelude hiding (catch) +import Prelude hiding (catch,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import Control.Monad(join,ap,when,unless) import Control.Applicative import GF.Infra.Concurrency diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs index 7fbaed9e4..aa7b80268 100644 --- a/src/compiler/GF/Compiler.hs +++ b/src/compiler/GF/Compiler.hs @@ -56,7 +56,7 @@ compileSourceFiles opts fs = return (t,[cnc_gr]) cncs2haskell output = - when (FmtHaskell `elem` outputFormats opts && + when (FmtHaskell `elem` flag optOutputFormats opts && haskellOption opts HaskellConcrete) $ mapM_ cnc2haskell (snd output) @@ -130,7 +130,7 @@ unionPGFFiles opts fs = writeOutputs :: Options -> PGF -> IOE () writeOutputs opts pgf = do sequence_ [writeOutput opts name str - | fmt <- outputFormats opts, + | fmt <- flag optOutputFormats opts, (name,str) <- exportPGF opts fmt pgf] -- | Write the result of compiling a grammar (e.g. with 'compileToPGF' or @@ -163,7 +163,6 @@ grammarName :: Options -> PGF -> String grammarName opts pgf = grammarName' opts (showCId (abstractName pgf)) grammarName' opts abs = fromMaybe abs (flag optName opts) -outputFormats opts = [fmt | fmt <- flag optOutputFormats opts, fmt/=FmtByteCode] outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts) outputPath opts file = maybe id (</>) (flag optOutputDir opts) file diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index dcd419c42..4b19d215b 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -22,6 +22,7 @@ module GF.Grammar.Printer , ppMeta
, getAbs
) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Infra.Ident
import GF.Infra.Option
diff --git a/src/compiler/GF/Haskell.hs b/src/compiler/GF/Haskell.hs index e2156ac5d..57601c1d5 100644 --- a/src/compiler/GF/Haskell.hs +++ b/src/compiler/GF/Haskell.hs @@ -1,6 +1,7 @@ -- | Abstract syntax and a pretty printer for a subset of Haskell {-# LANGUAGE DeriveFunctor #-} module GF.Haskell where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import GF.Infra.Ident(Ident,identS) import GF.Text.Pretty diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index 3b6833f0f..c5f9ba255 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -18,6 +18,7 @@ module GF.Infra.CheckM checkIn, checkInModule, checkMap, checkMapRecover, parallelCheck, accumulateError, commitCheck, ) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import GF.Data.Operations --import GF.Infra.Ident diff --git a/src/compiler/GF/Infra/Location.hs b/src/compiler/GF/Infra/Location.hs index 0bf85b37f..8447a297c 100644 --- a/src/compiler/GF/Infra/Location.hs +++ b/src/compiler/GF/Infra/Location.hs @@ -1,5 +1,6 @@ -- | Source locations module GF.Infra.Location where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import GF.Text.Pretty -- ** Source locations diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index efd59ca0b..f68c7d121 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -92,8 +92,6 @@ data OutputFormat = FmtPGFPretty | FmtHaskell | FmtJava | FmtProlog - | FmtLambdaProlog - | FmtByteCode | FmtBNF | FmtEBNF | FmtRegular @@ -478,8 +476,6 @@ outputFormatsExpl = (("haskell", FmtHaskell),"Haskell (abstract syntax)"), (("java", FmtJava),"Java (abstract syntax)"), (("prolog", FmtProlog),"Prolog (whole grammar)"), - (("lambda_prolog",FmtLambdaProlog),"LambdaProlog (abstract syntax)"), - (("lp_byte_code", FmtByteCode),"Bytecode for Teyjus (abstract syntax, experimental)"), (("bnf", FmtBNF),"BNF (context-free grammar)"), (("ebnf", FmtEBNF),"Extended BNF"), (("regular", FmtRegular),"* regular grammar"), diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs index de0ec6abc..1ca6f399d 100644 --- a/src/compiler/GF/Server.hs +++ b/src/compiler/GF/Server.hs @@ -33,7 +33,7 @@ import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache) --import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi import Network.CGI(handleErrors,liftIO) import CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile -import Text.JSON(encode,showJSON,makeObj) +import Text.JSON(JSValue(..),Result(..),valFromObj,encode,decode,showJSON,makeObj) --import System.IO.Silently(hCapture) import System.Process(readProcessWithExitCode) import System.Exit(ExitCode(..)) @@ -283,13 +283,17 @@ handle logLn documentroot state0 cache execute1 stateVar skip_empty = filter (not.null.snd) jsonList = jsonList' return - jsonListLong = jsonList' (mapM addTime) + jsonListLong ext = jsonList' (mapM (addTime ext)) ext jsonList' details ext = fmap (json200) (details =<< ls_ext "." ext) - addTime path = + addTime ext path = do t <- getModificationTime path - return $ makeObj ["path".=path,"time".=format t] + if ext==".json" + then addComment (time t) <$> liftIO (try $ getComment path) + else return . makeObj $ time t where + addComment t = makeObj . either (const t) (\c->t++["comment".=c]) + time t = ["path".=path,"time".=format t] format = formatTime defaultTimeLocale rfc822DateFormat rm path | takeExtension path `elem` ok_to_delete = @@ -331,6 +335,11 @@ handle logLn documentroot state0 cache execute1 stateVar do paths <- getDirectoryContents dir return [path | path<-paths, takeExtension path==ext] + getComment path = + do Ok (JSObject obj) <- decode <$> readFile path + Ok cmnt <- return (valFromObj "comment" obj) + return (cmnt::String) + -- * Dynamic content jsonresult cwd dir cmd (ecode,stdout,stderr) files = diff --git a/src/compiler/GF/Speech/GSL.hs b/src/compiler/GF/Speech/GSL.hs index d9d6af0cc..a898a4bb5 100644 --- a/src/compiler/GF/Speech/GSL.hs +++ b/src/compiler/GF/Speech/GSL.hs @@ -7,6 +7,7 @@ ----------------------------------------------------------------------------- module GF.Speech.GSL (gslPrinter) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint --import GF.Data.Utilities import GF.Grammar.CFG diff --git a/src/compiler/GF/Speech/JSGF.hs b/src/compiler/GF/Speech/JSGF.hs index 25168dbc8..15f5ff69d 100644 --- a/src/compiler/GF/Speech/JSGF.hs +++ b/src/compiler/GF/Speech/JSGF.hs @@ -11,6 +11,7 @@ ----------------------------------------------------------------------------- module GF.Speech.JSGF (jsgfPrinter) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint --import GF.Data.Utilities import GF.Infra.Option diff --git a/src/compiler/GF/Speech/SRGS_ABNF.hs b/src/compiler/GF/Speech/SRGS_ABNF.hs index 75d206a0c..dc5c7bbd3 100644 --- a/src/compiler/GF/Speech/SRGS_ABNF.hs +++ b/src/compiler/GF/Speech/SRGS_ABNF.hs @@ -18,6 +18,7 @@ ----------------------------------------------------------------------------- module GF.Speech.SRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint --import GF.Data.Utilities import GF.Infra.Option diff --git a/src/runtime/c/Makefile.am b/src/runtime/c/Makefile.am index 9f6ce9a76..edc4f88b2 100644 --- a/src/runtime/c/Makefile.am +++ b/src/runtime/c/Makefile.am @@ -34,7 +34,8 @@ pgfinclude_HEADERS = \ pgf/linearizer.h \ pgf/literals.h \ pgf/graphviz.h \ - pgf/pgf.h + pgf/pgf.h \ + pgf/data.h sgincludedir=$(includedir)/sg sginclude_HEADERS = \ @@ -75,6 +76,8 @@ libpgf_la_SOURCES = \ pgf/literals.h \ pgf/reader.h \ pgf/reader.c \ + pgf/writer.h \ + pgf/writer.c \ pgf/linearizer.c \ pgf/typechecker.c \ pgf/reasoner.c \ diff --git a/src/runtime/c/gu/bits.c b/src/runtime/c/gu/bits.c index 8c43b8477..b5696a19c 100644 --- a/src/runtime/c/gu/bits.c +++ b/src/runtime/c/gu/bits.c @@ -41,3 +41,36 @@ gu_decode_double(uint64_t u) } return sign ? copysign(ret, -1.0) : ret; } + +GU_INTERNAL uint64_t +gu_encode_double(double d) +{ + int sign = signbit(d) > 0; + unsigned rawexp; + uint64_t mantissa; + + switch (fpclassify(d)) { + case FP_NAN: + rawexp = 0x7ff; + mantissa = 1; + break; + case FP_INFINITE: + rawexp = 0x7ff; + mantissa = 0; + break; + default: { + int exp; + mantissa = (uint64_t) scalbn(frexp(d, &exp), 53); + mantissa &= ~ (1ULL << 52); + exp -= 53; + + rawexp = exp + 1075; + } + } + + uint64_t u = (((uint64_t) sign) << 63) | + (((uint64_t) rawexp & 0x7ff) << 52) | + mantissa; + + return u; +} diff --git a/src/runtime/c/gu/bits.h b/src/runtime/c/gu/bits.h index edf6a0049..ee619f400 100644 --- a/src/runtime/c/gu/bits.h +++ b/src/runtime/c/gu/bits.h @@ -144,6 +144,7 @@ gu_decode_2c64(uint64_t u, GuExn* err) GU_INTERNAL_DECL double gu_decode_double(uint64_t u); - +GU_INTERNAL_DECL uint64_t +gu_encode_double(double d); #endif // GU_BITS_H_ diff --git a/src/runtime/c/gu/defs.h b/src/runtime/c/gu/defs.h index 6b531979c..f5472a414 100644 --- a/src/runtime/c/gu/defs.h +++ b/src/runtime/c/gu/defs.h @@ -23,6 +23,14 @@ #define restrict __restrict +#elif defined(__MINGW32__) + +#define GU_API_DECL +#define GU_API + +#define GU_INTERNAL_DECL +#define GU_INTERNAL + #else #define GU_API_DECL @@ -30,7 +38,9 @@ #define GU_INTERNAL_DECL __attribute__ ((visibility ("hidden"))) #define GU_INTERNAL __attribute__ ((visibility ("hidden"))) + #endif + // end MSVC workaround #include <stddef.h> diff --git a/src/runtime/c/gu/in.c b/src/runtime/c/gu/in.c index b36df7924..c241d3086 100644 --- a/src/runtime/c/gu/in.c +++ b/src/runtime/c/gu/in.c @@ -152,7 +152,7 @@ gu_in_le(GuIn* in, GuExn* err, int n) uint8_t buf[8]; gu_in_bytes(in, buf, n, err); uint64_t u = 0; - for (int i = 0; i < n; i++) { + for (int i = n-1; i >= 0; i--) { u = u << 8 | buf[i]; } return u; @@ -246,7 +246,7 @@ gu_in_f64le(GuIn* in, GuExn* err) GU_API double gu_in_f64be(GuIn* in, GuExn* err) { - return gu_decode_double(gu_in_u64le(in, err)); + return gu_decode_double(gu_in_u64be(in, err)); } static void diff --git a/src/runtime/c/gu/out.c b/src/runtime/c/gu/out.c index 7a287cadb..164f483d1 100644 --- a/src/runtime/c/gu/out.c +++ b/src/runtime/c/gu/out.c @@ -1,6 +1,7 @@ #include <gu/seq.h> #include <gu/out.h> #include <gu/utf8.h> +#include <gu/bits.h> #include <stdio.h> static bool @@ -168,8 +169,31 @@ gu_out_is_buffered(GuOut* out); extern inline bool gu_out_try_u8_(GuOut* restrict out, uint8_t u); +GU_API void +gu_out_u16be(GuOut* out, uint16_t u, GuExn* err) +{ + gu_out_u8(out, (u>>8) & 0xFF, err); + gu_out_u8(out, u & 0xFF, err); +} +GU_API void +gu_out_u64be(GuOut* out, uint64_t u, GuExn* err) +{ + gu_out_u8(out, (u>>56) & 0xFF, err); + gu_out_u8(out, (u>>48) & 0xFF, err); + gu_out_u8(out, (u>>40) & 0xFF, err); + gu_out_u8(out, (u>>32) & 0xFF, err); + gu_out_u8(out, (u>>24) & 0xFF, err); + gu_out_u8(out, (u>>16) & 0xFF, err); + gu_out_u8(out, (u>>8) & 0xFF, err); + gu_out_u8(out, u & 0xFF, err); +} +GU_API void +gu_out_f64be(GuOut* out, double d, GuExn* err) +{ + gu_out_u64be(out, gu_encode_double(d), err); +} typedef struct GuBufferedOutStream GuBufferedOutStream; diff --git a/src/runtime/c/pgf/aligner.c b/src/runtime/c/pgf/aligner.c index d143850d6..53209bb4c 100644 --- a/src/runtime/c/pgf/aligner.c +++ b/src/runtime/c/pgf/aligner.c @@ -142,14 +142,14 @@ pgf_aligner_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok) } static void -pgf_aligner_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_aligner_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfAlignerLin* alin = gu_container(funcs, PgfAlignerLin, funcs); gu_buf_push(alin->parent_stack, int, fid); } static void -pgf_aligner_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_aligner_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfAlignerLin* alin = gu_container(funcs, PgfAlignerLin, funcs); gu_buf_pop(alin->parent_stack, int); diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index 83aff155f..45685c82d 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -351,4 +351,20 @@ struct PgfCCat { GuFinalizer fin[0]; }; +PGF_API_DECL bool +pgf_production_is_lexical(PgfProductionApply *papp, + GuBuf* non_lexical_buf, GuPool* pool); + +PGF_API_DECL void +pgf_parser_index(PgfConcr* concr, + PgfCCat* ccat, PgfProduction prod, + bool is_lexical, + GuPool *pool); + +PGF_API_DECL void +pgf_lzr_index(PgfConcr* concr, + PgfCCat* ccat, PgfProduction prod, + bool is_lexical, + GuPool *pool); + #endif diff --git a/src/runtime/c/pgf/expr.c b/src/runtime/c/pgf/expr.c index f9fcd1442..92e92f04f 100644 --- a/src/runtime/c/pgf/expr.c +++ b/src/runtime/c/pgf/expr.c @@ -224,20 +224,24 @@ typedef enum { PGF_TOKEN_EOF, } PGF_TOKEN_TAG; +typedef GuUCS (*PgfParserGetc)(void* state, bool mark, GuExn* err); + struct PgfExprParser { GuExn* err; - GuIn* in; GuPool* expr_pool; GuPool* tmp_pool; PGF_TOKEN_TAG token_tag; GuStringBuf* token_value; + + void* getch_state; + PgfParserGetc getch; GuUCS ch; }; static void -pgf_expr_parser_getc(PgfExprParser* parser) +pgf_expr_parser_getc(PgfExprParser* parser, bool mark) { - parser->ch = gu_in_utf8(parser->in, parser->err); + parser->ch = parser->getch(parser->getch_state, mark, parser->err); if (!gu_ok(parser->err)) { gu_exn_clear(parser->err); parser->ch = EOF; @@ -284,10 +288,11 @@ pgf_is_normal_ident(PgfCId id) } static void -pgf_expr_parser_token(PgfExprParser* parser) +pgf_expr_parser_token(PgfExprParser* parser, bool mark) { while (isspace(parser->ch)) { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); + mark = false; } parser->token_tag = PGF_TOKEN_UNKNOWN; @@ -295,72 +300,73 @@ pgf_expr_parser_token(PgfExprParser* parser) switch (parser->ch) { case EOF: + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_EOF; break; case '(': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_LPAR; break; case ')': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_RPAR; break; case '{': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_LCURLY; break; case '}': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_RCURLY; break; case '<': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_LTRIANGLE; break; case '>': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_RTRIANGLE; break; case '?': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_QUESTION; break; case '\\': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_LAMBDA; break; case '-': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); if (parser->ch == '>') { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); parser->token_tag = PGF_TOKEN_RARROW; } break; case ',': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_COMMA; break; case ':': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_COLON; break; case ';': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_SEMI; break; case '\'': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); GuStringBuf* chars = gu_new_string_buf(parser->tmp_pool); while (parser->ch != '\'' && parser->ch != EOF) { if (parser->ch == '\\') { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); } gu_out_utf8(parser->ch, gu_string_buf_out(chars), parser->err); - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); } if (parser->ch == '\'') { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); gu_out_utf8(0, gu_string_buf_out(chars), parser->err); parser->token_tag = PGF_TOKEN_IDENT; parser->token_value = chars; @@ -372,7 +378,8 @@ pgf_expr_parser_token(PgfExprParser* parser) if (pgf_is_ident_first(parser->ch)) { do { gu_out_utf8(parser->ch, gu_string_buf_out(chars), parser->err); - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); + mark = false; } while (pgf_is_ident_rest(parser->ch)); gu_out_utf8(0, gu_string_buf_out(chars), parser->err); parser->token_tag = PGF_TOKEN_IDENT; @@ -380,16 +387,17 @@ pgf_expr_parser_token(PgfExprParser* parser) } else if (isdigit(parser->ch)) { while (isdigit(parser->ch)) { gu_out_utf8(parser->ch, gu_string_buf_out(chars), parser->err); - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); + mark = false; } - + if (parser->ch == '.') { gu_out_utf8(parser->ch, gu_string_buf_out(chars), parser->err); - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); while (isdigit(parser->ch)) { gu_out_utf8(parser->ch, gu_string_buf_out(chars), parser->err); - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); } gu_out_utf8(0, gu_string_buf_out(chars), parser->err); parser->token_tag = PGF_TOKEN_FLT; @@ -400,11 +408,11 @@ pgf_expr_parser_token(PgfExprParser* parser) parser->token_value = chars; } } else if (parser->ch == '"') { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); while (parser->ch != '"' && parser->ch != EOF) { if (parser->ch == '\\') { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); switch (parser->ch) { case '\\': gu_out_utf8('\\', gu_string_buf_out(chars), parser->err); @@ -430,15 +438,17 @@ pgf_expr_parser_token(PgfExprParser* parser) } else { gu_out_utf8(parser->ch, gu_string_buf_out(chars), parser->err); } - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); } if (parser->ch == '"') { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); gu_out_utf8(0, gu_string_buf_out(chars), parser->err); parser->token_tag = PGF_TOKEN_STR; parser->token_value = chars; } + } else { + pgf_expr_parser_getc(parser, mark); } break; } @@ -449,51 +459,51 @@ static bool pgf_expr_parser_lookahead(PgfExprParser* parser, int ch) { while (isspace(parser->ch)) { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); } - + return (parser->ch == ch); } -static PgfExpr -pgf_expr_parser_expr(PgfExprParser* parser); +PGF_API PgfExpr +pgf_expr_parser_expr(PgfExprParser* parser, bool mark); static PgfType* -pgf_expr_parser_type(PgfExprParser* parser); +pgf_expr_parser_type(PgfExprParser* parser, bool mark); static PgfExpr -pgf_expr_parser_term(PgfExprParser* parser) +pgf_expr_parser_term(PgfExprParser* parser, bool mark) { switch (parser->token_tag) { case PGF_TOKEN_LPAR: { - pgf_expr_parser_token(parser); - PgfExpr expr = pgf_expr_parser_expr(parser); + pgf_expr_parser_token(parser, false); + PgfExpr expr = pgf_expr_parser_expr(parser, false); if (parser->token_tag == PGF_TOKEN_RPAR) { - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); return expr; } else { return gu_null_variant; } } case PGF_TOKEN_LTRIANGLE: { - pgf_expr_parser_token(parser); - PgfExpr expr = pgf_expr_parser_expr(parser); + pgf_expr_parser_token(parser, false); + PgfExpr expr = pgf_expr_parser_expr(parser, false); if (gu_variant_is_null(expr)) return gu_null_variant; - + if (parser->token_tag != PGF_TOKEN_COLON) { return gu_null_variant; } - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); - PgfType* type = pgf_expr_parser_type(parser); + PgfType* type = pgf_expr_parser_type(parser, false); if (type == NULL) return gu_null_variant; if (parser->token_tag != PGF_TOKEN_RTRIANGLE) { return gu_null_variant; } - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); return gu_new_variant_i(parser->expr_pool, PGF_EXPR_TYPED, @@ -501,14 +511,14 @@ pgf_expr_parser_term(PgfExprParser* parser) expr, type); } case PGF_TOKEN_QUESTION: { - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); PgfMetaId id = 0; if (parser->token_tag == PGF_TOKEN_INT) { char* str = gu_string_buf_data(parser->token_value); id = atoi(str); - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); } return gu_new_variant_i(parser->expr_pool, PGF_EXPR_META, @@ -517,7 +527,7 @@ pgf_expr_parser_term(PgfExprParser* parser) } case PGF_TOKEN_IDENT: { PgfCId id = gu_string_buf_data(parser->token_value); - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); PgfExpr e; PgfExprFun* fun = gu_new_flex_variant(PGF_EXPR_FUN, @@ -528,11 +538,11 @@ pgf_expr_parser_term(PgfExprParser* parser) return e; } case PGF_TOKEN_INT: { - char* str = + char* str = gu_string_buf_data(parser->token_value); int n = atoi(str); - pgf_expr_parser_token(parser); - PgfLiteral lit = + pgf_expr_parser_token(parser, mark); + PgfLiteral lit = gu_new_variant_i(parser->expr_pool, PGF_LITERAL_INT, PgfLiteralInt, @@ -545,7 +555,7 @@ pgf_expr_parser_term(PgfExprParser* parser) case PGF_TOKEN_STR: { char* str = gu_string_buf_data(parser->token_value); - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); return pgf_expr_string(str, parser->expr_pool); } case PGF_TOKEN_FLT: { @@ -554,8 +564,8 @@ pgf_expr_parser_term(PgfExprParser* parser) double d; if (!gu_string_to_double(str,&d)) return gu_null_variant; - pgf_expr_parser_token(parser); - PgfLiteral lit = + pgf_expr_parser_token(parser, mark); + PgfLiteral lit = gu_new_variant_i(parser->expr_pool, PGF_LITERAL_FLT, PgfLiteralFlt, @@ -571,29 +581,28 @@ pgf_expr_parser_term(PgfExprParser* parser) } static PgfExpr -pgf_expr_parser_arg(PgfExprParser* parser) +pgf_expr_parser_arg(PgfExprParser* parser, bool mark) { PgfExpr arg; if (parser->token_tag == PGF_TOKEN_LCURLY) { - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); - arg = pgf_expr_parser_expr(parser); + arg = pgf_expr_parser_expr(parser, false); if (gu_variant_is_null(arg)) return gu_null_variant; if (parser->token_tag != PGF_TOKEN_RCURLY) { return gu_null_variant; } - - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); arg = gu_new_variant_i(parser->expr_pool, PGF_EXPR_IMPL_ARG, PgfExprImplArg, arg); } else { - arg = pgf_expr_parser_term(parser); + arg = pgf_expr_parser_term(parser, mark); } return arg; @@ -607,17 +616,17 @@ pgf_expr_parser_bind(PgfExprParser* parser, GuBuf* binds) if (parser->token_tag == PGF_TOKEN_LCURLY) { bind_type = PGF_BIND_TYPE_IMPLICIT; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } for (;;) { if (parser->token_tag == PGF_TOKEN_IDENT) { var = gu_string_copy(gu_string_buf_data(parser->token_value), parser->expr_pool); - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } else if (parser->token_tag == PGF_TOKEN_WILD) { var = "_"; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } else { return false; } @@ -635,14 +644,14 @@ pgf_expr_parser_bind(PgfExprParser* parser, GuBuf* binds) parser->token_tag != PGF_TOKEN_COMMA) { break; } - - pgf_expr_parser_token(parser); + + pgf_expr_parser_token(parser, false); } if (bind_type == PGF_BIND_TYPE_IMPLICIT) { if (parser->token_tag != PGF_TOKEN_RCURLY) return false; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } return true; @@ -660,17 +669,17 @@ pgf_expr_parser_binds(PgfExprParser* parser) if (parser->token_tag != PGF_TOKEN_COMMA) break; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } return binds; } -static PgfExpr -pgf_expr_parser_expr(PgfExprParser* parser) +PGF_API PgfExpr +pgf_expr_parser_expr(PgfExprParser* parser, bool mark) { if (parser->token_tag == PGF_TOKEN_LAMBDA) { - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); GuBuf* binds = pgf_expr_parser_binds(parser); if (binds == NULL) return gu_null_variant; @@ -678,9 +687,9 @@ pgf_expr_parser_expr(PgfExprParser* parser) if (parser->token_tag != PGF_TOKEN_RARROW) { return gu_null_variant; } - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); - PgfExpr expr = pgf_expr_parser_expr(parser); + PgfExpr expr = pgf_expr_parser_expr(parser, mark); if (gu_variant_is_null(expr)) return gu_null_variant; @@ -691,10 +700,9 @@ pgf_expr_parser_expr(PgfExprParser* parser) ((PgfExprAbs*) gu_variant_data(bind))->body = expr; expr = bind; } - return expr; } else { - PgfExpr expr = pgf_expr_parser_term(parser); + PgfExpr expr = pgf_expr_parser_term(parser, mark); if (gu_variant_is_null(expr)) return gu_null_variant; @@ -704,17 +712,18 @@ pgf_expr_parser_expr(PgfExprParser* parser) parser->token_tag != PGF_TOKEN_RTRIANGLE && parser->token_tag != PGF_TOKEN_COLON && parser->token_tag != PGF_TOKEN_COMMA && - parser->token_tag != PGF_TOKEN_SEMI) { - PgfExpr arg = pgf_expr_parser_arg(parser); + parser->token_tag != PGF_TOKEN_SEMI && + parser->token_tag != PGF_TOKEN_UNKNOWN) { + PgfExpr arg = pgf_expr_parser_arg(parser, mark); if (gu_variant_is_null(arg)) - return gu_null_variant; + return expr; expr = gu_new_variant_i(parser->expr_pool, PGF_EXPR_APP, PgfExprApp, expr, arg); } - + return expr; } } @@ -729,16 +738,16 @@ pgf_expr_parser_hypos(PgfExprParser* parser, GuBuf* hypos) if (bind_type == PGF_BIND_TYPE_EXPLICIT && parser->token_tag == PGF_TOKEN_LCURLY) { bind_type = PGF_BIND_TYPE_IMPLICIT; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } if (parser->token_tag == PGF_TOKEN_IDENT) { var = gu_string_copy(gu_string_buf_data(parser->token_value), parser->expr_pool); - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } else if (parser->token_tag == PGF_TOKEN_WILD) { var = "_"; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } else { return false; } @@ -751,14 +760,14 @@ pgf_expr_parser_hypos(PgfExprParser* parser, GuBuf* hypos) if (bind_type == PGF_BIND_TYPE_IMPLICIT && parser->token_tag == PGF_TOKEN_RCURLY) { bind_type = PGF_BIND_TYPE_EXPLICIT; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } if (parser->token_tag != PGF_TOKEN_COMMA) { break; } - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } if (bind_type == PGF_BIND_TYPE_IMPLICIT) @@ -768,14 +777,14 @@ pgf_expr_parser_hypos(PgfExprParser* parser, GuBuf* hypos) } static PgfType* -pgf_expr_parser_atom(PgfExprParser* parser) +pgf_expr_parser_atom(PgfExprParser* parser, bool mark) { if (parser->token_tag != PGF_TOKEN_IDENT) return NULL; PgfCId cid = gu_string_copy(gu_string_buf_data(parser->token_value), parser->expr_pool); - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); GuBuf* args = gu_new_buf(PgfExpr, parser->tmp_pool); while (parser->token_tag != PGF_TOKEN_EOF && @@ -783,10 +792,10 @@ pgf_expr_parser_atom(PgfExprParser* parser) parser->token_tag != PGF_TOKEN_RTRIANGLE && parser->token_tag != PGF_TOKEN_RARROW) { PgfExpr arg = - pgf_expr_parser_arg(parser); + pgf_expr_parser_arg(parser, mark); if (gu_variant_is_null(arg)) - return NULL; - + break; + gu_buf_push(args, PgfExpr, arg); } @@ -805,14 +814,14 @@ pgf_expr_parser_atom(PgfExprParser* parser) } static PgfType* -pgf_expr_parser_type(PgfExprParser* parser) +pgf_expr_parser_type(PgfExprParser* parser, bool mark) { PgfType* type = NULL; GuBuf* hypos = gu_new_buf(PgfHypo, parser->expr_pool); for (;;) { if (parser->token_tag == PGF_TOKEN_LPAR) { - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); size_t n_start = gu_buf_length(hypos); @@ -828,7 +837,7 @@ pgf_expr_parser_type(PgfExprParser* parser) if (parser->token_tag != PGF_TOKEN_COLON) return NULL; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } else { PgfHypo* hypo = gu_buf_extend(hypos); hypo->bind_type = PGF_BIND_TYPE_EXPLICIT; @@ -838,33 +847,33 @@ pgf_expr_parser_type(PgfExprParser* parser) size_t n_end = gu_buf_length(hypos); - PgfType* type = pgf_expr_parser_type(parser); + PgfType* type = pgf_expr_parser_type(parser, false); if (type == NULL) return NULL; if (parser->token_tag != PGF_TOKEN_RPAR) return NULL; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); if (parser->token_tag != PGF_TOKEN_RARROW) return NULL; - pgf_expr_parser_token(parser); - + pgf_expr_parser_token(parser, false); + for (size_t i = n_start; i < n_end; i++) { PgfHypo* hypo = gu_buf_index(hypos, PgfHypo, i); hypo->type = type; } } else { - type = pgf_expr_parser_atom(parser); + type = pgf_expr_parser_atom(parser, mark); if (type == NULL) return NULL; if (parser->token_tag != PGF_TOKEN_RARROW) break; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); PgfHypo* hypo = gu_buf_extend(hypos); hypo->bind_type = PGF_BIND_TYPE_EXPLICIT; @@ -878,29 +887,34 @@ pgf_expr_parser_type(PgfExprParser* parser) return type; } -static PgfExprParser* -pgf_new_parser(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err) +PGF_API PgfExprParser* +pgf_new_parser(void* getc_state, PgfParserGetc getc, GuPool* pool, GuPool* tmp_pool, GuExn* err) { PgfExprParser* parser = gu_new(PgfExprParser, tmp_pool); parser->err = err; - parser->in = in; parser->expr_pool = pool; parser->tmp_pool = tmp_pool; + parser->getch_state = getc_state; + parser->getch = getc; parser->ch = ' '; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); return parser; } +static GuUCS +pgf_expr_parser_in_getc(void* state, bool mark, GuExn* err) +{ + return gu_in_utf8((GuIn*) state, err); +} + PGF_API PgfExpr -pgf_read_expr(GuIn* in, GuPool* pool, GuExn* err) +pgf_read_expr(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err) { - GuPool* tmp_pool = gu_new_pool(); PgfExprParser* parser = - pgf_new_parser(in, pool, tmp_pool, err); - PgfExpr expr = pgf_expr_parser_expr(parser); + pgf_new_parser(in, pgf_expr_parser_in_getc, pool, tmp_pool, err); + PgfExpr expr = pgf_expr_parser_expr(parser, true); if (parser->token_tag != PGF_TOKEN_EOF) return gu_null_variant; - gu_pool_free(tmp_pool); return expr; } @@ -911,24 +925,24 @@ pgf_read_expr_tuple(GuIn* in, { GuPool* tmp_pool = gu_new_pool(); PgfExprParser* parser = - pgf_new_parser(in, pool, tmp_pool, err); + pgf_new_parser(in, pgf_expr_parser_in_getc, pool, tmp_pool, err); if (parser->token_tag != PGF_TOKEN_LTRIANGLE) goto fail; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); for (size_t i = 0; i < n_exprs; i++) { if (i > 0) { if (parser->token_tag != PGF_TOKEN_COMMA) goto fail; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } - exprs[i] = pgf_expr_parser_expr(parser); + exprs[i] = pgf_expr_parser_expr(parser, false); if (gu_variant_is_null(exprs[i])) goto fail; } if (parser->token_tag != PGF_TOKEN_RTRIANGLE) goto fail; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); if (parser->token_tag != PGF_TOKEN_EOF) goto fail; gu_pool_free(tmp_pool); @@ -947,10 +961,10 @@ pgf_read_expr_matrix(GuIn* in, { GuPool* tmp_pool = gu_new_pool(); PgfExprParser* parser = - pgf_new_parser(in, pool, tmp_pool, err); + pgf_new_parser(in, pgf_expr_parser_in_getc, pool, tmp_pool, err); if (parser->token_tag != PGF_TOKEN_LTRIANGLE) goto fail; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); GuBuf* buf = gu_new_buf(PgfExpr, pool); @@ -962,10 +976,10 @@ pgf_read_expr_matrix(GuIn* in, if (i > 0) { if (parser->token_tag != PGF_TOKEN_COMMA) goto fail; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } - exprs[i] = pgf_expr_parser_expr(parser); + exprs[i] = pgf_expr_parser_expr(parser, false); if (gu_variant_is_null(exprs[i])) goto fail; } @@ -973,14 +987,14 @@ pgf_read_expr_matrix(GuIn* in, if (parser->token_tag != PGF_TOKEN_SEMI) break; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } if (parser->token_tag != PGF_TOKEN_RTRIANGLE) goto fail; } - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); if (parser->token_tag != PGF_TOKEN_EOF) goto fail; gu_pool_free(tmp_pool); @@ -993,15 +1007,13 @@ fail: } PGF_API PgfType* -pgf_read_type(GuIn* in, GuPool* pool, GuExn* err) +pgf_read_type(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err) { - GuPool* tmp_pool = gu_new_pool(); PgfExprParser* parser = - pgf_new_parser(in, pool, tmp_pool, err); - PgfType* type = pgf_expr_parser_type(parser); + pgf_new_parser(in, pgf_expr_parser_in_getc, pool, tmp_pool, err); + PgfType* type = pgf_expr_parser_type(parser, true); if (parser->token_tag != PGF_TOKEN_EOF) return NULL; - gu_pool_free(tmp_pool); return type; } @@ -1177,6 +1189,247 @@ pgf_expr_hash(GuHash h, PgfExpr e) return h; } +PGF_API size_t +pgf_expr_size(PgfExpr expr) +{ + GuVariantInfo ei = gu_variant_open(expr); + switch (ei.tag) { + case PGF_EXPR_ABS: { + PgfExprAbs* abs = ei.data; + return pgf_expr_size(abs->body); + } + case PGF_EXPR_APP: { + PgfExprApp* app = ei.data; + return pgf_expr_size(app->fun) + pgf_expr_size(app->arg); + } + case PGF_EXPR_LIT: + case PGF_EXPR_META: + case PGF_EXPR_FUN: + case PGF_EXPR_VAR: { + return 1; + } + case PGF_EXPR_TYPED: { + PgfExprTyped* typed = ei.data; + return pgf_expr_size(typed->expr); + } + case PGF_EXPR_IMPL_ARG: { + PgfExprImplArg* impl = ei.data; + return pgf_expr_size(impl->expr); + } + default: + gu_impossible(); + return 0; + } +} + +static void +pgf_expr_functions_helper(PgfExpr expr, GuBuf* functions) +{ + GuVariantInfo ei = gu_variant_open(expr); + switch (ei.tag) { + case PGF_EXPR_ABS: { + PgfExprAbs* abs = ei.data; + pgf_expr_functions_helper(abs->body, functions); + break; + } + case PGF_EXPR_APP: { + PgfExprApp* app = ei.data; + pgf_expr_functions_helper(app->fun, functions); + pgf_expr_functions_helper(app->arg, functions); + break; + } + case PGF_EXPR_LIT: + case PGF_EXPR_META: + case PGF_EXPR_VAR: { + break; + } + case PGF_EXPR_FUN:{ + PgfExprFun* fun = ei.data; + gu_buf_push(functions, GuString, fun->fun); + break; + } + case PGF_EXPR_TYPED: { + PgfExprTyped* typed = ei.data; + pgf_expr_functions_helper(typed->expr, functions); + break; + } + case PGF_EXPR_IMPL_ARG: { + PgfExprImplArg* impl = ei.data; + pgf_expr_functions_helper(impl->expr, functions); + break; + } + default: + gu_impossible(); + } +} + +PGF_API GuSeq* +pgf_expr_functions(PgfExpr expr, GuPool* pool) +{ + GuBuf* functions = gu_new_buf(GuString, pool); + pgf_expr_functions_helper(expr, functions); + return gu_buf_data_seq(functions); +} + +PGF_API PgfType* +pgf_type_substitute(PgfType* type, GuSeq* meta_values, GuPool* pool) +{ + size_t n_hypos = gu_seq_length(type->hypos); + PgfHypos* new_hypos = gu_new_seq(PgfHypo, n_hypos, pool); + for (size_t i = 0; i < n_hypos; i++) { + PgfHypo* hypo = gu_seq_index(type->hypos, PgfHypo, i); + PgfHypo* new_hypo = gu_seq_index(new_hypos, PgfHypo, i); + + new_hypo->bind_type = hypo->bind_type; + new_hypo->cid = gu_string_copy(hypo->cid, pool); + new_hypo->type = pgf_type_substitute(hypo->type, meta_values, pool); + } + + PgfType *new_type = + gu_new_flex(pool, PgfType, exprs, type->n_exprs); + new_type->hypos = new_hypos; + new_type->cid = gu_string_copy(type->cid, pool); + new_type->n_exprs = type->n_exprs; + + for (size_t i = 0; i < type->n_exprs; i++) { + new_type->exprs[i] = + pgf_expr_substitute(type->exprs[i], meta_values, pool); + } + + return new_type; +} + +PGF_API PgfExpr +pgf_expr_substitute(PgfExpr expr, GuSeq* meta_values, GuPool* pool) +{ + GuVariantInfo ei = gu_variant_open(expr); + switch (ei.tag) { + case PGF_EXPR_ABS: { + PgfExprAbs* abs = ei.data; + + PgfCId id = gu_string_copy(abs->id, pool); + PgfExpr body = pgf_expr_substitute(abs->body, meta_values, pool); + return gu_new_variant_i(pool, + PGF_EXPR_ABS, + PgfExprAbs, + abs->bind_type, id, body); + } + case PGF_EXPR_APP: { + PgfExprApp* app = ei.data; + + PgfExpr fun = pgf_expr_substitute(app->fun, meta_values, pool); + PgfExpr arg = pgf_expr_substitute(app->arg, meta_values, pool); + return gu_new_variant_i(pool, + PGF_EXPR_APP, + PgfExprApp, + fun, arg); + } + case PGF_EXPR_LIT: { + PgfExprLit* elit = ei.data; + + PgfLiteral lit; + GuVariantInfo i = gu_variant_open(elit->lit); + switch (i.tag) { + case PGF_LITERAL_STR: { + PgfLiteralStr* lstr = i.data; + + PgfLiteralStr* new_lstr = + gu_new_flex_variant(PGF_LITERAL_STR, + PgfLiteralStr, + val, strlen(lstr->val)+1, + &lit, pool); + strcpy(new_lstr->val, lstr->val); + break; + } + case PGF_LITERAL_INT: { + PgfLiteralInt* lint = i.data; + + PgfLiteralInt* new_lint = + gu_new_variant(PGF_LITERAL_INT, + PgfLiteralInt, + &lit, pool); + new_lint->val = lint->val; + break; + } + case PGF_LITERAL_FLT: { + PgfLiteralFlt* lflt = i.data; + + PgfLiteralFlt* new_lflt = + gu_new_variant(PGF_LITERAL_FLT, + PgfLiteralFlt, + &lit, pool); + new_lflt->val = lflt->val; + break; + } + default: + gu_impossible(); + } + + return gu_new_variant_i(pool, + PGF_EXPR_LIT, + PgfExprLit, + lit); + } + case PGF_EXPR_META: { + PgfExprMeta* meta = ei.data; + PgfExpr e = gu_null_variant; + if ((size_t) meta->id < gu_seq_length(meta_values)) { + e = gu_seq_get(meta_values, PgfExpr, meta->id); + } + if (gu_variant_is_null(e)) { + e = gu_new_variant_i(pool, + PGF_EXPR_META, + PgfExprMeta, + meta->id); + } + return e; + } + case PGF_EXPR_FUN: { + PgfExprFun* fun = ei.data; + + PgfExpr e; + PgfExprFun* new_fun = + gu_new_flex_variant(PGF_EXPR_FUN, + PgfExprFun, + fun, strlen(fun->fun)+1, + &e, pool); + strcpy(new_fun->fun, fun->fun); + return e; + } + case PGF_EXPR_VAR: { + PgfExprVar* var = ei.data; + return gu_new_variant_i(pool, + PGF_EXPR_VAR, + PgfExprVar, + var->var); + } + case PGF_EXPR_TYPED: { + PgfExprTyped* typed = ei.data; + + PgfExpr expr = pgf_expr_substitute(typed->expr, meta_values, pool); + PgfType *type = pgf_type_substitute(typed->type, meta_values, pool); + + return gu_new_variant_i(pool, + PGF_EXPR_TYPED, + PgfExprTyped, + expr, + type); + } + case PGF_EXPR_IMPL_ARG: { + PgfExprImplArg* impl = ei.data; + + PgfExpr expr = pgf_expr_substitute(impl->expr, meta_values, pool); + return gu_new_variant_i(pool, + PGF_EXPR_IMPL_ARG, + PgfExprImplArg, + expr); + } + default: + gu_impossible(); + return gu_null_variant; + } +} + PGF_API void pgf_print_cid(PgfCId id, GuOut* out, GuExn* err) @@ -1397,10 +1650,10 @@ pgf_print_hypo(PgfHypo *hypo, PgfPrintContext* ctxt, int prec, } else { pgf_print_type(hypo->type, ctxt, prec, out, err); } - + gu_pool_free(tmp_pool); } - + PgfPrintContext* new_ctxt = malloc(sizeof(PgfPrintContext)); new_ctxt->name = hypo->cid; new_ctxt->next = ctxt; @@ -1415,7 +1668,7 @@ pgf_print_type(PgfType *type, PgfPrintContext* ctxt, int prec, if (n_hypos > 0) { if (prec > 0) gu_putc('(', out, err); - + PgfPrintContext* new_ctxt = ctxt; for (size_t i = 0; i < n_hypos; i++) { PgfHypo *hypo = gu_seq_index(type->hypos, PgfHypo, i); @@ -1455,6 +1708,22 @@ pgf_print_type(PgfType *type, PgfPrintContext* ctxt, int prec, } PGF_API void +pgf_print_context(PgfHypos *hypos, PgfPrintContext* ctxt, + GuOut *out, GuExn *err) +{ + PgfPrintContext* new_ctxt = ctxt; + + size_t n_hypos = gu_seq_length(hypos); + for (size_t i = 0; i < n_hypos; i++) { + if (i > 0) + gu_putc(' ', out, err); + + PgfHypo *hypo = gu_seq_index(hypos, PgfHypo, i); + new_ctxt = pgf_print_hypo(hypo, new_ctxt, 4, out, err); + } +} + +PGF_API void pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt, GuOut* out, GuExn* err) { @@ -1467,30 +1736,6 @@ pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt, gu_putc('>', out, err); } -PGF_API_DECL void -pgf_print_category(PgfPGF *gr, PgfCId catname, - GuOut* out, GuExn *err) -{ - PgfAbsCat* abscat = - gu_seq_binsearch(gr->abstract.cats, pgf_abscat_order, PgfAbsCat, catname); - if (abscat == NULL) { - GuExnData* exn = gu_raise(err, PgfExn); - exn->data = "Unknown category"; - return; - } - - gu_puts(abscat->name, out, err); - - PgfPrintContext* ctxt = NULL; - size_t n_hypos = gu_seq_length(abscat->context); - for (size_t i = 0; i < n_hypos; i++) { - PgfHypo *hypo = gu_seq_index(abscat->context, PgfHypo, i); - - gu_putc(' ', out, err); - ctxt = pgf_print_hypo(hypo, ctxt, 4, out, err); - } -} - PGF_API bool pgf_type_eq(PgfType* t1, PgfType* t2) { diff --git a/src/runtime/c/pgf/expr.h b/src/runtime/c/pgf/expr.h index 6492f8d18..e560d3a83 100644 --- a/src/runtime/c/pgf/expr.h +++ b/src/runtime/c/pgf/expr.h @@ -168,7 +168,7 @@ PGF_API_DECL PgfExprMeta* pgf_expr_unmeta(PgfExpr expr); PGF_API_DECL PgfExpr -pgf_read_expr(GuIn* in, GuPool* pool, GuExn* err); +pgf_read_expr(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err); PGF_API_DECL int pgf_read_expr_tuple(GuIn* in, @@ -180,7 +180,7 @@ pgf_read_expr_matrix(GuIn* in, size_t n_exprs, GuPool* pool, GuExn* err); PGF_API_DECL PgfType* -pgf_read_type(GuIn* in, GuPool* pool, GuExn* err); +pgf_read_type(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err); PGF_API_DECL bool pgf_literal_eq(PgfLiteral lit1, PgfLiteral lit2); @@ -197,6 +197,18 @@ pgf_literal_hash(GuHash h, PgfLiteral lit); PGF_API_DECL GuHash pgf_expr_hash(GuHash h, PgfExpr e); +PGF_API size_t +pgf_expr_size(PgfExpr expr); + +PGF_API GuSeq* +pgf_expr_functions(PgfExpr expr, GuPool* pool); + +PGF_API PgfExpr +pgf_expr_substitute(PgfExpr expr, GuSeq* meta_values, GuPool* pool); + +PGF_API PgfType* +pgf_type_substitute(PgfType* type, GuSeq* meta_values, GuPool* pool); + typedef struct PgfPrintContext PgfPrintContext; struct PgfPrintContext { @@ -223,14 +235,14 @@ pgf_print_type(PgfType *type, PgfPrintContext* ctxt, int prec, GuOut* out, GuExn *err); PGF_API_DECL void -pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt, - GuOut* out, GuExn* err); +pgf_print_context(PgfHypos *hypos, PgfPrintContext* ctxt, + GuOut *out, GuExn *err); PGF_API_DECL void -pgf_print_category(PgfPGF *gr, PgfCId catname, - GuOut* out, GuExn *err); +pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt, + GuOut* out, GuExn* err); -PGF_API prob_t +PGF_API_DECL prob_t pgf_compute_tree_probability(PgfPGF *gr, PgfExpr expr); #endif /* EXPR_H_ */ diff --git a/src/runtime/c/pgf/graphviz.c b/src/runtime/c/pgf/graphviz.c index f10303bdc..66e203dbc 100644 --- a/src/runtime/c/pgf/graphviz.c +++ b/src/runtime/c/pgf/graphviz.c @@ -155,7 +155,7 @@ pgf_bracket_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok) } static void -pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); @@ -192,7 +192,7 @@ pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int linde } static void -pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); diff --git a/src/runtime/c/pgf/linearizer.c b/src/runtime/c/pgf/linearizer.c index f18a3e55a..ced2a8cf2 100644 --- a/src/runtime/c/pgf/linearizer.c +++ b/src/runtime/c/pgf/linearizer.c @@ -30,7 +30,7 @@ pgf_lzr_add_overl_entry(PgfCncOverloadMap* overl_table, gu_buf_push(entries, void*, entry); } -PGF_INTERNAL void +PGF_API void pgf_lzr_index(PgfConcr* concr, PgfCCat* ccat, PgfProduction prod, bool is_lexical, @@ -731,7 +731,7 @@ found: } static void -pgf_lzr_cache_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lin_idx, PgfCId fun) +pgf_lzr_cache_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lin_idx, PgfCId fun) { PgfLzrCache* cache = gu_container(funcs, PgfLzrCache, funcs); PgfLzrCached* event = gu_buf_extend(cache->events); @@ -743,7 +743,7 @@ pgf_lzr_cache_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lin_idx } static void -pgf_lzr_cache_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lin_idx, PgfCId fun) +pgf_lzr_cache_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lin_idx, PgfCId fun) { PgfLzrCache* cache = gu_container(funcs, PgfLzrCache, funcs); PgfLzrCached* event = gu_buf_extend(cache->events); diff --git a/src/runtime/c/pgf/linearizer.h b/src/runtime/c/pgf/linearizer.h index f2fea4221..57fad962f 100644 --- a/src/runtime/c/pgf/linearizer.h +++ b/src/runtime/c/pgf/linearizer.h @@ -83,10 +83,10 @@ struct PgfLinFuncs void (*symbol_token)(PgfLinFuncs** self, PgfToken tok); /// Begin phrase - void (*begin_phrase)(PgfLinFuncs** self, PgfCId cat, int fid, int lindex, PgfCId fun); + void (*begin_phrase)(PgfLinFuncs** self, PgfCId cat, int fid, size_t lindex, PgfCId fun); /// End phrase - void (*end_phrase)(PgfLinFuncs** self, PgfCId cat, int fid, int lindex, PgfCId fun); + void (*end_phrase)(PgfLinFuncs** self, PgfCId cat, int fid, size_t lindex, PgfCId fun); /// handling nonExist void (*symbol_ne)(PgfLinFuncs** self); diff --git a/src/runtime/c/pgf/lookup.c b/src/runtime/c/pgf/lookup.c index 16874eb0e..5918275c1 100644 --- a/src/runtime/c/pgf/lookup.c +++ b/src/runtime/c/pgf/lookup.c @@ -9,6 +9,9 @@ #include <stdio.h> #include <stdlib.h> #include <math.h> +#if defined(__MINGW32__) || defined(_MSC_VER) +#include <malloc.h> +#endif //#define PGF_LOOKUP_DEBUG //#define PGF_LINEARIZER_DEBUG @@ -116,7 +119,7 @@ typedef struct { static PgfAbsProduction* pgf_lookup_new_production(PgfAbsFun* fun, GuPool *pool) { - size_t n_hypos = gu_seq_length(fun->type->hypos); + size_t n_hypos = fun->type->hypos ? gu_seq_length(fun->type->hypos) : 0; PgfAbsProduction* prod = gu_new_flex(pool, PgfAbsProduction, args, n_hypos); prod->fun = fun; prod->count = 0; @@ -696,8 +699,12 @@ pgf_lookup_tokenize(GuMap* lexicon_idx, GuString sentence, GuPool* pool) break; const uint8_t* start = p-1; - while (c != 0 && !gu_ucs_is_space(c)) { + if (strchr(".!?,:",c) != NULL) c = gu_utf8_decode(&p); + else { + while (c != 0 && strchr(".!?,:",c) == NULL && !gu_ucs_is_space(c)) { + c = gu_utf8_decode(&p); + } } const uint8_t* end = p-1; @@ -869,7 +876,7 @@ pgf_lookup_symbol_token(PgfLinFuncs** self, PgfToken token) } static void -pgf_lookup_begin_phrase(PgfLinFuncs** self, PgfCId cat, int fid, int lindex, PgfCId funname) +pgf_lookup_begin_phrase(PgfLinFuncs** self, PgfCId cat, int fid, size_t lindex, PgfCId funname) { PgfLookupState* st = gu_container(self, PgfLookupState, funcs); @@ -883,7 +890,7 @@ pgf_lookup_begin_phrase(PgfLinFuncs** self, PgfCId cat, int fid, int lindex, Pgf } static void -pgf_lookup_end_phrase(PgfLinFuncs** self, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_lookup_end_phrase(PgfLinFuncs** self, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfLookupState* st = gu_container(self, PgfLookupState, funcs); st->curr_absfun = NULL; diff --git a/src/runtime/c/pgf/parser.c b/src/runtime/c/pgf/parser.c index ecfb7d2ea..d12852a71 100644 --- a/src/runtime/c/pgf/parser.c +++ b/src/runtime/c/pgf/parser.c @@ -65,6 +65,7 @@ typedef enum { BIND_NONE, BIND_HARD, BIND_SOFT } BIND_TYPE; typedef struct { PgfProductionIdx* idx; size_t offset; + size_t sym_idx; } PgfLexiconIdxEntry; typedef GuBuf PgfLexiconIdx; @@ -1060,16 +1061,16 @@ pgf_parsing_complete(PgfParsing* ps, PgfItem* item, PgfExprProb *ep) } static int -pgf_symbols_cmp(GuString* psent, PgfSymbols* syms, bool case_sensitive) +pgf_symbols_cmp(GuString* psent, PgfSymbols* syms, size_t* sym_idx, bool case_sensitive) { size_t n_syms = gu_seq_length(syms); - for (size_t i = 0; i < n_syms; i++) { - PgfSymbol sym = gu_seq_get(syms, PgfSymbol, i); + while (*sym_idx < n_syms) { + PgfSymbol sym = gu_seq_get(syms, PgfSymbol, *sym_idx); - if (i > 0) { + if (*sym_idx > 0) { if (!skip_space(psent)) { if (**psent == 0) - return -1; + return 0; return 1; } @@ -1085,13 +1086,13 @@ pgf_symbols_cmp(GuString* psent, PgfSymbols* syms, bool case_sensitive) case PGF_SYMBOL_LIT: case PGF_SYMBOL_VAR: { if (**psent == 0) - return -1; + return 0; return 1; } case PGF_SYMBOL_KS: { PgfSymbolKS* pks = inf.data; if (**psent == 0) - return -1; + return 0; int cmp = cmp_string(psent, pks->token, case_sensitive); if (cmp != 0) @@ -1110,6 +1111,8 @@ pgf_symbols_cmp(GuString* psent, PgfSymbols* syms, bool case_sensitive) default: gu_impossible(); } + + (*sym_idx)++; } return 0; @@ -1130,7 +1133,8 @@ pgf_parsing_lookahead(PgfParsing *ps, PgfParseState* state, GuString start = ps->sentence + state->end_offset; GuString current = start; - int cmp = pgf_symbols_cmp(¤t, seq->syms, ps->case_sensitive); + size_t sym_idx = 0; + int cmp = pgf_symbols_cmp(¤t, seq->syms, &sym_idx, ps->case_sensitive); if (cmp < 0) { j = k-1; } else if (cmp > 0) { @@ -1151,8 +1155,9 @@ pgf_parsing_lookahead(PgfParsing *ps, PgfParseState* state, if (seq->idx != NULL) { PgfLexiconIdxEntry* entry = gu_buf_extend(state->lexicon_idx); - entry->idx = seq->idx; - entry->offset = (size_t) (current - ps->sentence); + entry->idx = seq->idx; + entry->offset = (size_t) (current - ps->sentence); + entry->sym_idx = sym_idx; } if (len+1 <= max) @@ -1231,6 +1236,7 @@ pgf_new_parse_state(PgfParsing* ps, size_t start_offset, PgfLexiconIdxEntry* entry = gu_buf_extend(state->lexicon_idx); entry->idx = seq->idx; entry->offset = state->start_offset; + entry->sym_idx= 0; } // Add non-epsilon lexical rules to the bottom up index @@ -1254,9 +1260,12 @@ pgf_parsing_add_transition(PgfParsing* ps, PgfToken tok, PgfItem* item) if (ps->prefix != NULL && *current == 0) { if (gu_string_is_prefix(ps->prefix, tok)) { + PgfProductionApply* papp = gu_variant_data(item->prod); + ps->tp = gu_new(PgfTokenProb, ps->out_pool); ps->tp->tok = tok; ps->tp->cat = item->conts->ccat->cnccat->abscat->name; + ps->tp->fun = papp->fun->absfun->name; ps->tp->prob = item->inside_prob + item->conts->outside_prob; } } else { @@ -1275,14 +1284,15 @@ pgf_parsing_add_transition(PgfParsing* ps, PgfToken tok, PgfItem* item) static void pgf_parsing_predict_lexeme(PgfParsing* ps, PgfItemConts* conts, PgfProductionIdxEntry* entry, - size_t offset) + size_t offset, size_t sym_idx) { GuVariantInfo i = { PGF_PRODUCTION_APPLY, entry->papp }; PgfProduction prod = gu_variant_close(i); PgfItem* item = pgf_new_item(ps, conts, prod); PgfSymbols* syms = entry->papp->fun->lins[conts->lin_idx]->syms; - item->sym_idx = gu_seq_length(syms); + item->sym_idx = sym_idx; + pgf_item_set_curr_symbol(item, ps->pool); prob_t prob = item->inside_prob+item->conts->outside_prob; PgfParseState* state = pgf_new_parse_state(ps, offset, BIND_NONE, prob); @@ -1355,7 +1365,7 @@ pgf_parsing_td_predict(PgfParsing* ps, PgfProductionIdxEntry, &key); if (value != NULL) { - pgf_parsing_predict_lexeme(ps, conts, value, lentry->offset); + pgf_parsing_predict_lexeme(ps, conts, value, lentry->offset, lentry->sym_idx); PgfProductionIdxEntry* start = gu_buf_data(lentry->idx); @@ -1366,7 +1376,7 @@ pgf_parsing_td_predict(PgfParsing* ps, while (left >= start && value->ccat->fid == left->ccat->fid && value->lin_idx == left->lin_idx) { - pgf_parsing_predict_lexeme(ps, conts, left, lentry->offset); + pgf_parsing_predict_lexeme(ps, conts, left, lentry->offset, lentry->sym_idx); left--; } @@ -1374,7 +1384,7 @@ pgf_parsing_td_predict(PgfParsing* ps, while (right <= end && value->ccat->fid == right->ccat->fid && value->lin_idx == right->lin_idx) { - pgf_parsing_predict_lexeme(ps, conts, right, lentry->offset); + pgf_parsing_predict_lexeme(ps, conts, right, lentry->offset, lentry->sym_idx); right++; } } @@ -2139,30 +2149,37 @@ pgf_parse_result_enum_next(GuEnum* self, void* to, GuPool* pool) *(PgfExprProb**)to = pgf_parse_result_next(ps); } -static GuString -pgf_parsing_last_token(PgfParsing* ps, GuPool* pool) +static PgfParseError* +pgf_parsing_new_exception(PgfParsing* ps, GuPool* pool) { - if (ps->before == NULL) - return ""; + const uint8_t* p = (uint8_t*) ps->sentence; + const uint8_t* end = p + (ps->before ? ps->before->end_offset : 0); - const uint8_t* start = (uint8_t*) ps->sentence; - const uint8_t* end = (uint8_t*) ps->sentence + ps->before->end_offset; + PgfParseError* err = gu_new(PgfParseError, pool); + err->incomplete= (*end == 0); + err->offset = 0; + err->token_ptr = (char*) p; - const uint8_t* p = start; while (p < end) { if (gu_ucs_is_space(gu_utf8_decode(&p))) { - start = p; + err->token_ptr = (char*) p; } + err->offset++; + } + + if (err->incomplete) { + err->token_ptr = NULL; + err->token_len = 0; + return err; } while (*p && !gu_ucs_is_space(gu_utf8_decode(&p))) { end = p; } - char* tok = gu_malloc(pool, end-start+1); - memcpy(tok, start, (end-start)); - tok[end-start] = 0; - return tok; + err->token_len = ((char*)end)-err->token_ptr; + + return err; } PGF_API GuEnum* @@ -2204,7 +2221,7 @@ pgf_parse_with_heuristics(PgfConcr* concr, PgfType* typ, GuString sentence, while (gu_buf_length(ps->expr_queue) == 0) { if (!pgf_parsing_proceed(ps)) { GuExnData* exn = gu_raise(err, PgfParseError); - exn->data = (void*) pgf_parsing_last_token(ps, exn->pool); + exn->data = (void*) pgf_parsing_new_exception(ps, exn->pool); return NULL; } @@ -2249,7 +2266,7 @@ pgf_parse_with_oracle(PgfConcr* concr, PgfType* typ, while (gu_buf_length(ps->expr_queue) == 0) { if (!pgf_parsing_proceed(ps)) { GuExnData* exn = gu_raise(err, PgfParseError); - exn->data = (void*) pgf_parsing_last_token(ps, exn->pool); + exn->data = (void*) pgf_parsing_new_exception(ps, exn->pool); return NULL; } @@ -2312,7 +2329,7 @@ pgf_complete(PgfConcr* concr, PgfType* type, GuString sentence, while (ps->before->end_offset < len) { if (!pgf_parsing_proceed(ps)) { GuExnData* exn = gu_raise(err, PgfParseError); - exn->data = (void*) pgf_parsing_last_token(ps, exn->pool); + exn->data = (void*) pgf_parsing_new_exception(ps, exn->pool); return NULL; } @@ -2362,8 +2379,9 @@ pgf_sequence_cmp_fn(GuOrder* order, const void* p1, const void* p2) GuString sent = (GuString) p1; const PgfSequence* sp2 = p2; - int res = pgf_symbols_cmp(&sent, sp2->syms, self->case_sensitive); - if (res == 0 && *sent != 0) { + size_t sym_idx = 0; + int res = pgf_symbols_cmp(&sent, sp2->syms, &sym_idx, self->case_sensitive); + if (res == 0 && (*sent != 0 || sym_idx != gu_seq_length(sp2->syms))) { res = 1; } @@ -2494,7 +2512,7 @@ pgf_lookup_word_prefix(PgfConcr *concr, GuString prefix, return &state->en; } -PGF_INTERNAL void +PGF_API void pgf_parser_index(PgfConcr* concr, PgfCCat* ccat, PgfProduction prod, bool is_lexical, diff --git a/src/runtime/c/pgf/parseval.c b/src/runtime/c/pgf/parseval.c index 85df380fa..2882f7643 100644 --- a/src/runtime/c/pgf/parseval.c +++ b/src/runtime/c/pgf/parseval.c @@ -6,7 +6,7 @@ typedef struct { int start, end; PgfCId cat; - int lin_idx; + size_t lin_idx; } PgfPhrase; typedef struct { @@ -46,14 +46,14 @@ pgf_metrics_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok) } static void -pgf_metrics_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lin_index, PgfCId fun) +pgf_metrics_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lin_index, PgfCId fun) { PgfMetricsLznState* state = gu_container(funcs, PgfMetricsLznState, funcs); gu_buf_push(state->marks, int, state->pos); } static void -pgf_metrics_lzn_end_phrase1(PgfLinFuncs** funcs, PgfCId cat, int fid, int lin_idx, PgfCId fun) +pgf_metrics_lzn_end_phrase1(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lin_idx, PgfCId fun) { PgfMetricsLznState* state = gu_container(funcs, PgfMetricsLznState, funcs); @@ -85,7 +85,7 @@ pgf_metrics_symbol_bind(PgfLinFuncs** funcs) } static void -pgf_metrics_lzn_end_phrase2(PgfLinFuncs** funcs, PgfCId cat, int fid, int lin_idx, PgfCId fun) +pgf_metrics_lzn_end_phrase2(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lin_idx, PgfCId fun) { PgfMetricsLznState* state = gu_container(funcs, PgfMetricsLznState, funcs); diff --git a/src/runtime/c/pgf/pgf.c b/src/runtime/c/pgf/pgf.c index a1649b9ff..5317830fb 100644 --- a/src/runtime/c/pgf/pgf.c +++ b/src/runtime/c/pgf/pgf.c @@ -2,6 +2,7 @@ #include <pgf/data.h> #include <pgf/expr.h> #include <pgf/reader.h> +#include <pgf/writer.h> #include <pgf/linearizer.h> #include <gu/file.h> #include <gu/string.h> @@ -44,6 +45,28 @@ pgf_read_in(GuIn* in, return pgf; } +PGF_API_DECL void +pgf_write(PgfPGF* pgf, const char* fpath, GuExn* err) +{ + FILE* outfile = fopen(fpath, "wb"); + if (outfile == NULL) { + gu_raise_errno(err); + return; + } + + GuPool* tmp_pool = gu_local_pool(); + + // Create an input stream from the input file + GuOut* out = gu_file_out(outfile, tmp_pool); + + PgfWriter* wtr = pgf_new_writer(out, tmp_pool, err); + pgf_write_pgf(pgf, wtr); + + gu_pool_free(tmp_pool); + + fclose(outfile); +} + PGF_API GuString pgf_abstract_name(PgfPGF* pgf) { @@ -101,7 +124,7 @@ pgf_start_cat(PgfPGF* pgf, GuPool* pool) GuPool* tmp_pool = gu_local_pool(); GuIn* in = gu_string_in(lstr->val,tmp_pool); GuExn* err = gu_new_exn(tmp_pool); - PgfType *type = pgf_read_type(in, pool, err); + PgfType *type = pgf_read_type(in, pool, tmp_pool, err); if (!gu_ok(err)) break; gu_pool_free(tmp_pool); @@ -117,6 +140,29 @@ pgf_start_cat(PgfPGF* pgf, GuPool* pool) return type; } +PGF_API PgfHypos* +pgf_category_context(PgfPGF *gr, PgfCId catname) +{ + PgfAbsCat* abscat = + gu_seq_binsearch(gr->abstract.cats, pgf_abscat_order, PgfAbsCat, catname); + if (abscat == NULL) { + return NULL; + } + + return abscat->context; +} + +PGF_API prob_t +pgf_category_prob(PgfPGF* pgf, PgfCId catname) +{ + PgfAbsCat* abscat = + gu_seq_binsearch(pgf->abstract.cats, pgf_abscat_order, PgfAbsCat, catname); + if (abscat == NULL) + return INFINITY; + + return abscat->prob; +} + PGF_API GuString pgf_language_code(PgfConcr* concr) { @@ -150,7 +196,7 @@ pgf_iter_functions(PgfPGF* pgf, GuMapItor* itor, GuExn* err) } PGF_API void -pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname, +pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname, GuMapItor* itor, GuExn* err) { size_t n_funs = gu_seq_length(pgf->abstract.funs); @@ -176,7 +222,17 @@ pgf_function_type(PgfPGF* pgf, PgfCId funname) return absfun->type; } -PGF_API double +PGF_API_DECL bool +pgf_function_is_constructor(PgfPGF* pgf, PgfCId funname) +{ + PgfAbsFun* absfun = + gu_seq_binsearch(pgf->abstract.funs, pgf_absfun_order, PgfAbsFun, funname); + if (absfun == NULL) + return false; + return (absfun->defns == NULL); +} + +PGF_API prob_t pgf_function_prob(PgfPGF* pgf, PgfCId funname) { PgfAbsFun* absfun = diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 632a1d332..6dd040b49 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -19,6 +19,14 @@ #define PGF_INTERNAL_DECL #define PGF_INTERNAL +#elif defined(__MINGW32__) + +#define PGF_API_DECL +#define PGF_API + +#define PGF_INTERNAL_DECL +#define PGF_INTERNAL + #else #define PGF_API_DECL @@ -57,6 +65,9 @@ pgf_concrete_load(PgfConcr* concr, GuIn* in, GuExn* err); PGF_API_DECL void pgf_concrete_unload(PgfConcr* concr); +PGF_API_DECL void +pgf_write(PgfPGF* pgf, const char* fpath, GuExn* err); + PGF_API_DECL GuString pgf_abstract_name(PgfPGF*); @@ -78,6 +89,12 @@ pgf_iter_categories(PgfPGF* pgf, GuMapItor* itor, GuExn* err); PGF_API_DECL PgfType* pgf_start_cat(PgfPGF* pgf, GuPool* pool); +PGF_API_DECL PgfHypos* +pgf_category_context(PgfPGF *gr, PgfCId catname); + +PGF_API_DECL prob_t +pgf_category_prob(PgfPGF* pgf, PgfCId catname); + PGF_API_DECL void pgf_iter_functions(PgfPGF* pgf, GuMapItor* itor, GuExn* err); @@ -88,7 +105,10 @@ pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname, PGF_API_DECL PgfType* pgf_function_type(PgfPGF* pgf, PgfCId funname); -PGF_API_DECL double +PGF_API_DECL bool +pgf_function_is_constructor(PgfPGF* pgf, PgfCId funname); + +PGF_API_DECL prob_t pgf_function_prob(PgfPGF* pgf, PgfCId funname); PGF_API_DECL GuString @@ -122,6 +142,13 @@ PGF_API_DECL PgfExprEnum* pgf_generate_all(PgfPGF* pgf, PgfType* ty, GuExn* err, GuPool* pool, GuPool* out_pool); +typedef struct { + int incomplete; // equal to !=0 if the sentence is incomplete, 0 otherwise + size_t offset; + const char* token_ptr; + size_t token_len; +} PgfParseError; + PGF_API_DECL PgfExprEnum* pgf_parse(PgfConcr* concr, PgfType* typ, GuString sentence, GuExn* err, GuPool* pool, GuPool* out_pool); @@ -193,6 +220,7 @@ pgf_parse_with_oracle(PgfConcr* concr, PgfType* typ, typedef struct { PgfToken tok; PgfCId cat; + PgfCId fun; prob_t prob; } PgfTokenProb; diff --git a/src/runtime/c/pgf/reader.c b/src/runtime/c/pgf/reader.c index 2129269e8..d7094c9d5 100644 --- a/src/runtime/c/pgf/reader.c +++ b/src/runtime/c/pgf/reader.c @@ -936,20 +936,9 @@ pgf_read_pargs(PgfReader* rdr, PgfConcr* concr) return pargs; } -extern void -pgf_parser_index(PgfConcr* concr, - PgfCCat* ccat, PgfProduction prod, - bool is_lexical, - GuPool *pool); - -extern void -pgf_lzr_index(PgfConcr* concr, - PgfCCat* ccat, PgfProduction prod, - bool is_lexical, - GuPool *pool); - -static bool -pgf_production_is_lexical(PgfReader* rdr, PgfProductionApply *papp) +PGF_API bool +pgf_production_is_lexical(PgfProductionApply *papp, + GuBuf* non_lexical_buf, GuPool* pool) { if (gu_seq_length(papp->args) > 0) return false; @@ -969,13 +958,13 @@ pgf_production_is_lexical(PgfReader* rdr, PgfProductionApply *papp) inf.tag == PGF_SYMBOL_SOFT_SPACE || inf.tag == PGF_SYMBOL_CAPIT || inf.tag == PGF_SYMBOL_ALL_CAPIT) { - seq->idx = rdr->non_lexical_buf; + seq->idx = non_lexical_buf; return false; } } - seq->idx = gu_new_buf(PgfProductionIdxEntry, rdr->opool); - } if (seq->idx == rdr->non_lexical_buf) { + seq->idx = gu_new_buf(PgfProductionIdxEntry, pool); + } if (seq->idx == non_lexical_buf) { return false; } } @@ -1004,7 +993,7 @@ pgf_read_production(PgfReader* rdr, PgfConcr* concr, papp->args = pgf_read_pargs(rdr, concr); gu_return_on_exn(rdr->err, ); - is_lexical = pgf_production_is_lexical(rdr, papp); + is_lexical = pgf_production_is_lexical(papp, rdr->non_lexical_buf, rdr->opool); if (!is_lexical) gu_seq_set(ccat->prods, PgfProduction, (*top)++, prod); else @@ -1075,7 +1064,7 @@ pgf_read_cnccat(PgfReader* rdr, PgfAbstr* abstr, PgfConcr* concr, PgfCId name) int len = last + 1 - first; cnccat->cats = gu_new_seq(PgfCCat*, len, rdr->opool); - + for (int i = 0; i < len; i++) { int fid = first + i; PgfCCat* ccat = gu_map_get(concr->ccats, &fid, PgfCCat*); diff --git a/src/runtime/c/pgf/writer.c b/src/runtime/c/pgf/writer.c new file mode 100644 index 000000000..57c7e3c76 --- /dev/null +++ b/src/runtime/c/pgf/writer.c @@ -0,0 +1,922 @@ +#include "data.h" +#include "expr.h" +#include "writer.h" + +#include <gu/defs.h> +#include <gu/map.h> +#include <gu/seq.h> +#include <gu/assert.h> +#include <gu/in.h> +#include <gu/bits.h> +#include <gu/exn.h> +#include <gu/utf8.h> +#include <math.h> +#include <stdio.h> +#include <stdlib.h> +#if defined(__MINGW32__) || defined(_MSC_VER) +#include <malloc.h> +#endif + +// +// PgfWriter +// + +struct PgfWriter { + GuOut* out; + GuExn* err; +}; + +PGF_INTERNAL void +pgf_write_tag(uint8_t tag, PgfWriter* wtr) +{ + gu_out_u8(wtr->out, tag, wtr->err); +} + +PGF_INTERNAL void +pgf_write_uint(uint32_t val, PgfWriter* wtr) +{ + for (;;) { + uint8_t b = val & 0x7F; + val = val >> 7; + if (val == 0) { + gu_out_u8(wtr->out, b, wtr->err); + break; + } else { + gu_out_u8(wtr->out, b | 0x80, wtr->err); + gu_return_on_exn(wtr->err, ); + } + } +} + +PGF_INTERNAL void +pgf_write_int(int32_t val, PgfWriter* wtr) +{ + pgf_write_uint((uint32_t) val, wtr); +} + +PGF_INTERNAL void +pgf_write_len(size_t len, PgfWriter* wtr) +{ + pgf_write_int(len, wtr); +} + +PGF_INTERNAL void +pgf_write_cid(PgfCId id, PgfWriter* wtr) +{ + size_t len = strlen(id); + pgf_write_len(len, wtr); + gu_return_on_exn(wtr->err, ); + gu_out_bytes(wtr->out, (uint8_t*) id, len, wtr->err); +} + +PGF_INTERNAL void +pgf_write_string(GuString val, PgfWriter* wtr) +{ + size_t len = strlen(val); + pgf_write_len(len, wtr); + gu_return_on_exn(wtr->err, ); + gu_out_bytes(wtr->out, (uint8_t*) val, len, wtr->err); +} + +PGF_INTERNAL void +pgf_write_double(double val, PgfWriter* wtr) +{ + gu_out_f64be(wtr->out, val, wtr->err); +} + +static void +pgf_write_literal(PgfLiteral lit, PgfWriter* wtr) +{ + GuVariantInfo i = gu_variant_open(lit); + pgf_write_tag(i.tag, wtr); + gu_return_on_exn(wtr->err, ); + switch (i.tag) { + case PGF_LITERAL_STR: { + PgfLiteralStr *lstr = i.data; + pgf_write_string(lstr->val, wtr); + break; + } + case PGF_LITERAL_INT: { + PgfLiteralInt *lint = i.data; + pgf_write_int(lint->val, wtr); + break; + } + case PGF_LITERAL_FLT: { + PgfLiteralFlt *lflt = i.data; + pgf_write_double(lflt->val, wtr); + break; + } + default: + gu_impossible(); + } +} + +static void +pgf_write_flags(PgfFlags* flags, PgfWriter* wtr) +{ + size_t n_flags = gu_seq_length(flags); + pgf_write_len(n_flags, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < n_flags; i++) { + PgfFlag* flag = gu_seq_index(flags, PgfFlag, i); + + pgf_write_cid(flag->name, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_literal(flag->value, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_type_(PgfType* type, PgfWriter* wtr); + +static void +pgf_write_expr_(PgfExpr expr, PgfWriter* wtr) +{ + GuVariantInfo i = gu_variant_open(expr); + pgf_write_tag(i.tag, wtr); + gu_return_on_exn(wtr->err, ); + switch (i.tag) { + case PGF_EXPR_ABS:{ + PgfExprAbs *eabs = i.data; + + pgf_write_tag(eabs->bind_type, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_cid(eabs->id, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_expr_(eabs->body, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_APP: { + PgfExprApp *eapp = i.data; + + pgf_write_expr_(eapp->fun, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_expr_(eapp->arg, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_LIT: { + PgfExprLit *elit = i.data; + pgf_write_literal(elit->lit, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_META: { + PgfExprMeta *emeta = i.data; + pgf_write_int(emeta->id, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_FUN: { + PgfExprFun *efun = i.data; + pgf_write_cid(efun->fun, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_VAR: { + PgfExprVar *evar = i.data; + pgf_write_int(evar->var, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_TYPED: { + PgfExprTyped *etyped = i.data; + pgf_write_expr_(etyped->expr, wtr); + gu_return_on_exn(wtr->err, ); + pgf_write_type_(etyped->type, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_IMPL_ARG: { + PgfExprImplArg *eimpl = i.data; + pgf_write_expr_(eimpl->expr, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + default: + gu_impossible(); + } +} + +static void +pgf_write_hypo(PgfHypo* hypo, PgfWriter* wtr) +{ + pgf_write_tag(hypo->bind_type, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_cid(hypo->cid, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_type_(hypo->type, wtr); + gu_return_on_exn(wtr->err, ); +} + +static void +pgf_write_type_(PgfType* type, PgfWriter* wtr) +{ + size_t n_hypos = gu_seq_length(type->hypos); + pgf_write_len(n_hypos, wtr); + gu_return_on_exn(wtr->err, ); + for (size_t i = 0; i < n_hypos; i++) { + PgfHypo* hypo = gu_seq_index(type->hypos, PgfHypo, i); + pgf_write_hypo(hypo, wtr); + gu_return_on_exn(wtr->err, ); + } + + pgf_write_cid(type->cid, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_len(type->n_exprs, wtr); + + for (size_t i = 0; i < type->n_exprs; i++) { + pgf_write_expr_(type->exprs[i], wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_patt(PgfPatt patt, PgfWriter* wtr) +{ + GuVariantInfo i = gu_variant_open(patt); + switch (i.tag) { + case PGF_PATT_APP: { + PgfPattApp *papp = i.data; + pgf_write_cid(papp->ctor, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_len(papp->n_args, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < papp->n_args; i++) { + pgf_write_patt(papp->args[i], wtr); + gu_return_on_exn(wtr->err, ); + } + break; + } + case PGF_PATT_VAR: { + PgfPattVar *papp = i.data; + pgf_write_cid(papp->var, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_PATT_AS: { + PgfPattAs *pas = i.data; + pgf_write_cid(pas->var, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_patt(pas->patt, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_PATT_WILD: { + PgfPattWild* pwild = i.data; + ((void) pwild); + break; + } + case PGF_PATT_LIT: { + PgfPattLit *plit = i.data; + pgf_write_literal(plit->lit, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_PATT_IMPL_ARG: { + PgfPattImplArg *pimpl = i.data; + pgf_write_patt(pimpl->patt, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_PATT_TILDE: { + PgfPattTilde *ptilde = i.data; + pgf_write_expr_(ptilde->expr, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + default: + gu_impossible(); + } +} + +static void +pgf_write_absfun(PgfAbsFun* absfun, PgfWriter* wtr) +{ + pgf_write_cid(absfun->name,wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_type_(absfun->type, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_int(absfun->arity, wtr); + + pgf_write_tag((absfun->defns == NULL) ? 0 : 1, wtr); + gu_return_on_exn(wtr->err, ); + + if (absfun->defns != NULL) { + size_t length = gu_seq_length(absfun->defns); + pgf_write_len(length, wtr); + gu_return_on_exn(wtr->err, ); + + PgfEquation** data = gu_seq_data(absfun->defns); + for (size_t i = 0; i < length; i++) { + PgfEquation *equ = data[i]; + + pgf_write_len(equ->n_patts, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t j = 0; j < equ->n_patts; j++) { + pgf_write_patt(equ->patts[j], wtr); + gu_return_on_exn(wtr->err, ); + } + pgf_write_expr_(equ->body, wtr); + gu_return_on_exn(wtr->err, ); + } + } + + pgf_write_double(exp(-absfun->ep.prob), wtr); +} + +static void +pgf_write_absfuns(PgfAbsFuns* absfuns, PgfWriter* wtr) +{ + size_t n_funs = gu_seq_length(absfuns); + pgf_write_len(n_funs, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < n_funs; i++) { + PgfAbsFun* absfun = gu_seq_index(absfuns, PgfAbsFun, i); + pgf_write_absfun(absfun, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_abscat(PgfAbsCat* abscat, PgfAbstr* abstr, PgfWriter* wtr) +{ + pgf_write_cid(abscat->name, wtr); + gu_return_on_exn(wtr->err, ); + + size_t n_hypos = gu_seq_length(abscat->context); + pgf_write_len(n_hypos, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < n_hypos; i++) { + PgfHypo* hypo = gu_seq_index(abscat->context, PgfHypo, i); + pgf_write_hypo(hypo, wtr); + gu_return_on_exn(wtr->err, ); + } + + size_t n_count = 0; + size_t n_funs = gu_seq_length(abstr->funs); + for (size_t i = 0; i < n_funs; i++) { + PgfAbsFun* fun = gu_seq_index(abstr->funs, PgfAbsFun, i); + + if (strcmp(fun->type->cid, abscat->name) == 0) { + n_count++; + } + } + pgf_write_len(n_count, wtr); + for (size_t i = 0; i < n_funs; i++) { + PgfAbsFun* fun = gu_seq_index(abstr->funs, PgfAbsFun, i); + + if (strcmp(fun->type->cid, abscat->name) == 0) { + gu_out_f64be(wtr->out, exp(-fun->ep.prob), wtr->err); // ignore + gu_return_on_exn(wtr->err, ); + + pgf_write_cid(fun->name, wtr); + gu_return_on_exn(wtr->err, ); + } + } + + pgf_write_double(exp(-abscat->prob), wtr); +} + +static void +pgf_write_abscats(PgfAbsCats* abscats, PgfAbstr* abstr, PgfWriter* wtr) +{ + size_t n_cats = gu_seq_length(abscats); + pgf_write_len(n_cats, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < n_cats; i++) { + PgfAbsCat* abscat = gu_seq_index(abscats, PgfAbsCat, i); + pgf_write_abscat(abscat, abstr, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_abstract(PgfAbstr* abstr, PgfWriter* wtr) +{ + pgf_write_cid(abstr->name, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_flags(abstr->aflags, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_absfuns(abstr->funs, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_abscats(abstr->cats, abstr, wtr); + gu_return_on_exn(wtr->err, ); +} + +typedef struct { + GuMapItor itor; + PgfWriter* wtr; +} PgfWriterIter; + +static void +pgf_write_printname(GuMapItor* self, const void* key, void* value, GuExn *err) +{ + PgfWriterIter* itor = gu_container(self, PgfWriterIter, itor); + PgfCId id = key; + GuString name = value; + + pgf_write_cid(id, itor->wtr); + gu_return_on_exn(err, ); + + pgf_write_string(name, itor->wtr); + gu_return_on_exn(err, ); +} + +static void +pgf_write_printnames(PgfCIdMap* printnames, PgfWriter* wtr) +{ + pgf_write_len(gu_map_count(printnames), wtr); + gu_return_on_exn(wtr->err, ); + + PgfWriterIter itor; + itor.itor.fn = pgf_write_printname; + itor.wtr = wtr; + gu_map_iter(printnames, &itor.itor, wtr->err); + gu_return_on_exn(wtr->err, ); +} + +static void +pgf_write_symbols(PgfSymbols*, PgfWriter* wtr); + +static void +pgf_write_alternative(PgfAlternative* alt, PgfWriter* wtr) +{ + pgf_write_symbols(alt->form, wtr); + gu_return_on_exn(wtr->err,); + + size_t n_prefixes = gu_seq_length(alt->prefixes); + pgf_write_len(n_prefixes, wtr); + gu_return_on_exn(wtr->err,); + + for (size_t i = 0; i < n_prefixes; i++) { + GuString prefix = gu_seq_get(alt->prefixes, GuString, i); + + pgf_write_string(prefix, wtr); + gu_return_on_exn(wtr->err,); + } +} + +static void +pgf_write_symbol(PgfSymbol sym, PgfWriter* wtr) +{ + GuVariantInfo i = gu_variant_open(sym); + + pgf_write_tag(i.tag, wtr); + switch (i.tag) { + case PGF_SYMBOL_CAT: { + PgfSymbolCat *sym_cat = i.data; + + pgf_write_int(sym_cat->d, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_int(sym_cat->r, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_SYMBOL_LIT: { + PgfSymbolLit *sym_lit = i.data; + + pgf_write_int(sym_lit->d, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_int(sym_lit->r, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_SYMBOL_VAR: { + PgfSymbolVar *sym_var = i.data; + + pgf_write_int(sym_var->d, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_int(sym_var->r, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_SYMBOL_KS: { + PgfSymbolKS *sym_ks = i.data; + pgf_write_string(sym_ks->token, wtr); + break; + } + case PGF_SYMBOL_KP: { + PgfSymbolKP *sym_kp = i.data; + pgf_write_symbols(sym_kp->default_form, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_len(sym_kp->n_forms, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < sym_kp->n_forms; i++) { + pgf_write_alternative(&sym_kp->forms[i], wtr); + gu_return_on_exn(wtr->err, ); + } + break; + } + case PGF_SYMBOL_NE: + case PGF_SYMBOL_BIND: + case PGF_SYMBOL_SOFT_BIND: + case PGF_SYMBOL_SOFT_SPACE: + case PGF_SYMBOL_CAPIT: + case PGF_SYMBOL_ALL_CAPIT: { + break; + } + default: + gu_impossible(); + } +} + +static void +pgf_write_symbols(PgfSymbols* syms, PgfWriter* wtr) +{ + size_t len = gu_seq_length(syms); + pgf_write_len(len, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < len; i++) { + PgfSymbol sym = gu_seq_get(syms, PgfSymbol, i); + pgf_write_symbol(sym, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_sequences(PgfSequences* seqs, PgfWriter* wtr) +{ + size_t len = gu_seq_length(seqs); + pgf_write_len(len, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < len; i++) { + PgfSymbols* syms = gu_seq_index(seqs, PgfSequence, i)->syms; + pgf_write_symbols(syms, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_cncfun(PgfCncFun* cncfun, PgfConcr* concr, PgfWriter* wtr) +{ + pgf_write_cid(cncfun->absfun->name, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_len(cncfun->n_lins, wtr); + gu_return_on_exn(wtr->err, ); + + PgfSequence* data = gu_seq_data(concr->sequences); + for (size_t i = 0; i < cncfun->n_lins; i++) { + size_t seq_id = (cncfun->lins[i] - data); + + pgf_write_int(seq_id, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_cncfuns(PgfCncFuns* cncfuns, PgfConcr* concr, PgfWriter* wtr) +{ + size_t len = gu_seq_length(cncfuns); + pgf_write_len(len, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t funid = 0; funid < len; funid++) { + PgfCncFun* cncfun = gu_seq_get(cncfuns, PgfCncFun*, funid); + + pgf_write_cncfun(cncfun, concr, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_fid(PgfCCat* ccat, PgfWriter* wtr) +{ + pgf_write_int(ccat->fid, wtr); + gu_return_on_exn(wtr->err, ); +} + +static void +pgf_write_funid(PgfCncFun* cncfun, PgfWriter* wtr) +{ + pgf_write_int(cncfun->funid, wtr); + gu_return_on_exn(wtr->err, ); +} + +typedef struct { + GuMapItor itor; + PgfWriter* wtr; + bool do_count; + bool do_defs; + size_t count; +} PgfLinDefRefIter; + +static void +pgf_write_ccat_lindefrefs(GuMapItor* self, const void* key, void* value, GuExn *err) +{ + PgfLinDefRefIter* itor = gu_container(self, PgfLinDefRefIter, itor); + PgfCCat* ccat = *((PgfCCat**) value); + + PgfCncFuns* funs = (itor->do_defs) ? ccat->lindefs : ccat->linrefs; + if (funs != NULL) { + if (itor->do_count) { + itor->count++; + } else { + pgf_write_fid(ccat, itor->wtr); + gu_return_on_exn(err, ); + + size_t n_funs = gu_seq_length(funs); + pgf_write_len(n_funs, itor->wtr); + gu_return_on_exn(err, ); + + for (size_t j = 0; j < n_funs; j++) { + PgfCncFun* fun = gu_seq_get(funs, PgfCncFun*, j); + pgf_write_funid(fun, itor->wtr); + } + } + } +} + +static void +pgf_write_lindefs(PgfWriter* wtr, PgfConcr* concr) +{ + PgfLinDefRefIter itor; + itor.itor.fn = pgf_write_ccat_lindefrefs; + itor.wtr = wtr; + itor.do_count= true; + itor.do_defs = true; + itor.count = 0; + gu_map_iter(concr->ccats, &itor.itor, wtr->err); + + pgf_write_len(itor.count, wtr); + gu_return_on_exn(wtr->err, ); + + itor.do_count = false; + gu_map_iter(concr->ccats, &itor.itor, wtr->err); + gu_return_on_exn(wtr->err, ); +} + +static void +pgf_write_linrefs(PgfWriter* wtr, PgfConcr* concr) +{ + PgfLinDefRefIter itor; + itor.itor.fn = pgf_write_ccat_lindefrefs; + itor.wtr = wtr; + itor.do_count= true; + itor.do_defs = false; + itor.count = 0; + gu_map_iter(concr->ccats, &itor.itor, wtr->err); + + pgf_write_len(itor.count, wtr); + gu_return_on_exn(wtr->err, ); + + itor.do_count = false; + gu_map_iter(concr->ccats, &itor.itor, wtr->err); + gu_return_on_exn(wtr->err, ); +} + +static void +pgf_write_parg(PgfPArg* parg, PgfWriter* wtr) +{ + size_t n_hoas = gu_seq_length(parg->hypos); + pgf_write_len(n_hoas, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < n_hoas; i++) { + PgfCCat* ccat = gu_seq_get(parg->hypos, PgfCCat*, i); + pgf_write_fid(ccat, wtr); + gu_return_on_exn(wtr->err, ); + } + + pgf_write_fid(parg->ccat, wtr); + gu_return_on_exn(wtr->err, ); +} + +static void +pgf_write_pargs(PgfPArgs* pargs, PgfWriter* wtr) +{ + size_t len = gu_seq_length(pargs); + pgf_write_len(len, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < len; i++) { + PgfPArg* parg = gu_seq_index(pargs, PgfPArg, i); + pgf_write_parg(parg, wtr); + } +} + +static void +pgf_write_production(PgfProduction prod, PgfWriter* wtr) +{ + GuVariantInfo i = gu_variant_open(prod); + pgf_write_tag(i.tag, wtr); + switch (i.tag) { + case PGF_PRODUCTION_APPLY: { + PgfProductionApply *papp = i.data; + + pgf_write_funid(papp->fun, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_pargs(papp->args, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_PRODUCTION_COERCE: { + PgfProductionCoerce *pcoerce = i.data; + + pgf_write_fid(pcoerce->coerce, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + default: + gu_impossible(); + } +} + +static void +pgf_write_ccat(GuMapItor* self, const void* key, void* value, GuExn *err) +{ + PgfWriterIter* itor = gu_container(self, PgfWriterIter, itor); + PgfCCat* ccat = *((PgfCCat**) value); + + pgf_write_fid(ccat, itor->wtr); + gu_return_on_exn(err, ); + + size_t n_prods = ccat->prods ? gu_seq_length(ccat->prods) : 0; + pgf_write_len(n_prods, itor->wtr); + gu_return_on_exn(err, ); + + for (size_t i = 0; i < n_prods; i++) { + PgfProduction prod = gu_seq_get(ccat->prods, PgfProduction, i); + pgf_write_production(prod, itor->wtr); + gu_return_on_exn(err, ); + } +} + +static void +pgf_write_ccats(GuMap* ccats, PgfWriter* wtr) +{ + pgf_write_len(gu_map_count(ccats), wtr); + gu_return_on_exn(wtr->err, ); + + PgfWriterIter itor; + itor.itor.fn = pgf_write_ccat; + itor.wtr = wtr; + gu_map_iter(ccats, &itor.itor, wtr->err); +} + +static void +pgf_write_cnccat(PgfCncCat* cnccat, PgfWriter* wtr) +{ + size_t len = gu_seq_length(cnccat->cats); + PgfCCat* first = gu_seq_get(cnccat->cats, PgfCCat*, 0); + PgfCCat* last = gu_seq_get(cnccat->cats, PgfCCat*, len-1); + pgf_write_fid(first,wtr); + pgf_write_fid(last,wtr); + pgf_write_len(cnccat->n_lins, wtr); + + for (size_t i = 0; i < cnccat->n_lins; i++) { + pgf_write_string(cnccat->labels[i], wtr); + } +} + +static void +pgf_write_cnccat_iter(GuMapItor* self, const void* key, void* value, GuExn *err) +{ + PgfWriterIter* itor = gu_container(self, PgfWriterIter, itor); + PgfCncCat* cnccat = *((PgfCncCat**) value); + + pgf_write_cid(cnccat->abscat->name, itor->wtr); + gu_return_on_exn(err, ); + + pgf_write_cnccat(cnccat, itor->wtr); +} + +static void +pgf_write_cnccats(PgfCIdMap* cnccats, PgfWriter* wtr) +{ + pgf_write_len(gu_map_count(cnccats), wtr); + gu_return_on_exn(wtr->err, ); + + PgfWriterIter itor; + itor.itor.fn = pgf_write_cnccat_iter; + itor.wtr = wtr; + gu_map_iter(cnccats, &itor.itor, wtr->err); +} + +static void +pgf_write_concrete_content(PgfConcr* concr, PgfWriter* wtr) +{ + pgf_write_printnames(concr->printnames, wtr); + gu_return_on_exn(wtr->err,); + + pgf_write_sequences(concr->sequences, wtr); + gu_return_on_exn(wtr->err,); + + pgf_write_cncfuns(concr->cncfuns, concr, wtr); + gu_return_on_exn(wtr->err,); + + pgf_write_lindefs(wtr, concr); + pgf_write_linrefs(wtr, concr); + pgf_write_ccats(concr->ccats, wtr); + pgf_write_cnccats(concr->cnccats, wtr); + pgf_write_int(concr->total_cats, wtr); +} + +static void +pgf_write_concrete(PgfConcr* concr, PgfWriter* wtr, bool with_content) +{ + if (with_content && + (concr->sequences == NULL || concr->cncfuns == NULL || + concr->ccats == NULL || concr->cnccats == NULL)) { + // the syntax is not loaded so we must skip it. + return; + } + + pgf_write_cid(concr->name, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_flags(concr->cflags, wtr); + gu_return_on_exn(wtr->err, ); + + if (with_content) { + pgf_write_concrete_content(concr, wtr); + } + gu_return_on_exn(wtr->err, ); +} + +PGF_API void +pgf_concrete_save(PgfConcr* concr, GuOut* out, GuExn* err) +{ + GuPool* pool = gu_new_pool(); + + PgfWriter* wtr = pgf_new_writer(out, pool, err); + + pgf_write_concrete(concr, wtr, true); + + gu_pool_free(pool); +} + +static void +pgf_write_concretes(PgfConcrs* concretes, PgfWriter* wtr, bool with_content) +{ + size_t n_concrs = gu_seq_length(concretes); + pgf_write_len(n_concrs, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < n_concrs; i++) { + PgfConcr* concr = gu_seq_index(concretes, PgfConcr, i); + pgf_write_concrete(concr, wtr, with_content); + gu_return_on_exn(wtr->err, ); + } +} + +PGF_INTERNAL void +pgf_write_pgf(PgfPGF* pgf, PgfWriter* wtr) { + gu_out_u16be(wtr->out, pgf->major_version, wtr->err); + gu_return_on_exn(wtr->err, ); + + gu_out_u16be(wtr->out, pgf->minor_version, wtr->err); + gu_return_on_exn(wtr->err, ); + + pgf_write_flags(pgf->gflags, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_abstract(&pgf->abstract, wtr); + gu_return_on_exn(wtr->err, ); + + bool with_content = + (gu_seq_binsearch(pgf->gflags, pgf_flag_order, PgfFlag, "split") == NULL); + pgf_write_concretes(pgf->concretes, wtr, with_content); + gu_return_on_exn(wtr->err, ); +} + +PGF_INTERNAL PgfWriter* +pgf_new_writer(GuOut* out, GuPool* pool, GuExn* err) +{ + PgfWriter* wtr = gu_new(PgfWriter, pool); + wtr->out = out; + wtr->err = err; + return wtr; +} + diff --git a/src/runtime/c/pgf/writer.h b/src/runtime/c/pgf/writer.h new file mode 100644 index 000000000..de99ee266 --- /dev/null +++ b/src/runtime/c/pgf/writer.h @@ -0,0 +1,39 @@ +#ifndef WRITER_H_ +#define WRITER_H_ + +#include <gu/exn.h> +#include <gu/mem.h> +#include <gu/in.h> + +// the writer interface + +typedef struct PgfWriter PgfWriter; + +PGF_INTERNAL_DECL PgfWriter* +pgf_new_writer(GuOut* out, GuPool* pool, GuExn* err); + +PGF_INTERNAL_DECL void +pgf_write_tag(uint8_t tag, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_uint(uint32_t val, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_int(int32_t val, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_string(GuString val, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_double(double val, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_len(size_t len, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_cid(PgfCId id, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_pgf(PgfPGF* pgf, PgfWriter* wtr); + +#endif // WRITER_H_ diff --git a/src/runtime/c/sg/sqlite3Btree.c b/src/runtime/c/sg/sqlite3Btree.c index 999606791..a75cfd62b 100644 --- a/src/runtime/c/sg/sqlite3Btree.c +++ b/src/runtime/c/sg/sqlite3Btree.c @@ -5040,6 +5040,30 @@ SQLITE_PRIVATE int sqlite3VdbeRecordCompareWithSkip(int, const void *, UnpackedR */ /* #include "sqliteInt.h" */ +/* An array to map all upper-case characters into their corresponding +** lower-case character. +** +** SQLite only considers US-ASCII (or EBCDIC) characters. We do not +** handle case conversions for the UTF character set since the tables +** involved are nearly as big or bigger than SQLite itself. +*/ +const unsigned char sqlite3UpperToLower[] = { + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, + 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, + 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, + 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 97, 98, 99,100,101,102,103, + 104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121, + 122, 91, 92, 93, 94, 95, 96, 97, 98, 99,100,101,102,103,104,105,106,107, + 108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125, + 126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143, + 144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161, + 162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179, + 180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197, + 198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215, + 216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233, + 234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251, + 252,253,254,255 +}; /* EVIDENCE-OF: R-02982-34736 In order to maintain full backwards ** compatibility for legacy applications, the URI filename capability is ** disabled by default. @@ -9063,6 +9087,22 @@ SQLITE_PRIVATE int sqlite3Strlen30(const char *z){ return 0x3fffffff & (int)strlen(z); } +/* Convenient short-hand */ +#define UpperToLower sqlite3UpperToLower + +int sqlite3StrICmp(const char *zLeft, const char *zRight){ + unsigned char *a, *b; + int c; + a = (unsigned char *)zLeft; + b = (unsigned char *)zRight; + for(;;){ + c = (int)UpperToLower[*a] - (int)UpperToLower[*b]; + if( c || *a==0 ) break; + a++; + b++; + } + return c; +} /* ** The string z[] is an text representation of a real number. ** Convert this string to a double and write it into *pResult. @@ -17831,13 +17871,6 @@ struct winFile { #define WINFILE_PSOW 0x10 /* SQLITE_IOCAP_POWERSAFE_OVERWRITE */ /* - * The size of the buffer used by sqlite3_win32_write_debug(). - */ -#ifndef SQLITE_WIN32_DBG_BUF_SIZE -# define SQLITE_WIN32_DBG_BUF_SIZE ((int)(4096-sizeof(DWORD))) -#endif - -/* * The value used with sqlite3_win32_set_directory() to specify that * the temporary directory should be changed. */ @@ -18786,43 +18819,6 @@ SQLITE_PRIVATE int sqlite3_win32_reset_heap(){ #endif /* SQLITE_WIN32_MALLOC */ /* -** This function outputs the specified (ANSI) string to the Win32 debugger -** (if available). -*/ - -SQLITE_PRIVATE void sqlite3_win32_write_debug(const char *zBuf, int nBuf){ - char zDbgBuf[SQLITE_WIN32_DBG_BUF_SIZE]; - int nMin = MIN(nBuf, (SQLITE_WIN32_DBG_BUF_SIZE - 1)); /* may be negative. */ - if( nMin<-1 ) nMin = -1; /* all negative values become -1. */ - assert( nMin==-1 || nMin==0 || nMin<SQLITE_WIN32_DBG_BUF_SIZE ); -#if defined(SQLITE_WIN32_HAS_ANSI) - if( nMin>0 ){ - memset(zDbgBuf, 0, SQLITE_WIN32_DBG_BUF_SIZE); - memcpy(zDbgBuf, zBuf, nMin); - osOutputDebugStringA(zDbgBuf); - }else{ - osOutputDebugStringA(zBuf); - } -#elif defined(SQLITE_WIN32_HAS_WIDE) - memset(zDbgBuf, 0, SQLITE_WIN32_DBG_BUF_SIZE); - if ( osMultiByteToWideChar( - osAreFileApisANSI() ? CP_ACP : CP_OEMCP, 0, zBuf, - nMin, (LPWSTR)zDbgBuf, SQLITE_WIN32_DBG_BUF_SIZE/sizeof(WCHAR))<=0 ){ - return; - } - osOutputDebugStringW((LPCWSTR)zDbgBuf); -#else - if( nMin>0 ){ - memset(zDbgBuf, 0, SQLITE_WIN32_DBG_BUF_SIZE); - memcpy(zDbgBuf, zBuf, nMin); - fprintf(stderr, "%s", zDbgBuf); - }else{ - fprintf(stderr, "%s", zBuf); - } -#endif -} - -/* ** The following routine suspends the current thread for at least ms ** milliseconds. This is equivalent to the Win32 Sleep() interface. */ @@ -19264,40 +19260,6 @@ SQLITE_PRIVATE char *sqlite3_win32_utf8_to_mbcs(const char *zFilename){ } /* -** This function sets the data directory or the temporary directory based on -** the provided arguments. The type argument must be 1 in order to set the -** data directory or 2 in order to set the temporary directory. The zValue -** argument is the name of the directory to use. The return value will be -** SQLITE_OK if successful. -*/ -SQLITE_PRIVATE int sqlite3_win32_set_directory(DWORD type, LPCWSTR zValue){ - char **ppDirectory = 0; -#ifndef SQLITE_OMIT_AUTOINIT - int rc = sqlite3BtreeInitialize(); - if( rc ) return rc; -#endif - if( type==SQLITE_WIN32_TEMP_DIRECTORY_TYPE ){ - ppDirectory = &sqlite3_temp_directory; - } - assert( !ppDirectory || type==SQLITE_WIN32_TEMP_DIRECTORY_TYPE - ); - assert( !ppDirectory || sqlite3MemdebugHasType(*ppDirectory, MEMTYPE_HEAP) ); - if( ppDirectory ){ - char *zValueUtf8 = 0; - if( zValue && zValue[0] ){ - zValueUtf8 = winUnicodeToUtf8(zValue); - if ( zValueUtf8==0 ){ - return SQLITE_NOMEM; - } - } - sqlite3_free(*ppDirectory); - *ppDirectory = zValueUtf8; - return SQLITE_OK; - } - return SQLITE_ERROR; -} - -/* ** The return value of winGetLastErrorMsg ** is zero if the error message fits in the buffer, or non-zero ** otherwise (if the message was truncated). @@ -22368,9 +22330,6 @@ static int winOpen( if( isReadonly ){ pFile->ctrlFlags |= WINFILE_RDONLY; } - if( sqlite3_uri_boolean(zName, "psow", SQLITE_POWERSAFE_OVERWRITE) ){ - pFile->ctrlFlags |= WINFILE_PSOW; - } pFile->lastErrno = NO_ERROR; pFile->zPath = zName; #if SQLITE_MAX_MMAP_SIZE>0 @@ -22590,43 +22549,6 @@ static BOOL winIsDriveLetterAndColon( } /* -** Returns non-zero if the specified path name should be used verbatim. If -** non-zero is returned from this function, the calling function must simply -** use the provided path name verbatim -OR- resolve it into a full path name -** using the GetFullPathName Win32 API function (if available). -*/ -static BOOL winIsVerbatimPathname( - const char *zPathname -){ - /* - ** If the path name starts with a forward slash or a backslash, it is either - ** a legal UNC name, a volume relative path, or an absolute path name in the - ** "Unix" format on Windows. There is no easy way to differentiate between - ** the final two cases; therefore, we return the safer return value of TRUE - ** so that callers of this function will simply use it verbatim. - */ - if ( winIsDirSep(zPathname[0]) ){ - return TRUE; - } - - /* - ** If the path name starts with a letter and a colon it is either a volume - ** relative path or an absolute path. Callers of this function must not - ** attempt to treat it as a relative path name (i.e. they should simply use - ** it verbatim). - */ - if ( winIsDriveLetterAndColon(zPathname) ){ - return TRUE; - } - - /* - ** If we get to this point, the path name should almost certainly be a purely - ** relative one (i.e. not a UNC name, not absolute, and not volume relative). - */ - return FALSE; -} - -/* ** Turn a relative pathname into a full pathname. Write the full ** pathname into zOut[]. zOut[] will be at least pVfs->mxPathname ** bytes in size. diff --git a/src/runtime/dotNet/Bracket.cs b/src/runtime/dotNet/Bracket.cs index 1fc4c0db7..6fd8756f8 100644 --- a/src/runtime/dotNet/Bracket.cs +++ b/src/runtime/dotNet/Bracket.cs @@ -64,17 +64,17 @@ namespace PGFSharp stack.Peek ().AddChild (new StringChildBracket (str)); } - private void BeginPhrase(IntPtr self, IntPtr cat, int fid, int lindex, IntPtr fun) { + private void BeginPhrase(IntPtr self, IntPtr cat, int fid, UIntPtr lindex, IntPtr fun) { stack.Push (new Bracket ()); } - private void EndPhrase(IntPtr self, IntPtr cat, int fid, int lindex, IntPtr fun) { + private void EndPhrase(IntPtr self, IntPtr cat, int fid, UIntPtr lindex, IntPtr fun) { var b = stack.Pop (); b.CatName = Native.NativeString.StringFromNativeUtf8 (cat); b.FunName = Native.NativeString.StringFromNativeUtf8 (fun); b.FId = fid; - b.LIndex = lindex; + b.LIndex = (int) lindex; if (stack.Count == 0) final = b; diff --git a/src/runtime/dotNet/Expr.cs b/src/runtime/dotNet/Expr.cs index dada28fc0..407ea4af3 100644 --- a/src/runtime/dotNet/Expr.cs +++ b/src/runtime/dotNet/Expr.cs @@ -46,7 +46,7 @@ namespace PGFSharp using (var strNative = new Native.NativeString(exprStr)) { var in_ = NativeGU.gu_data_in(strNative.Ptr, strNative.Size, tmp_pool.Ptr); - var expr = Native.pgf_read_expr(in_, result_pool.Ptr, exn.Ptr); + var expr = Native.pgf_read_expr(in_, result_pool.Ptr, tmp_pool.Ptr, exn.Ptr); if (exn.IsRaised || expr == IntPtr.Zero) { throw new PGFError(); diff --git a/src/runtime/dotNet/Native.cs b/src/runtime/dotNet/Native.cs index 5c750e010..0c055ffd8 100644 --- a/src/runtime/dotNet/Native.cs +++ b/src/runtime/dotNet/Native.cs @@ -128,7 +128,7 @@ namespace PGFSharp public static extern IntPtr pgf_function_type(IntPtr pgf, IntPtr funNameStr); [DllImport(LIBNAME, CallingConvention = CC)] - public static extern IntPtr pgf_read_type(IntPtr in_, IntPtr pool, IntPtr err); + public static extern IntPtr pgf_read_type(IntPtr in_, IntPtr pool, IntPtr tmp_pool, IntPtr err); [DllImport(LIBNAME, CallingConvention = CC)] public static extern void pgf_print_type(IntPtr expr, IntPtr ctxt, int prec, IntPtr output, IntPtr err); @@ -139,7 +139,7 @@ namespace PGFSharp public static extern void pgf_print_expr(IntPtr expr, IntPtr ctxt, int prec, IntPtr output, IntPtr err); [DllImport(LIBNAME, CallingConvention = CC)] - public static extern IntPtr pgf_read_expr(IntPtr in_, IntPtr pool, IntPtr err); + public static extern IntPtr pgf_read_expr(IntPtr in_, IntPtr pool, IntPtr tmp_pool, IntPtr err); [DllImport(LIBNAME, CallingConvention = CC)] public static extern IntPtr pgf_compute(IntPtr pgf, IntPtr expr, IntPtr err, IntPtr tmp_pool, IntPtr res_pool); @@ -207,10 +207,10 @@ namespace PGFSharp public delegate void LinFuncSymbolToken(IntPtr self, IntPtr token); [UnmanagedFunctionPointer(CallingConvention.Cdecl)] - public delegate void LinFuncBeginPhrase(IntPtr self, IntPtr cat, int fid, int lindex, IntPtr fun); + public delegate void LinFuncBeginPhrase(IntPtr self, IntPtr cat, int fid, UIntPtr lindex, IntPtr fun); [UnmanagedFunctionPointer(CallingConvention.Cdecl)] - public delegate void LinFuncEndPhrase(IntPtr self, IntPtr cat, int fid, int lindex, IntPtr fun); + public delegate void LinFuncEndPhrase(IntPtr self, IntPtr cat, int fid, UIntPtr lindex, IntPtr fun); [UnmanagedFunctionPointer(CallingConvention.Cdecl)] public delegate void LinFuncSymbolNonexistant(IntPtr self); diff --git a/src/runtime/dotNet/Type.cs b/src/runtime/dotNet/Type.cs index bf31f8117..819af0b7b 100644 --- a/src/runtime/dotNet/Type.cs +++ b/src/runtime/dotNet/Type.cs @@ -43,7 +43,7 @@ namespace PGFSharp using (var strNative = new Native.NativeString(typeStr)) { var in_ = NativeGU.gu_data_in(strNative.Ptr, strNative.Size, tmp_pool.Ptr); - var typ = Native.pgf_read_type(in_, result_pool.Ptr, exn.Ptr); + var typ = Native.pgf_read_type(in_, result_pool.Ptr, tmp_pool.Ptr, exn.Ptr); if (exn.IsRaised || typ == IntPtr.Zero) { throw new PGFError(); diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 037145ee6..895d13ca4 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -19,7 +19,7 @@ #include <gu/exn.h> module PGF2 (-- * PGF - PGF,readPGF, + PGF,readPGF,showPGF, -- * Identifiers CId, @@ -27,11 +27,12 @@ module PGF2 (-- * PGF -- * Abstract syntax AbsName,abstractName, -- ** Categories - Cat,categories,showCategory, + Cat,categories,categoryContext, -- ** Functions - Fun,functions, functionsByCat, functionType, hasLinearization, + Fun, functions, functionsByCat, + functionType, functionIsConstructor, hasLinearization, -- ** Expressions - Expr,showExpr,readExpr, + Expr,showExpr,readExpr,pExpr, mkAbs,unAbs, mkApp,unApp, mkStr,unStr, @@ -39,11 +40,12 @@ module PGF2 (-- * PGF mkFloat,unFloat, mkMeta,unMeta, mkCId, + exprHash, exprSize, exprFunctions, exprSubstitute, treeProbability, -- ** Types Type, Hypo, BindType(..), startCat, - readType, showType, + readType, showType, showContext, mkType, unType, -- ** Type checking @@ -53,14 +55,16 @@ module PGF2 (-- * PGF compute, -- * Concrete syntax - ConcName,Concr,languages,concreteName, + ConcName,Concr,languages,concreteName,languageCode, + -- ** Linearization linearize,linearizeAll,tabularLinearize,tabularLinearizeAll,bracketedLinearize, FId, LIndex, BracketedString(..), showBracketedString, flattenBracketedString, + printName, alignWords, -- ** Parsing - parse, parseWithHeuristics, + ParseOutput(..), parse, parseWithHeuristics, -- ** Sentence Lookup lookupSentence, -- ** Generation @@ -78,7 +82,7 @@ module PGF2 (-- * PGF LiteralCallback,literalCallbacks ) where -import Prelude hiding (fromEnum) +import Prelude hiding (fromEnum,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import Control.Exception(Exception,throwIO) import Control.Monad(forM_) import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO) @@ -134,6 +138,17 @@ readPGF fpath = pgfFPtr <- newForeignPtr gu_pool_finalizer pool return (PGF pgf (touchForeignPtr pgfFPtr)) +showPGF :: PGF -> String +showPGF p = + unsafePerformIO $ + withGuPool $ \tmpPl -> + do (sb,out) <- newOut tmpPl + exn <- gu_new_exn tmpPl + pgf_print (pgf p) out exn + touchPGF p + s <- gu_string_buf_freeze sb tmpPl + peekUtf8CString s + -- | List of all languages available in the grammar. languages :: PGF -> Map.Map ConcName Concr languages p = @@ -158,6 +173,10 @@ languages p = concreteName :: Concr -> ConcName concreteName c = unsafePerformIO (peekUtf8CString =<< pgf_concrete_name (concr c)) +languageCode :: Concr -> String +languageCode c = unsafePerformIO (peekUtf8CString =<< pgf_language_code (concr c)) + + -- | Generates an exhaustive possibly infinite list of -- all abstract syntax expressions of the given type. -- The expressions are ordered by their probability. @@ -222,6 +241,16 @@ functionType p fn = then Nothing else Just (Type c_type (touchPGF p))) +-- | The type of a function +functionIsConstructor :: PGF -> Fun -> Bool +functionIsConstructor p fn = + unsafePerformIO $ + withGuPool $ \tmpPl -> do + c_fn <- newUtf8CString fn tmpPl + res <- pgf_function_is_constructor (pgf p) c_fn + touchPGF p + return (res /= 0) + -- | Checks an expression against a specified type. checkExpr :: PGF -> Expr -> Type -> Either String Expr checkExpr (PGF p _) (Expr c_expr touch1) (Type c_ty touch2) = @@ -323,6 +352,45 @@ treeProbability (PGF p _) (Expr c_expr touch1) = touch1 return (realToFrac res) +exprHash :: Int32 -> Expr -> Int32 +exprHash h (Expr c_expr touch1) = + unsafePerformIO $ do + h <- pgf_expr_hash (fromIntegral h) c_expr + touch1 + return (fromIntegral h) + +exprSize :: Expr -> Int +exprSize (Expr c_expr touch1) = + unsafePerformIO $ do + size <- pgf_expr_size c_expr + touch1 + return (fromIntegral size) + +exprFunctions :: Expr -> [Fun] +exprFunctions (Expr c_expr touch) = + unsafePerformIO $ + withGuPool $ \tmpPl -> do + seq <- pgf_expr_functions c_expr tmpPl + len <- (#peek GuSeq, len) seq + arr <- peekArray (fromIntegral (len :: CInt)) (seq `plusPtr` (#offset GuSeq, data)) + funs <- mapM peekUtf8CString arr + touch + return funs + +exprSubstitute :: Expr -> [Expr] -> Expr +exprSubstitute (Expr c_expr touch) meta_values = + unsafePerformIO $ + withGuPool $ \tmpPl -> do + c_meta_values <- newSequence (#size PgfExpr) pokeExpr meta_values tmpPl + exprPl <- gu_new_pool + c_expr <- pgf_expr_substitute c_expr c_meta_values exprPl + touch + exprFPl <- newForeignPtr gu_pool_finalizer exprPl + let touch' = sequence_ (touchForeignPtr exprFPl : map touchExpr meta_values) + return (Expr c_expr touch') + where + pokeExpr ptr (Expr c_expr _) = poke ptr c_expr + ----------------------------------------------------------------------------- -- Graphviz @@ -448,7 +516,15 @@ getAnalysis ref self c_lemma c_anal prob exn = do anal <- peekUtf8CString c_anal writeIORef ref ((lemma, anal, prob):ans) -parse :: Concr -> Type -> String -> Either String [(Expr,Float)] +-- | This data type encodes the different outcomes which you could get from the parser. +data ParseOutput + = ParseFailed Int String -- ^ The integer is the position in number of unicode characters where the parser failed. + -- The string is the token where the parser have failed. + | ParseOk [(Expr,Float)] -- ^ If the parsing and the type checking are successful we get a list of abstract syntax trees. + -- The list should be non-empty. + | ParseIncomplete -- ^ The sentence is not complete. + +parse :: Concr -> Type -> String -> ParseOutput parse lang ty sent = parseWithHeuristics lang ty sent (-1.0) [] parseWithHeuristics :: Concr -- ^ the language with which we parse @@ -465,8 +541,8 @@ parseWithHeuristics :: Concr -- ^ the language with which we parse -- the input sentence; the current offset in the sentence. -- If a literal has been recognized then the output should -- be Just (expr,probability,end_offset) - -> Either String [(Expr,Float)] -parseWithHeuristics lang (Type ctype _) sent heuristic callbacks = + -> ParseOutput +parseWithHeuristics lang (Type ctype touchType) sent heuristic callbacks = unsafePerformIO $ do exprPl <- gu_new_pool parsePl <- gu_new_pool @@ -474,15 +550,24 @@ parseWithHeuristics lang (Type ctype _) sent heuristic callbacks = sent <- newUtf8CString sent parsePl callbacks_map <- mkCallbacksMap (concr lang) callbacks parsePl enum <- pgf_parse_with_heuristics (concr lang) ctype sent heuristic callbacks_map exn parsePl exprPl + touchType failed <- gu_exn_is_raised exn if failed then do is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError if is_parse_error - then do c_tok <- (#peek GuExn, data.data) exn - tok <- peekUtf8CString c_tok - gu_pool_free parsePl - gu_pool_free exprPl - return (Left tok) + then do c_err <- (#peek GuExn, data.data) exn + c_incomplete <- (#peek PgfParseError, incomplete) c_err + if (c_incomplete :: CInt) == 0 + then do c_offset <- (#peek PgfParseError, offset) c_err + token_ptr <- (#peek PgfParseError, token_ptr) c_err + token_len <- (#peek PgfParseError, token_len) c_err + tok <- peekUtf8CStringLen token_ptr token_len + gu_pool_free parsePl + gu_pool_free exprPl + return (ParseFailed (fromIntegral (c_offset :: CInt)) tok) + else do gu_pool_free parsePl + gu_pool_free exprPl + return ParseIncomplete else do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn if is_exn then do c_msg <- (#peek GuExn, data.data) exn @@ -496,7 +581,7 @@ parseWithHeuristics lang (Type ctype _) sent heuristic callbacks = else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl exprFPl <- newForeignPtr gu_pool_finalizer exprPl exprs <- fromPgfExprEnum enum parseFPl (touchConcr lang >> touchForeignPtr exprFPl) - return (Right exprs) + return (ParseOk exprs) mkCallbacksMap :: Ptr PgfConcr -> [(String, Int -> Int -> Maybe (Expr,Float,Int))] -> Ptr GuPool -> IO (Ptr PgfCallbacksMap) mkCallbacksMap concr callbacks pool = do @@ -524,7 +609,7 @@ mkCallbacksMap concr callbacks pool = do c_str <- gu_string_buf_freeze sb tmpPl guin <- gu_string_in c_str tmpPl - pgf_read_expr guin out_pool exn + pgf_read_expr guin out_pool tmpPl exn ep <- gu_malloc out_pool (#size PgfExprProb) (#poke PgfExprProb, expr) ep c_e @@ -563,7 +648,7 @@ parseWithOracle :: Concr -- ^ the language with which we parse -> Cat -- ^ the start category -> String -- ^ the input sentence -> Oracle - -> Either String [(Expr,Float)] + -> ParseOutput parseWithOracle lang cat sent (predict,complete,literal) = unsafePerformIO $ do parsePl <- gu_new_pool @@ -580,11 +665,19 @@ parseWithOracle lang cat sent (predict,complete,literal) = if failed then do is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError if is_parse_error - then do c_tok <- (#peek GuExn, data.data) exn - tok <- peekUtf8CString c_tok - gu_pool_free parsePl - gu_pool_free exprPl - return (Left tok) + then do c_err <- (#peek GuExn, data.data) exn + c_incomplete <- (#peek PgfParseError, incomplete) c_err + if (c_incomplete :: CInt) == 0 + then do c_offset <- (#peek PgfParseError, offset) c_err + token_ptr <- (#peek PgfParseError, token_ptr) c_err + token_len <- (#peek PgfParseError, token_len) c_err + tok <- peekUtf8CStringLen token_ptr token_len + gu_pool_free parsePl + gu_pool_free exprPl + return (ParseFailed (fromIntegral (c_offset :: CInt)) tok) + else do gu_pool_free parsePl + gu_pool_free exprPl + return ParseIncomplete else do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn if is_exn then do c_msg <- (#peek GuExn, data.data) exn @@ -598,7 +691,7 @@ parseWithOracle lang cat sent (predict,complete,literal) = else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl exprFPl <- newForeignPtr gu_pool_finalizer exprPl exprs <- fromPgfExprEnum enum parseFPl (touchConcr lang >> touchForeignPtr exprFPl) - return (Right exprs) + return (ParseOk exprs) where oracleWrapper oracle catPtr lblPtr offset = do cat <- peekUtf8CString catPtr @@ -623,7 +716,7 @@ parseWithOracle lang cat sent (predict,complete,literal) = c_str <- gu_string_buf_freeze sb tmpPl guin <- gu_string_in c_str tmpPl - pgf_read_expr guin out_pool exn + pgf_read_expr guin out_pool tmpPl exn ep <- gu_malloc out_pool (#size PgfExprProb) (#poke PgfExprProb, expr) ep c_e @@ -881,6 +974,7 @@ alignWords lang e = unsafePerformIO $ withGuPool $ \pl -> do exn <- gu_new_exn pl seq <- pgf_align_words (concr lang) (expr e) exn pl + touchConcr lang touchExpr e failed <- gu_exn_is_raised exn if failed @@ -905,6 +999,18 @@ alignWords lang e = unsafePerformIO $ (fids :: [CInt]) <- peekArray (fromIntegral (n_fids :: CInt)) (ptr `plusPtr` (#offset PgfAlignmentPhrase, fids)) return (phrase, map fromIntegral fids) +printName :: Concr -> Fun -> Maybe String +printName lang fun = + unsafePerformIO $ + withGuPool $ \tmpPl -> do + c_fun <- newUtf8CString fun tmpPl + c_name <- pgf_print_name (concr lang) c_fun + name <- if c_name == nullPtr + then return Nothing + else fmap Just (peekUtf8CString c_name) + touchConcr lang + return name + -- | List of all functions defined in the abstract syntax functions :: PGF -> [Fun] functions p = @@ -974,25 +1080,38 @@ categories p = name <- peekUtf8CString (castPtr key) writeIORef ref $! (name : names) -showCategory :: PGF -> Cat -> String -showCategory p cat = +categoryContext :: PGF -> Cat -> [Hypo] +categoryContext p cat = unsafePerformIO $ withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - exn <- gu_new_exn tmpPl - c_cat <- newUtf8CString cat tmpPl - pgf_print_category (pgf p) c_cat out exn + do c_cat <- newUtf8CString cat tmpPl + c_hypos <- pgf_category_context (pgf p) c_cat + if c_hypos == nullPtr + then return [] + else do n_hypos <- (#peek GuSeq, len) c_hypos + peekHypos (c_hypos `plusPtr` (#offset GuSeq, data)) 0 n_hypos + where + peekHypos :: Ptr a -> Int -> Int -> IO [Hypo] + peekHypos c_hypo i n + | i < n = do cid <- (#peek PgfHypo, cid) c_hypo >>= peekUtf8CString + c_ty <- (#peek PgfHypo, type) c_hypo + bt <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo) + hs <- peekHypos (plusPtr c_hypo (#size PgfHypo)) (i+1) n + return ((bt,cid,Type c_ty (touchPGF p)) : hs) + | otherwise = return [] + + toBindType :: CInt -> BindType + toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit + toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit + +categoryProb :: PGF -> Cat -> Float +categoryProb p cat = + unsafePerformIO $ + withGuPool $ \tmpPl -> + do c_cat <- newUtf8CString cat tmpPl + c_prob <- pgf_category_prob (pgf p) c_cat touchPGF p - failed <- gu_exn_is_raised exn - if failed - then do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn - if is_exn - then do c_msg <- (#peek GuExn, data.data) exn - msg <- peekUtf8CString c_msg - throwIO (PGFError msg) - else throwIO (PGFError "The abstract tree cannot be linearized") - else do s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s + return (realToFrac c_prob) ----------------------------------------------------------------------------- -- Helper functions diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc index a03a24be3..096d15bfa 100644 --- a/src/runtime/haskell-bind/PGF2/Expr.hsc +++ b/src/runtime/haskell-bind/PGF2/Expr.hsc @@ -5,6 +5,7 @@ module PGF2.Expr where import System.IO.Unsafe(unsafePerformIO) import Foreign hiding (unsafePerformIO) import Foreign.C +import Data.IORef import PGF2.FFI -- | An data type that represents @@ -51,7 +52,7 @@ mkAbs bind_type var (Expr body bodyTouch) = exprFPl <- newForeignPtr gu_pool_finalizer exprPl return (Expr c_expr (bodyTouch >> touchForeignPtr exprFPl)) where - cbind_type = + cbind_type = case bind_type of Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) @@ -195,7 +196,7 @@ readExpr str = do c_str <- newUtf8CString str tmpPl guin <- gu_string_in c_str tmpPl exn <- gu_new_exn tmpPl - c_expr <- pgf_read_expr guin exprPl exn + c_expr <- pgf_read_expr guin exprPl tmpPl exn status <- gu_exn_is_raised exn if (not status && c_expr /= nullPtr) then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl @@ -203,6 +204,48 @@ readExpr str = else do gu_pool_free exprPl return Nothing +pExpr :: ReadS Expr +pExpr str = + unsafePerformIO $ + do exprPl <- gu_new_pool + withGuPool $ \tmpPl -> + do ref <- newIORef (str,str,str) + exn <- gu_new_exn tmpPl + c_fetch_char <- wrapParserGetc (fetch_char ref) + c_parser <- pgf_new_parser nullPtr c_fetch_char exprPl tmpPl exn + c_expr <- pgf_expr_parser_expr c_parser 1 + status <- gu_exn_is_raised exn + if (not status && c_expr /= nullPtr) + then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl + (str,_,_) <- readIORef ref + return [(Expr c_expr (touchForeignPtr exprFPl),str)] + else do gu_pool_free exprPl + return [] + where + fetch_char :: IORef (String,String,String) -> Ptr () -> (#type bool) -> Ptr GuExn -> IO (#type GuUCS) + fetch_char ref _ mark exn = do + (str1,str2,str3) <- readIORef ref + let str1' = if mark /= 0 + then str2 + else str1 + case str3 of + [] -> do writeIORef ref (str1',str3,[]) + gu_exn_raise exn gu_exn_type_GuEOF + return (-1) + (c:cs) -> do writeIORef ref (str1',str3,cs) + return ((fromIntegral . fromEnum) c) + +foreign import ccall "pgf/expr.h pgf_new_parser" + pgf_new_parser :: Ptr () -> (FunPtr ParserGetc) -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfExprParser) + +foreign import ccall "pgf/expr.h pgf_expr_parser_expr" + pgf_expr_parser_expr :: Ptr PgfExprParser -> (#type bool) -> IO PgfExpr + +type ParserGetc = Ptr () -> (#type bool) -> Ptr GuExn -> IO (#type GuUCS) + +foreign import ccall "wrapper" + wrapParserGetc :: ParserGetc -> IO (FunPtr ParserGetc) + -- | renders an expression as a 'String'. The list -- of identifiers is the list of all free variables -- in the expression in order reverse to the order diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hsc index 3870e2fba..c33f1da50 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hsc @@ -1,14 +1,20 @@ -{-# LANGUAGE ForeignFunctionInterface, MagicHash #-} +{-# LANGUAGE ForeignFunctionInterface, MagicHash, BangPatterns #-} module PGF2.FFI where -import Foreign ( alloca, poke ) +#include <gu/defs.h> +#include <gu/hash.h> +#include <gu/utf8.h> +#include <pgf/pgf.h> + +import Foreign ( alloca, peek, poke, peekByteOff ) import Foreign.C import Foreign.Ptr import Foreign.ForeignPtr import Control.Exception import GHC.Ptr -import Data.Int(Int32) +import Data.Int +import Data.Word type Touch = IO () @@ -23,77 +29,128 @@ data Concr = Concr {concr :: Ptr PgfConcr, touchConcr :: Touch} data GuEnum data GuExn data GuIn +data GuOut data GuKind data GuType data GuString data GuStringBuf +data GuMap data GuMapItor -data GuOut +data GuHasher data GuSeq +data GuBuf data GuPool +type GuVariant = Ptr () +type GuHash = (#type GuHash) +type GuUCS = (#type GuUCS) -foreign import ccall fopen :: CString -> CString -> IO (Ptr ()) +type CSizeT = (#type size_t) +type CUInt8 = (#type uint8_t) -foreign import ccall "gu/mem.h gu_new_pool" +foreign import ccall unsafe fopen :: CString -> CString -> IO (Ptr ()) + +foreign import ccall unsafe "gu/mem.h gu_new_pool" gu_new_pool :: IO (Ptr GuPool) -foreign import ccall "gu/mem.h gu_malloc" - gu_malloc :: Ptr GuPool -> CInt -> IO (Ptr a) +foreign import ccall unsafe "gu/mem.h gu_malloc" + gu_malloc :: Ptr GuPool -> CSizeT -> IO (Ptr a) + +foreign import ccall unsafe "gu/mem.h gu_malloc_aligned" + gu_malloc_aligned :: Ptr GuPool -> CSizeT -> CSizeT -> IO (Ptr a) -foreign import ccall "gu/mem.h gu_pool_free" +foreign import ccall unsafe "gu/mem.h gu_pool_free" gu_pool_free :: Ptr GuPool -> IO () -foreign import ccall "gu/mem.h &gu_pool_free" +foreign import ccall unsafe "gu/mem.h &gu_pool_free" gu_pool_finalizer :: FinalizerPtr GuPool -foreign import ccall "gu/exn.h gu_new_exn" +foreign import ccall unsafe "gu/exn.h gu_new_exn" gu_new_exn :: Ptr GuPool -> IO (Ptr GuExn) -foreign import ccall "gu/exn.h gu_exn_is_raised" +foreign import ccall unsafe "gu/exn.h gu_exn_is_raised" gu_exn_is_raised :: Ptr GuExn -> IO Bool -foreign import ccall "gu/exn.h gu_exn_caught_" +foreign import ccall unsafe "gu/exn.h gu_exn_caught_" gu_exn_caught :: Ptr GuExn -> CString -> IO Bool -foreign import ccall "gu/exn.h gu_exn_raise_" +foreign import ccall unsafe "gu/exn.h gu_exn_raise_" gu_exn_raise :: Ptr GuExn -> CString -> IO (Ptr ()) -gu_exn_type_GuErrno = Ptr "GuErrno"# :: CString +gu_exn_type_GuErrno = Ptr "GuErrno"## :: CString + +gu_exn_type_GuEOF = Ptr "GuEOF"## :: CString -gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"# :: CString +gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"## :: CString -gu_exn_type_PgfExn = Ptr "PgfExn"# :: CString +gu_exn_type_PgfExn = Ptr "PgfExn"## :: CString -gu_exn_type_PgfParseError = Ptr "PgfParseError"# :: CString +gu_exn_type_PgfParseError = Ptr "PgfParseError"## :: CString -gu_exn_type_PgfTypeError = Ptr "PgfTypeError"# :: CString +gu_exn_type_PgfTypeError = Ptr "PgfTypeError"## :: CString -foreign import ccall "gu/string.h gu_string_in" +foreign import ccall unsafe "gu/string.h gu_string_in" gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn) -foreign import ccall "gu/string.h gu_new_string_buf" +foreign import ccall unsafe "gu/string.h gu_new_string_buf" gu_new_string_buf :: Ptr GuPool -> IO (Ptr GuStringBuf) -foreign import ccall "gu/string.h gu_string_buf_out" +foreign import ccall unsafe "gu/string.h gu_string_buf_out" gu_string_buf_out :: Ptr GuStringBuf -> IO (Ptr GuOut) -foreign import ccall "gu/file.h gu_file_in" +foreign import ccall unsafe "gu/file.h gu_file_in" gu_file_in :: Ptr () -> Ptr GuPool -> IO (Ptr GuIn) -foreign import ccall "gu/enum.h gu_enum_next" +foreign import ccall unsafe "gu/enum.h gu_enum_next" gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO () -foreign import ccall "gu/string.h gu_string_buf_freeze" +foreign import ccall unsafe "gu/string.h gu_string_buf_freeze" gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString foreign import ccall unsafe "gu/utf8.h gu_utf8_decode" - gu_utf8_decode :: Ptr CString -> IO Int32 + gu_utf8_decode :: Ptr CString -> IO GuUCS foreign import ccall unsafe "gu/utf8.h gu_utf8_encode" - gu_utf8_encode :: Int32 -> Ptr CString -> IO () + gu_utf8_encode :: GuUCS -> Ptr CString -> IO () foreign import ccall unsafe "gu/seq.h gu_make_seq" - gu_make_seq :: CInt -> CInt -> Ptr GuPool -> IO (Ptr GuSeq) + gu_make_seq :: CSizeT -> CSizeT -> Ptr GuPool -> IO (Ptr GuSeq) + +foreign import ccall unsafe "gu/seq.h gu_make_buf" + gu_make_buf :: CSizeT -> Ptr GuPool -> IO (Ptr GuBuf) + +foreign import ccall unsafe "gu/map.h gu_make_map" + gu_make_map :: CSizeT -> Ptr GuHasher -> CSizeT -> Ptr a -> CSizeT -> Ptr GuPool -> IO (Ptr GuMap) + +foreign import ccall unsafe "gu/map.h gu_map_insert" + gu_map_insert :: Ptr GuMap -> Ptr a -> IO (Ptr b) + +foreign import ccall unsafe "gu/map.h gu_map_find_default" + gu_map_find_default :: Ptr GuMap -> Ptr a -> IO (Ptr b) + +foreign import ccall "gu/map.h gu_map_iter" + gu_map_iter :: Ptr GuMap -> Ptr GuMapItor -> Ptr GuExn -> IO () + +foreign import ccall unsafe "gu/hash.h &gu_int_hasher" + gu_int_hasher :: Ptr GuHasher + +foreign import ccall unsafe "gu/hash.h &gu_addr_hasher" + gu_addr_hasher :: Ptr GuHasher + +foreign import ccall unsafe "gu/hash.h &gu_string_hasher" + gu_string_hasher :: Ptr GuHasher + +foreign import ccall unsafe "gu/hash.h &gu_null_struct" + gu_null_struct :: Ptr a + +foreign import ccall unsafe "gu/variant.h gu_variant_tag" + gu_variant_tag :: GuVariant -> IO CInt + +foreign import ccall unsafe "gu/variant.h gu_variant_data" + gu_variant_data :: GuVariant -> IO (Ptr a) + +foreign import ccall unsafe "gu/variant.h gu_alloc_variant" + gu_alloc_variant :: CUInt8 -> CSizeT -> CSizeT -> Ptr GuVariant -> Ptr GuPool -> IO (Ptr a) + withGuPool :: (Ptr GuPool -> IO a) -> IO a withGuPool f = bracket gu_new_pool gu_pool_free f @@ -116,15 +173,23 @@ peekUtf8CString ptr = else do cs <- decode pptr return (((toEnum . fromEnum) x) : cs) -newUtf8CString :: String -> Ptr GuPool -> IO CString -newUtf8CString s pool = do - -- An UTF8 character takes up to 6 bytes. We allocate enough - -- memory for the worst case. This is wasteful but those - -- strings are usually allocated only temporary. - ptr <- gu_malloc pool (fromIntegral (length s * 6+1)) +peekUtf8CStringLen :: CString -> CInt -> IO String +peekUtf8CStringLen ptr len = + alloca $ \pptr -> + poke pptr ptr >> decode pptr (ptr `plusPtr` fromIntegral len) + where + decode pptr end = do + ptr <- peek pptr + if ptr >= end + then return [] + else do x <- gu_utf8_decode pptr + cs <- decode pptr end + return (((toEnum . fromEnum) x) : cs) + +pokeUtf8CString :: String -> CString -> IO () +pokeUtf8CString s ptr = alloca $ \pptr -> poke pptr ptr >> encode s pptr - return ptr where encode [] pptr = do gu_utf8_encode 0 pptr @@ -132,6 +197,46 @@ newUtf8CString s pool = do gu_utf8_encode ((toEnum . fromEnum) c) pptr encode cs pptr +newUtf8CString :: String -> Ptr GuPool -> IO CString +newUtf8CString s pool = do + ptr <- gu_malloc pool (fromIntegral (utf8Length s)) + pokeUtf8CString s ptr + return ptr + +utf8Length s = count 0 s + where + count !c [] = c+1 + count !c (x:xs) + | ucs < 0x80 = count (c+1) xs + | ucs < 0x800 = count (c+2) xs + | ucs < 0x10000 = count (c+3) xs + | ucs < 0x200000 = count (c+4) xs + | ucs < 0x4000000 = count (c+5) xs + | otherwise = count (c+6) xs + where + ucs = fromEnum x + +peekSequence peekElem size ptr = do + c_len <- (#peek GuSeq, len) ptr + peekElems (c_len :: CSizeT) (ptr `plusPtr` (#offset GuSeq, data)) + where + peekElems 0 ptr = return [] + peekElems len ptr = do + e <- peekElem ptr + es <- peekElems (len-1) (ptr `plusPtr` size) + return (e:es) + +newSequence :: CSizeT -> (Ptr a -> v -> IO ()) -> [v] -> Ptr GuPool -> IO (Ptr GuSeq) +newSequence elem_size pokeElem values pool = do + c_seq <- gu_make_seq elem_size (fromIntegral (length values)) pool + pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) values + return c_seq + where + pokeElems ptr [] = return () + pokeElems ptr (x:xs) = do + pokeElem ptr x + pokeElems (ptr `plusPtr` (fromIntegral elem_size)) xs + ------------------------------------------------------------------ -- libpgf API @@ -140,6 +245,7 @@ data PgfApplication data PgfConcr type PgfExpr = Ptr () data PgfExprProb +data PgfExprParser data PgfFullFormEntry data PgfMorphoCallback data PgfPrintContext @@ -149,10 +255,19 @@ data PgfOracleCallback data PgfCncTree data PgfLinFuncs data PgfGraphvizOptions +type PgfBindType = (#type PgfBindType) +data PgfAbsFun +data PgfAbsCat +data PgfCCat +data PgfCncFun +data PgfProductionApply foreign import ccall "pgf/pgf.h pgf_read" pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF) +foreign import ccall "pgf/pgf.h pgf_write" + pgf_write :: Ptr PgfPGF -> CString -> Ptr GuExn -> IO () + foreign import ccall "pgf/pgf.h pgf_abstract_name" pgf_abstract_name :: Ptr PgfPGF -> IO CString @@ -180,6 +295,12 @@ foreign import ccall "pgf/pgf.h pgf_iter_categories" foreign import ccall "pgf/pgf.h pgf_start_cat" pgf_start_cat :: Ptr PgfPGF -> Ptr GuPool -> IO PgfType +foreign import ccall "pgf/pgf.h pgf_category_context" + pgf_category_context :: Ptr PgfPGF -> CString -> IO (Ptr GuSeq) + +foreign import ccall "pgf/pgf.h pgf_category_prob" + pgf_category_prob :: Ptr PgfPGF -> CString -> IO (#type prob_t) + foreign import ccall "pgf/pgf.h pgf_iter_functions" pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO () @@ -189,6 +310,9 @@ foreign import ccall "pgf/pgf.h pgf_iter_functions_by_cat" foreign import ccall "pgf/pgf.h pgf_function_type" pgf_function_type :: Ptr PgfPGF -> CString -> IO PgfType +foreign import ccall "pgf/expr.h pgf_function_is_constructor" + pgf_function_is_constructor :: Ptr PgfPGF -> CString -> IO (#type bool) + foreign import ccall "pgf/pgf.h pgf_print_name" pgf_print_name :: Ptr PgfConcr -> CString -> IO CString @@ -205,16 +329,16 @@ foreign import ccall "pgf/pgf.h pgf_lzr_wrap_linref" pgf_lzr_wrap_linref :: Ptr PgfCncTree -> Ptr GuPool -> IO (Ptr PgfCncTree) foreign import ccall "pgf/pgf.h pgf_lzr_linearize_simple" - pgf_lzr_linearize_simple :: Ptr PgfConcr -> Ptr PgfCncTree -> CInt -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO () + pgf_lzr_linearize_simple :: Ptr PgfConcr -> Ptr PgfCncTree -> CSizeT -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO () foreign import ccall "pgf/pgf.h pgf_lzr_linearize" - pgf_lzr_linearize :: Ptr PgfConcr -> Ptr PgfCncTree -> CInt -> Ptr (Ptr PgfLinFuncs) -> Ptr GuPool -> IO () + pgf_lzr_linearize :: Ptr PgfConcr -> Ptr PgfCncTree -> CSizeT -> Ptr (Ptr PgfLinFuncs) -> Ptr GuPool -> IO () foreign import ccall "pgf/pgf.h pgf_lzr_get_table" - pgf_lzr_get_table :: Ptr PgfConcr -> Ptr PgfCncTree -> Ptr CInt -> Ptr (Ptr CString) -> IO () + pgf_lzr_get_table :: Ptr PgfConcr -> Ptr PgfCncTree -> Ptr CSizeT -> Ptr (Ptr CString) -> IO () type SymbolTokenCallback = Ptr (Ptr PgfLinFuncs) -> CString -> IO () -type PhraseCallback = Ptr (Ptr PgfLinFuncs) -> CString -> CInt -> CInt -> CString -> IO () +type PhraseCallback = Ptr (Ptr PgfLinFuncs) -> CString -> CInt -> CSizeT -> CString -> IO () type NonExistCallback = Ptr (Ptr PgfLinFuncs) -> IO () type MetaCallback = Ptr (Ptr PgfLinFuncs) -> CInt -> IO () @@ -239,12 +363,12 @@ foreign import ccall "pgf/pgf.h pgf_parse_with_heuristics" foreign import ccall "pgf/pgf.h pgf_lookup_sentence" pgf_lookup_sentence :: Ptr PgfConcr -> PgfType -> CString -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum) -type LiteralMatchCallback = CInt -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb) +type LiteralMatchCallback = CSizeT -> Ptr CSizeT -> Ptr GuPool -> IO (Ptr PgfExprProb) foreign import ccall "wrapper" wrapLiteralMatchCallback :: LiteralMatchCallback -> IO (FunPtr LiteralMatchCallback) -type LiteralPredictCallback = CInt -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb) +type LiteralPredictCallback = CSizeT -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb) foreign import ccall "wrapper" wrapLiteralPredictCallback :: LiteralPredictCallback -> IO (FunPtr LiteralPredictCallback) @@ -255,8 +379,8 @@ foreign import ccall "pgf/pgf.h pgf_new_callbacks_map" foreign import ccall hspgf_callbacks_map_add_literal :: Ptr PgfConcr -> Ptr PgfCallbacksMap -> CString -> FunPtr LiteralMatchCallback -> FunPtr LiteralPredictCallback -> Ptr GuPool -> IO () -type OracleCallback = CString -> CString -> CInt -> IO Bool -type OracleLiteralCallback = CString -> CString -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb) +type OracleCallback = CString -> CString -> CSizeT -> IO Bool +type OracleLiteralCallback = CString -> CString -> Ptr CSizeT -> Ptr GuPool -> IO (Ptr PgfExprProb) foreign import ccall "wrapper" wrapOracleCallback :: OracleCallback -> IO (FunPtr OracleCallback) @@ -299,7 +423,7 @@ foreign import ccall "pgf/pgf.h pgf_expr_unapply" pgf_expr_unapply :: PgfExpr -> Ptr GuPool -> IO (Ptr PgfApplication) foreign import ccall "pgf/pgf.h pgf_expr_abs" - pgf_expr_abs :: CInt -> CString -> PgfExpr -> Ptr GuPool -> IO PgfExpr + pgf_expr_abs :: PgfBindType -> CString -> PgfExpr -> Ptr GuPool -> IO PgfExpr foreign import ccall "pgf/pgf.h pgf_expr_unabs" pgf_expr_unabs :: PgfExpr -> IO (Ptr a) @@ -328,6 +452,18 @@ foreign import ccall "pgf/expr.h pgf_expr_arity" foreign import ccall "pgf/expr.h pgf_expr_eq" pgf_expr_eq :: PgfExpr -> PgfExpr -> IO CInt +foreign import ccall "pgf/expr.h pgf_expr_hash" + pgf_expr_hash :: GuHash -> PgfExpr -> IO GuHash + +foreign import ccall "pgf/expr.h pgf_expr_size" + pgf_expr_size :: PgfExpr -> IO CInt + +foreign import ccall "pgf/expr.h pgf_expr_functions" + pgf_expr_functions :: PgfExpr -> Ptr GuPool -> IO (Ptr GuSeq) + +foreign import ccall "pgf/expr.h pgf_expr_substitute" + pgf_expr_substitute :: PgfExpr -> Ptr GuSeq -> Ptr GuPool -> IO PgfExpr + foreign import ccall "pgf/expr.h pgf_compute_tree_probability" pgf_compute_tree_probability :: Ptr PgfPGF -> PgfExpr -> IO CFloat @@ -347,14 +483,14 @@ foreign import ccall "pgf/expr.h pgf_print_expr" pgf_print_expr :: PgfExpr -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO () foreign import ccall "pgf/expr.h pgf_print_expr_tuple" - pgf_print_expr_tuple :: CInt -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO () - -foreign import ccall "pgf/expr.h pgf_print_category" - pgf_print_category :: Ptr PgfPGF -> CString -> Ptr GuOut -> Ptr GuExn -> IO () + pgf_print_expr_tuple :: CSizeT -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO () foreign import ccall "pgf/expr.h pgf_print_type" pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO () +foreign import ccall "pgf/expr.h pgf_print_context" + pgf_print_context :: Ptr GuSeq -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO () + foreign import ccall "pgf/pgf.h pgf_generate_all" pgf_generate_all :: Ptr PgfPGF -> PgfType -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum) @@ -362,16 +498,16 @@ foreign import ccall "pgf/pgf.h pgf_print" pgf_print :: Ptr PgfPGF -> Ptr GuOut -> Ptr GuExn -> IO () foreign import ccall "pgf/expr.h pgf_read_expr" - pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr + pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr foreign import ccall "pgf/expr.h pgf_read_expr_tuple" - pgf_read_expr_tuple :: Ptr GuIn -> CInt -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt + pgf_read_expr_tuple :: Ptr GuIn -> CSizeT -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt foreign import ccall "pgf/expr.h pgf_read_expr_matrix" - pgf_read_expr_matrix :: Ptr GuIn -> CInt -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq) + pgf_read_expr_matrix :: Ptr GuIn -> CSizeT -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq) foreign import ccall "pgf/expr.h pgf_read_type" - pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfType + pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfType foreign import ccall "pgf/graphviz.h pgf_graphviz_abstract_tree" pgf_graphviz_abstract_tree :: Ptr PgfPGF -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO () @@ -380,4 +516,13 @@ foreign import ccall "pgf/graphviz.h pgf_graphviz_parse_tree" pgf_graphviz_parse_tree :: Ptr PgfConcr -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO () foreign import ccall "pgf/graphviz.h pgf_graphviz_word_alignment" - pgf_graphviz_word_alignment :: Ptr (Ptr PgfConcr) -> CInt -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO () + pgf_graphviz_word_alignment :: Ptr (Ptr PgfConcr) -> CSizeT -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO () + +foreign import ccall "pgf/data.h pgf_parser_index" + pgf_parser_index :: Ptr PgfConcr -> Ptr PgfCCat -> GuVariant -> (#type bool) -> Ptr GuPool -> IO () + +foreign import ccall "pgf/data.h pgf_lzr_index" + pgf_lzr_index :: Ptr PgfConcr -> Ptr PgfCCat -> GuVariant -> (#type bool) -> Ptr GuPool -> IO () + +foreign import ccall "pgf/data.h pgf_production_is_lexical" + pgf_production_is_lexical :: Ptr PgfProductionApply -> Ptr GuBuf -> Ptr GuPool -> IO (#type bool) diff --git a/src/runtime/haskell-bind/PGF2/Internal.hsc b/src/runtime/haskell-bind/PGF2/Internal.hsc new file mode 100644 index 000000000..c4aef323a --- /dev/null +++ b/src/runtime/haskell-bind/PGF2/Internal.hsc @@ -0,0 +1,932 @@ +{-# LANGUAGE ImplicitParams, RankNTypes #-} + +module PGF2.Internal(-- * Access the internal structures + FId,isPredefFId, + FunId,Token,Production(..),PArg(..),Symbol(..),Literal(..), + globalFlags, abstrFlags, concrFlags, + concrTotalCats, concrCategories, concrProductions, + concrTotalFuns, concrFunction, + concrTotalSeqs, concrSequence, + + -- * Building new PGFs in memory + build, eAbs, eApp, eMeta, eFun, eVar, eTyped, eImplArg, dTyp, hypo, + AbstrInfo, newAbstr, ConcrInfo, newConcr, newPGF, + + -- * Write an in-memory PGF to a file + writePGF + ) where + +#include <pgf/data.h> + +import PGF2 +import PGF2.FFI +import PGF2.Expr +import PGF2.Type +import System.IO.Unsafe(unsafePerformIO) +import Foreign +import Foreign.C +import Data.IORef +import Data.Maybe(fromMaybe) +import Data.List(sortBy) +import Control.Exception(Exception,throwIO) +import Control.Monad(foldM) +import qualified Data.Map as Map + +type Token = String +data Symbol + = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex + | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex + | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SymKS Token + | SymKP [Symbol] [([Symbol],[String])] + | SymBIND -- the special BIND token + | SymNE -- non exist + | SymSOFT_BIND -- the special SOFT_BIND token + | SymSOFT_SPACE -- the special SOFT_SPACE token + | SymCAPIT -- the special CAPIT token + | SymALL_CAPIT -- the special ALL_CAPIT token + deriving (Eq,Ord,Show) +data Production + = PApply {-# UNPACK #-} !FunId [PArg] + | PCoerce {-# UNPACK #-} !FId + deriving (Eq,Ord,Show) +data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show) +type FunId = Int +type SeqId = Int +data Literal = + LStr String -- ^ a string constant + | LInt Int -- ^ an integer constant + | LFlt Double -- ^ a floating point constant + deriving (Eq,Ord,Show) + + +----------------------------------------------------------------------- +-- Access the internal structures +----------------------------------------------------------------------- + +globalFlags :: PGF -> [(String,Literal)] +globalFlags p = unsafePerformIO $ do + c_flags <- (#peek PgfPGF, gflags) (pgf p) + flags <- peekFlags c_flags + touchPGF p + return flags + +abstrFlags :: PGF -> [(String,Literal)] +abstrFlags p = unsafePerformIO $ do + c_flags <- (#peek PgfPGF, abstract.aflags) (pgf p) + flags <- peekFlags c_flags + touchPGF p + return flags + +concrFlags :: Concr -> [(String,Literal)] +concrFlags c = unsafePerformIO $ do + c_flags <- (#peek PgfConcr, cflags) (concr c) + flags <- peekFlags c_flags + touchConcr c + return flags + +peekFlags :: Ptr GuSeq -> IO [(String,Literal)] +peekFlags c_flags = do + c_len <- (#peek GuSeq, len) c_flags + peekFlags (c_len :: CInt) (c_flags `plusPtr` (#offset GuSeq, data)) + where + peekFlags 0 ptr = return [] + peekFlags c_len ptr = do + name <- (#peek PgfFlag, name) ptr >>= peekUtf8CString + value <- (#peek PgfFlag, value) ptr >>= peekLiteral + flags <- peekFlags (c_len-1) (ptr `plusPtr` (#size PgfFlag)) + return ((name,value):flags) + +peekLiteral :: GuVariant -> IO Literal +peekLiteral p = do + tag <- gu_variant_tag p + ptr <- gu_variant_data p + case tag of + (#const PGF_LITERAL_STR) -> do { val <- peekUtf8CString (ptr `plusPtr` (#offset PgfLiteralStr, val)); + return (LStr val) } + (#const PGF_LITERAL_INT) -> do { val <- peek (ptr `plusPtr` (#offset PgfLiteralInt, val)); + return (LInt (fromIntegral (val :: CInt))) } + (#const PGF_LITERAL_FLT) -> do { val <- peek (ptr `plusPtr` (#offset PgfLiteralFlt, val)); + return (LFlt (realToFrac (val :: CDouble))) } + _ -> error "Unknown literal type in the grammar" + +concrTotalCats :: Concr -> FId +concrTotalCats c = unsafePerformIO $ do + c_total_cats <- (#peek PgfConcr, total_cats) (concr c) + touchConcr c + return (fromIntegral (c_total_cats :: CInt)) + +concrCategories :: Concr -> [(Cat,FId,FId,[String])] +concrCategories c = + unsafePerformIO $ + withGuPool $ \tmpPl -> + allocaBytes (#size GuMapItor) $ \itor -> do + exn <- gu_new_exn tmpPl + ref <- newIORef [] + fptr <- wrapMapItorCallback (getCategories ref) + (#poke GuMapItor, fn) itor fptr + c_cnccats <- (#peek PgfConcr, cnccats) (concr c) + gu_map_iter c_cnccats itor exn + touchConcr c + freeHaskellFunPtr fptr + cs <- readIORef ref + return (reverse cs) + where + getCategories ref itor key value exn = do + names <- readIORef ref + name <- peekUtf8CString (castPtr key) + c_cnccat <- peek (castPtr value) + c_cats <- (#peek PgfCncCat, cats) c_cnccat + c_len <- (#peek GuSeq, len) c_cats + first <- peek (c_cats `plusPtr` (#offset GuSeq, data)) >>= peekFId + last <- peek (c_cats `plusPtr` ((#offset GuSeq, data) + (fromIntegral (c_len-1::CSizeT))*(#size PgfCCat*))) >>= peekFId + c_n_lins <- (#peek PgfCncCat, n_lins) c_cnccat + arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cnccat `plusPtr` (#offset PgfCncCat, labels)) + labels <- mapM peekUtf8CString arr + writeIORef ref ((name,first,last,labels) : names) + +concrProductions :: Concr -> FId -> [Production] +concrProductions c fid = unsafePerformIO $ do + c_ccats <- (#peek PgfConcr, ccats) (concr c) + res <- alloca $ \pfid -> do + poke pfid (fromIntegral fid :: CInt) + gu_map_find_default c_ccats pfid >>= peek + if res == nullPtr + then do touchConcr c + return [] + else do c_prods <- (#peek PgfCCat, prods) res + if c_prods == nullPtr + then do touchConcr c + return [] + else do res <- peekSequence (deRef peekProduction) (#size GuVariant) c_prods + touchConcr c + return res + where + peekProduction p = do + tag <- gu_variant_tag p + dt <- gu_variant_data p + case tag of + (#const PGF_PRODUCTION_APPLY) -> do { c_cncfun <- (#peek PgfProductionApply, fun) dt ; + c_funid <- (#peek PgfCncFun, funid) c_cncfun ; + c_args <- (#peek PgfProductionApply, args) dt ; + pargs <- peekSequence peekPArg (#size PgfPArg) c_args ; + return (PApply (fromIntegral (c_funid :: CInt)) pargs) } + (#const PGF_PRODUCTION_COERCE)-> do { c_coerce <- (#peek PgfProductionCoerce, coerce) dt ; + fid <- peekFId c_coerce ; + return (PCoerce fid) } + _ -> error "Unknown production type in the grammar" + where + peekPArg ptr = do + c_hypos <- (#peek PgfPArg, hypos) ptr + hypos <- peekSequence (deRef peekFId) (#size int) c_hypos + c_ccat <- (#peek PgfPArg, ccat) ptr + fid <- peekFId c_ccat + return (PArg hypos fid) + +peekFId c_ccat = do + c_fid <- (#peek PgfCCat, fid) c_ccat + return (fromIntegral (c_fid :: CInt)) + +concrTotalFuns :: Concr -> FunId +concrTotalFuns c = unsafePerformIO $ do + c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c) + c_len <- (#peek GuSeq, len) c_cncfuns + touchConcr c + return (fromIntegral (c_len :: CSizeT)) + +concrFunction :: Concr -> FunId -> (Fun,[SeqId]) +concrFunction c funid = unsafePerformIO $ do + c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c) + c_cncfun <- peek (c_cncfuns `plusPtr` ((#offset GuSeq, data)+funid*(#size PgfCncFun*))) + c_absfun <- (#peek PgfCncFun, absfun) c_cncfun + c_name <- (#peek PgfAbsFun, name) c_absfun + name <- peekUtf8CString c_name + c_n_lins <- (#peek PgfCncFun, n_lins) c_cncfun + arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cncfun `plusPtr` (#offset PgfCncFun, lins)) + seqs_seq <- (#peek PgfConcr, sequences) (concr c) + touchConcr c + let seqs = seqs_seq `plusPtr` (#offset GuSeq, data) + return (name, map (toSeqId seqs) arr) + where + toSeqId seqs seq = minusPtr seq seqs `div` (#size PgfSequence) + +concrTotalSeqs :: Concr -> SeqId +concrTotalSeqs c = unsafePerformIO $ do + seq <- (#peek PgfConcr, sequences) (concr c) + c_len <- (#peek GuSeq, len) seq + touchConcr c + return (fromIntegral (c_len :: CSizeT)) + +concrSequence :: Concr -> SeqId -> [Symbol] +concrSequence c seqid = unsafePerformIO $ do + c_sequences <- (#peek PgfConcr, sequences) (concr c) + let c_sequence = c_sequences `plusPtr` ((#offset GuSeq, data)+seqid*(#size PgfSequence)) + c_syms <- (#peek PgfSequence, syms) c_sequence + res <- peekSequence (deRef peekSymbol) (#size GuVariant) c_syms + touchConcr c + return res + where + peekSymbol p = do + tag <- gu_variant_tag p + dt <- gu_variant_data p + case tag of + (#const PGF_SYMBOL_CAT) -> peekSymbolIdx SymCat dt + (#const PGF_SYMBOL_LIT) -> peekSymbolIdx SymLit dt + (#const PGF_SYMBOL_VAR) -> peekSymbolIdx SymVar dt + (#const PGF_SYMBOL_KS) -> peekSymbolKS dt + (#const PGF_SYMBOL_KP) -> peekSymbolKP dt + (#const PGF_SYMBOL_BIND) -> return SymBIND + (#const PGF_SYMBOL_SOFT_BIND) -> return SymSOFT_BIND + (#const PGF_SYMBOL_NE) -> return SymNE + (#const PGF_SYMBOL_SOFT_SPACE) -> return SymSOFT_SPACE + (#const PGF_SYMBOL_CAPIT) -> return SymCAPIT + (#const PGF_SYMBOL_ALL_CAPIT) -> return SymALL_CAPIT + _ -> error "Unknown symbol type in the grammar" + + peekSymbolIdx constr dt = do + c_d <- (#peek PgfSymbolIdx, d) dt + c_r <- (#peek PgfSymbolIdx, r) dt + return (constr (fromIntegral (c_d :: CInt)) (fromIntegral (c_r :: CInt))) + + peekSymbolKS dt = do + token <- peekUtf8CString (dt `plusPtr` (#offset PgfSymbolKS, token)) + return (SymKS token) + + peekSymbolKP dt = do + c_default_form <- (#peek PgfSymbolKP, default_form) dt + default_form <- peekSequence (deRef peekSymbol) (#size GuVariant) c_default_form + c_n_forms <- (#peek PgfSymbolKP, n_forms) dt + forms <- peekForms (c_n_forms :: CSizeT) (dt `plusPtr` (#offset PgfSymbolKP, forms)) + return (SymKP default_form forms) + + peekForms 0 ptr = return [] + peekForms len ptr = do + c_form <- (#peek PgfAlternative, form) ptr + form <- peekSequence (deRef peekSymbol) (#size GuVariant) c_form + c_prefixes <- (#peek PgfAlternative, prefixes) ptr + prefixes <- peekSequence (deRef peekUtf8CString) (#size GuString*) c_prefixes + forms <- peekForms (len-1) (ptr `plusPtr` (#size PgfAlternative)) + return ((form,prefixes):forms) + +deRef peekValue ptr = peek ptr >>= peekValue + +fidString, fidInt, fidFloat, fidVar, fidStart :: FId +fidString = (-1) +fidInt = (-2) +fidFloat = (-3) +fidVar = (-4) +fidStart = (-5) + +isPredefFId :: FId -> Bool +isPredefFId = (`elem` [fidString, fidInt, fidFloat, fidVar]) + + +----------------------------------------------------------------------- +-- Building new PGFs in memory +----------------------------------------------------------------------- + +data Builder s = Builder (Ptr GuPool) Touch +newtype B s a = B a + +build :: (forall s . (?builder :: Builder s) => B s a) -> a +build f = + unsafePerformIO $ do + pool <- gu_new_pool + poolFPtr <- newForeignPtr gu_pool_finalizer pool + let ?builder = Builder pool (touchForeignPtr poolFPtr) + let B res = f + return res + +eAbs :: (?builder :: Builder s) => BindType -> String -> B s Expr -> B s Expr +eAbs bind_type var (B (Expr body _)) = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_ABS) + (#size PgfExprAbs) + (#const gu_alignof(PgfExprAbs)) + pptr pool + cvar <- newUtf8CString var pool + (#poke PgfExprAbs, bind_type) ptr (cbind_type :: PgfBindType) + (#poke PgfExprAbs, id) ptr cvar + (#poke PgfExprAbs, body) ptr body + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + + cbind_type = + case bind_type of + Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) + Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) + +eApp :: (?builder :: Builder s) => B s Expr -> B s Expr -> B s Expr +eApp (B (Expr fun _)) (B (Expr arg _)) = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_APP) + (#size PgfExprApp) + (#const gu_alignof(PgfExprApp)) + pptr pool + (#poke PgfExprApp, fun) ptr fun + (#poke PgfExprApp, arg) ptr arg + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + +eMeta :: (?builder :: Builder s) => Int -> B s Expr +eMeta id = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_META) + (fromIntegral (#size PgfExprMeta)) + (#const gu_alignof(PgfExprMeta)) + pptr pool + (#poke PgfExprMeta, id) ptr (fromIntegral id :: CInt) + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + +eFun :: (?builder :: Builder s) => Fun -> B s Expr +eFun fun = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_FUN) + (fromIntegral ((#size PgfExprFun)+utf8Length fun)) + (#const gu_flex_alignof(PgfExprFun)) + pptr pool + pokeUtf8CString fun (ptr `plusPtr` (#offset PgfExprFun, fun)) + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + +eVar :: (?builder :: Builder s) => Int -> B s Expr +eVar var = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_VAR) + (#size PgfExprVar) + (#const gu_alignof(PgfExprVar)) + pptr pool + (#poke PgfExprVar, var) ptr (fromIntegral var :: CInt) + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + +eTyped :: (?builder :: Builder s) => B s Expr -> B s Type -> B s Expr +eTyped (B (Expr e _)) (B (Type ty _)) = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_TYPED) + (#size PgfExprTyped) + (#const gu_alignof(PgfExprTyped)) + pptr pool + (#poke PgfExprTyped, expr) ptr e + (#poke PgfExprTyped, type) ptr ty + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + +eImplArg :: (?builder :: Builder s) => B s Expr -> B s Expr +eImplArg (B (Expr e _)) = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_IMPL_ARG) + (#size PgfExprImplArg) + (#const gu_alignof(PgfExprImplArg)) + pptr pool + (#poke PgfExprImplArg, expr) ptr e + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + +hypo :: BindType -> CId -> B s Type -> (B s Hypo) +hypo bind_type var (B ty) = B (bind_type,var,ty) + +dTyp :: (?builder :: Builder s) => [B s Hypo] -> Cat -> [B s Expr] -> B s Type +dTyp hypos cat es = + unsafePerformIO $ do + ptr <- gu_malloc_aligned pool + ((#size PgfType)+n_exprs*(#size GuVariant)) + (#const gu_flex_alignof(PgfType)) + c_hypos <- newHypos hypos pool + c_cat <- newUtf8CString cat pool + (#poke PgfType, hypos) ptr c_hypos + (#poke PgfType, cid) ptr c_cat + (#poke PgfType, n_exprs) ptr n_exprs + pokeArray (ptr `plusPtr` (#offset PgfType, exprs)) [e | B (Expr e _) <- es] + return (B (Type ptr touch)) + where + (Builder pool touch) = ?builder + n_exprs = fromIntegral (length es) :: CSizeT + +newHypos :: [B s Hypo] -> Ptr GuPool -> IO (Ptr GuSeq) +newHypos hypos pool = do + c_hypos <- gu_make_seq (#size PgfHypo) (fromIntegral (length hypos)) pool + pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos + return c_hypos + where + pokeHypos ptr [] = return () + pokeHypos ptr (B (bind_type,var,Type ty _):hypos) = do + c_var <- newUtf8CString var pool + (#poke PgfHypo, bind_type) ptr (cbind_type :: PgfBindType) + (#poke PgfHypo, cid) ptr c_var + (#poke PgfHypo, type) ptr ty + pokeHypos (ptr `plusPtr` (#size PgfHypo)) hypos + where + cbind_type = + case bind_type of + Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) + Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) + + +data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr PgfAbsFun) (Ptr GuBuf) Touch + +newAbstr :: (?builder :: Builder s) => [(String,Literal)] -> + [(Cat,[B s Hypo],Float)] -> + [(Fun,B s Type,Int,Float)] -> + AbstrInfo +newAbstr aflags cats funs = unsafePerformIO $ do + c_aflags <- newFlags aflags pool + (c_cats,abscats) <- newAbsCats (sortByFst3 cats) pool + (c_funs,absfuns) <- newAbsFuns (sortByFst4 funs) pool + c_abs_lin_fun <- newAbsLinFun + c_non_lexical_buf <- gu_make_buf (#size PgfProductionIdxEntry) pool + return (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun c_non_lexical_buf touch) + where + (Builder pool touch) = ?builder + + newAbsCats values pool = do + c_seq <- gu_make_seq (#size PgfAbsCat) (fromIntegral (length values)) pool + abscats <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values + return (c_seq,abscats) + where + pokeElems ptr abscats [] = return abscats + pokeElems ptr abscats (x:xs) = do + abscats <- pokeAbsCat ptr abscats x + pokeElems (ptr `plusPtr` (#size PgfAbsCat)) abscats xs + + pokeAbsCat ptr abscats (name,hypos,prob) = do + c_name <- newUtf8CString name pool + c_hypos <- newHypos hypos pool + (#poke PgfAbsCat, name) ptr c_name + (#poke PgfAbsCat, context) ptr c_hypos + (#poke PgfAbsCat, prob) ptr (realToFrac prob :: CFloat) + return (Map.insert name ptr abscats) + + newAbsFuns values pool = do + c_seq <- gu_make_seq (#size PgfAbsFun) (fromIntegral (length values)) pool + absfuns <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values + return (c_seq,absfuns) + where + pokeElems ptr absfuns [] = return absfuns + pokeElems ptr absfuns (x:xs) = do + absfuns <- pokeAbsFun ptr absfuns x + pokeElems (ptr `plusPtr` (#size PgfAbsFun)) absfuns xs + + pokeAbsFun ptr absfuns (name,B (Type c_ty _),arity,prob) = do + pfun <- gu_alloc_variant (#const PGF_EXPR_FUN) + (fromIntegral ((#size PgfExprFun)+utf8Length name)) + (#const gu_flex_alignof(PgfExprFun)) + (ptr `plusPtr` (#offset PgfAbsFun, ep.expr)) pool + let c_name = (pfun `plusPtr` (#offset PgfExprFun, fun)) + pokeUtf8CString name c_name + (#poke PgfAbsFun, name) ptr c_name + (#poke PgfAbsFun, type) ptr c_ty + (#poke PgfAbsFun, arity) ptr (fromIntegral arity :: CInt) + (#poke PgfAbsFun, defns) ptr nullPtr + (#poke PgfAbsFun, ep.prob) ptr (realToFrac prob :: CFloat) + return (Map.insert name ptr absfuns) + + newAbsLinFun = do + ptr <- gu_malloc_aligned pool + (#size PgfAbsFun) + (#const gu_alignof(PgfAbsFun)) + c_wild <- newUtf8CString "_" pool + c_ty <- gu_malloc_aligned pool + (#size PgfType) + (#const gu_alignof(PgfType)) + (#poke PgfType, hypos) c_ty nullPtr + (#poke PgfType, cid) c_ty c_wild + (#poke PgfType, n_exprs) c_ty (0 :: CSizeT) + (#poke PgfAbsFun, name) ptr c_wild + (#poke PgfAbsFun, type) ptr c_ty + (#poke PgfAbsFun, arity) ptr (0 :: CSizeT) + (#poke PgfAbsFun, defns) ptr nullPtr + (#poke PgfAbsFun, ep.prob) ptr (- log 0 :: CFloat) + (#poke PgfAbsFun, ep.expr) ptr nullPtr + return ptr + + +data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap) (Ptr PgfConcr -> Ptr GuPool -> IO ()) CInt + +newConcr :: (?builder :: Builder s) => AbstrInfo -> + [(String,Literal)] -> -- ^ Concrete syntax flags + [(String,String)] -> -- ^ Printnames + [(FId,[FunId])] -> -- ^ Lindefs + [(FId,[FunId])] -> -- ^ Linrefs + [(FId,[Production])] -> -- ^ Productions + [(Fun,[SeqId])] -> -- ^ Concrete functions (must be sorted by Fun) + [[Symbol]] -> -- ^ Sequences (must be sorted) + [(Cat,FId,FId,[String])] -> -- ^ Concrete categories + FId -> -- ^ The total count of the categories + ConcrInfo +newConcr (AbstrInfo _ _ abscats _ absfuns c_abs_lin_fun c_non_lexical_buf _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats total_cats = unsafePerformIO $ do + c_cflags <- newFlags cflags pool + c_printname <- newMap (#size GuString) gu_string_hasher newUtf8CString + (#size GuString) (pokeString pool) + printnames pool + c_seqs <- newSequence (#size PgfSequence) pokeSequence sequences pool + let seqs_ptr = c_seqs `plusPtr` (#offset GuSeq, data) + c_cncfuns <- newSequence (#size PgfCncFun*) (pokeCncFun seqs_ptr) (zip [0..] cncfuns) pool + let funs_ptr = c_cncfuns `plusPtr` (#offset GuSeq, data) + c_ccats <- gu_make_map (#size int) gu_int_hasher + (#size PgfCCat*) gu_null_struct + (#const GU_MAP_DEFAULT_INIT_SIZE) + pool + mapM_ (addLindefs c_ccats funs_ptr) lindefs + mapM_ (addLinrefs c_ccats funs_ptr) linrefs + mk_index <- foldM (addProductions c_ccats funs_ptr c_non_lexical_buf) (\concr pool -> return ()) prods + c_cnccats <- newMap (#size GuString) gu_string_hasher newUtf8CString (#size PgfCncCat*) (pokeCncCat c_ccats) (map (\v@(k,_,_,_) -> (k,v)) cnccats) pool + return (ConcrInfo c_cflags c_printname c_ccats c_cncfuns c_seqs c_cnccats mk_index (fromIntegral total_cats)) + where + (Builder pool touch) = ?builder + + pokeCncFun seqs_ptr ptr cncfun = do + c_cncfun <- newCncFun absfuns nullPtr cncfun pool + poke ptr c_cncfun + + pokeSequence c_seq syms = do + c_syms <- newSymbols syms pool + (#poke PgfSequence, syms) c_seq c_syms + (#poke PgfSequence, idx) c_seq nullPtr + + addLindefs c_ccats funs_ptr (fid,funids) = do + c_ccat <- getCCat c_ccats fid pool + c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId funs_ptr) funids pool + (#poke PgfCCat, lindefs) c_ccat c_funs + + addLinrefs c_ccats funs_ptr (fid,funids) = do + c_ccat <- getCCat c_ccats fid pool + c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId funs_ptr) funids pool + (#poke PgfCCat, linrefs) c_ccat c_funs + + addProductions c_ccats funs_ptr c_non_lexical_buf mk_index (fid,prods) = do + c_ccat <- getCCat c_ccats fid pool + let n_prods = length prods + c_prods <- gu_make_seq (#size PgfProduction) (fromIntegral n_prods) pool + (#poke PgfCCat, prods) c_ccat c_prods + pokeProductions c_ccat (c_prods `plusPtr` (#offset GuSeq, data)) 0 (n_prods-1) mk_index prods + where + pokeProductions c_ccat ptr top bot mk_index [] = return mk_index + pokeProductions c_ccat ptr top bot mk_index (prod:prods) = do + (is_lexical,c_prod) <- newProduction c_ccats funs_ptr c_non_lexical_buf prod pool + let mk_index' = \concr pool -> do pgf_parser_index concr c_ccat c_prod is_lexical pool + pgf_lzr_index concr c_ccat c_prod is_lexical pool + mk_index concr pool + if is_lexical == 0 + then do poke (ptr `plusPtr` ((#size PgfProduction)*top)) c_prod + pokeProductions c_ccat ptr (top+1) bot mk_index' prods + else do poke (ptr `plusPtr` ((#size PgfProduction)*bot)) c_prod + pokeProductions c_ccat ptr top (bot-1) mk_index' prods + + pokeRefDefFunId funs_ptr ptr funid = do + let c_fun = funs_ptr `plusPtr` (funid * (#size PgfCncFun)) + (#poke PgfCncFun, absfun) c_fun c_abs_lin_fun + poke ptr c_fun + + pokeCncCat c_ccats ptr (name,start,end,labels) = do + let n_lins = fromIntegral (length labels) :: CSizeT + c_cnccat <- gu_malloc_aligned pool + ((#size PgfCncCat)+n_lins*(#size GuString)) + (#const gu_flex_alignof(PgfCncCat)) + case Map.lookup name abscats of + Just c_abscat -> (#poke PgfCncCat, abscat) c_cnccat c_abscat + Nothing -> throwIO (PGFError ("The category "++name++" is not in the abstract syntax")) + c_ccats <- newSequence (#size PgfCCat*) pokeFId [start..end] pool + (#poke PgfCncCat, cats) c_cnccat c_ccats + pokeLabels (c_cnccat `plusPtr` (#offset PgfCncCat, labels)) labels + poke ptr c_cnccat + where + pokeFId ptr fid = do + c_ccat <- getCCat c_ccats fid pool + poke ptr c_ccat + + pokeLabels ptr [] = return [] + pokeLabels ptr (l:ls) = do + c_l <- newUtf8CString l pool + poke ptr c_l + pokeLabels (ptr `plusPtr` (#size GuString)) ls + + +newPGF :: (?builder :: Builder s) => [(String,Literal)] -> + AbsName -> + AbstrInfo -> + [(ConcName,ConcrInfo)] -> + B s PGF +newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _ _) concrs = + unsafePerformIO $ do + ptr <- gu_malloc_aligned pool + (#size PgfPGF) + (#const gu_alignof(PgfPGF)) + c_gflags <- newFlags gflags pool + c_absname <- newUtf8CString absname pool + let c_abstr = ptr `plusPtr` (#offset PgfPGF, abstract) + c_concrs <- newSequence (#size PgfConcr) (pokeConcr c_abstr) concrs pool + (#poke PgfPGF, major_version) ptr (2 :: (#type uint16_t)) + (#poke PgfPGF, minor_version) ptr (0 :: (#type uint16_t)) + (#poke PgfPGF, gflags) ptr c_gflags + (#poke PgfPGF, abstract.name) ptr c_absname + (#poke PgfPGF, abstract.aflags) ptr c_aflags + (#poke PgfPGF, abstract.funs) ptr c_funs + (#poke PgfPGF, abstract.cats) ptr c_cats + (#poke PgfPGF, abstract.abs_lin_fun) ptr c_abs_lin_fun + (#poke PgfPGF, concretes) ptr c_concrs + (#poke PgfPGF, pool) ptr pool + return (B (PGF ptr touch)) + where + (Builder pool touch) = ?builder + + pokeConcr c_abstr ptr (name, ConcrInfo c_cflags c_printnames c_ccats c_cncfuns c_seqs c_cnccats mk_index c_total_cats) = do + c_name <- newUtf8CString name pool + c_fun_indices <- gu_make_map (#size GuString) gu_string_hasher + (#size PgfCncOverloadMap*) gu_null_struct + (#const GU_MAP_DEFAULT_INIT_SIZE) + pool + c_coerce_idx <- gu_make_map (#size PgfCCat*) gu_addr_hasher + (#size GuBuf*) gu_null_struct + (#const GU_MAP_DEFAULT_INIT_SIZE) + pool + (#poke PgfConcr, name) ptr c_name + (#poke PgfConcr, abstr) ptr c_abstr + (#poke PgfConcr, cflags) ptr c_cflags + (#poke PgfConcr, printnames) ptr c_printnames + (#poke PgfConcr, ccats) ptr c_ccats + (#poke PgfConcr, fun_indices) ptr c_fun_indices + (#poke PgfConcr, coerce_idx) ptr c_coerce_idx + (#poke PgfConcr, cncfuns) ptr c_cncfuns + (#poke PgfConcr, sequences) ptr c_seqs + (#poke PgfConcr, cnccats) ptr c_cnccats + (#poke PgfConcr, total_cats) ptr c_total_cats + (#poke PgfConcr, pool) ptr nullPtr + mk_index ptr pool + + +newFlags :: [(String,Literal)] -> Ptr GuPool -> IO (Ptr GuSeq) +newFlags flags pool = newSequence (#size PgfFlag) pokeFlag (sortByFst flags) pool + where + pokeFlag c_flag (name,value) = do + c_name <- newUtf8CString name pool + c_value <- newLiteral value pool + (#poke PgfFlag, name) c_flag c_name + (#poke PgfFlag, value) c_flag c_value + + +newLiteral :: Literal -> Ptr GuPool -> IO GuVariant +newLiteral (LStr val) pool = + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_LITERAL_STR) + (fromIntegral ((#size PgfLiteralStr)+utf8Length val)) + (#const gu_flex_alignof(PgfLiteralStr)) + pptr pool + pokeUtf8CString val (ptr `plusPtr` (#offset PgfLiteralStr, val)) + peek pptr +newLiteral (LInt val) pool = + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_LITERAL_INT) + (fromIntegral (#size PgfLiteralInt)) + (#const gu_alignof(PgfLiteralInt)) + pptr pool + (#poke PgfLiteralInt, val) ptr (fromIntegral val :: CInt) + peek pptr +newLiteral (LFlt val) pool = + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_LITERAL_FLT) + (fromIntegral (#size PgfLiteralFlt)) + (#const gu_alignof(PgfLiteralFlt)) + pptr pool + (#poke PgfLiteralFlt, val) ptr (realToFrac val :: CDouble) + peek pptr + + +newProduction :: Ptr GuMap -> Ptr PgfCncFun -> Ptr GuBuf -> Production -> Ptr GuPool -> IO ((#type bool), GuVariant) +newProduction c_ccats funs_ptr c_non_lexical_buf (PApply fun_id args) pool = + alloca $ \pptr -> do + let c_fun = funs_ptr `plusPtr` (fun_id * (#size PgfCncFun)) + c_args <- newSequence (#size PgfPArg) pokePArg args pool + ptr <- gu_alloc_variant (#const PGF_PRODUCTION_APPLY) + (fromIntegral (#size PgfProductionApply)) + (#const gu_alignof(PgfProductionApply)) + pptr pool + (#poke PgfProductionApply, fun) ptr c_fun + (#poke PgfProductionApply, args) ptr c_args + is_lexical <- pgf_production_is_lexical ptr c_non_lexical_buf pool + c_prod <- peek pptr + return (is_lexical,c_prod) + where + pokePArg ptr (PArg hypos ccat) = do + c_ccat <- getCCat c_ccats ccat pool + (#poke PgfPArg, ccat) ptr c_ccat + c_hypos <- newSequence (#size PgfCCat*) pokeCCat hypos pool + (#poke PgfPArg, hypos) ptr c_hypos + + pokeCCat ptr ccat = do + c_ccat <- getCCat c_ccats ccat pool + poke ptr c_ccat + +newProduction c_ccats funs_ptr c_non_lexical_buf (PCoerce fid) pool = + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_PRODUCTION_COERCE) + (fromIntegral (#size PgfProductionCoerce)) + (#const gu_alignof(PgfProductionCoerce)) + pptr pool + c_ccat <- getCCat c_ccats fid pool + (#poke PgfProductionCoerce, coerce) ptr c_ccat + c_prod <- peek pptr + return (0,c_prod) + + +newCncFun absfuns seqs_ptr (funid,(fun,seqids)) pool = + do let c_absfun = fromMaybe nullPtr (Map.lookup fun absfuns) + c_ep = if c_absfun == nullPtr + then nullPtr + else c_absfun `plusPtr` (#offset PgfAbsFun, ep) + n_lins = fromIntegral (length seqids) :: CSizeT + ptr <- gu_malloc_aligned pool + ((#size PgfCncFun)+n_lins*(#size PgfSequence*)) + (#const gu_flex_alignof(PgfCncFun)) + (#poke PgfCncFun, absfun) ptr c_absfun + (#poke PgfCncFun, ep) ptr c_ep + (#poke PgfCncFun, funid) ptr (funid :: CInt) + (#poke PgfCncFun, n_lins) ptr n_lins + pokeSequences seqs_ptr (ptr `plusPtr` (#offset PgfCncFun, lins)) seqids + return ptr + where + pokeSequences seqs_ptr ptr [] = return () + pokeSequences seqs_ptr ptr (seqid:seqids) = do + poke ptr (seqs_ptr `plusPtr` (seqid * (#size PgfSequence))) + pokeSequences seqs_ptr (ptr `plusPtr` (#size PgfSequence*)) seqids + +getCCat c_ccats fid pool = + alloca $ \pfid -> do + poke pfid (fromIntegral fid :: CInt) + ptr <- gu_map_find_default c_ccats pfid + c_ccat <- peek ptr + if c_ccat /= nullPtr + then return c_ccat + else do c_ccat <- gu_malloc_aligned pool + (#size PgfCCat) + (#const gu_alignof(PgfCCat)) + (#poke PgfCCat, cnccat) c_ccat nullPtr + (#poke PgfCCat, lindefs) c_ccat nullPtr + (#poke PgfCCat, linrefs) c_ccat nullPtr + (#poke PgfCCat, n_synprods) c_ccat (0 :: CSizeT) + (#poke PgfCCat, prods) c_ccat nullPtr + (#poke PgfCCat, viterbi_prob) c_ccat (0 :: CFloat) + (#poke PgfCCat, fid) c_ccat fid + (#poke PgfCCat, conts) c_ccat nullPtr + (#poke PgfCCat, answers) c_ccat nullPtr + ptr <- gu_map_insert c_ccats pfid + poke ptr c_ccat + return c_ccat + +newSymbol :: Symbol -> Ptr GuPool -> IO GuVariant +newSymbol (SymCat d r) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAT) + (fromIntegral (#size PgfSymbolCat)) + (#const gu_alignof(PgfSymbolCat)) + pptr pool + (#poke PgfSymbolCat, d) ptr (fromIntegral d :: CInt) + (#poke PgfSymbolCat, r) ptr (fromIntegral r :: CInt) + peek pptr +newSymbol (SymLit d r) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_LIT) + (fromIntegral (#size PgfSymbolLit)) + (#const gu_alignof(PgfSymbolLit)) + pptr pool + (#poke PgfSymbolLit, d) ptr (fromIntegral d :: CInt) + (#poke PgfSymbolLit, r) ptr (fromIntegral r :: CInt) + peek pptr +newSymbol (SymVar d r) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_VAR) + (fromIntegral (#size PgfSymbolVar)) + (#const gu_alignof(PgfSymbolVar)) + pptr pool + (#poke PgfSymbolVar, d) ptr (fromIntegral d :: CInt) + (#poke PgfSymbolVar, r) ptr (fromIntegral r :: CInt) + peek pptr +newSymbol (SymKS t) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_KS) + (fromIntegral ((#size PgfSymbolKS)+utf8Length t)) + (#const gu_flex_alignof(PgfSymbolKS)) + pptr pool + pokeUtf8CString t (ptr `plusPtr` (#offset PgfSymbolKS, token)) + peek pptr +newSymbol (SymKP def alts) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_KP) + (fromIntegral ((#size PgfSymbolKP)+(length alts * (#size PgfAlternative)))) + (#const gu_flex_alignof(PgfSymbolKP)) + pptr pool + c_def <- newSymbols def pool + (#poke PgfSymbolKP, default_form) ptr c_def + pokeAlternatives (ptr `plusPtr` (#offset PgfSymbolKP, forms)) alts pool + peek pptr +newSymbol SymBIND pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_BIND) + (fromIntegral (#size PgfSymbolBIND)) + (#const gu_alignof(PgfSymbolBIND)) + pptr pool + peek pptr +newSymbol SymNE pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_NE) + (fromIntegral (#size PgfSymbolNE)) + (#const gu_alignof(PgfSymbolNE)) + pptr pool + peek pptr +newSymbol SymSOFT_BIND pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_BIND) + (fromIntegral (#size PgfSymbolBIND)) + (#const gu_alignof(PgfSymbolBIND)) + pptr pool + peek pptr +newSymbol SymSOFT_SPACE pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_SPACE) + (fromIntegral (#size PgfSymbolBIND)) + (#const gu_alignof(PgfSymbolBIND)) + pptr pool + peek pptr +newSymbol SymCAPIT pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAPIT) + (fromIntegral (#size PgfSymbolCAPIT)) + (#const gu_alignof(PgfSymbolCAPIT)) + pptr pool + peek pptr +newSymbol SymALL_CAPIT pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_ALL_CAPIT) + (fromIntegral (#size PgfSymbolCAPIT)) + (#const gu_alignof(PgfSymbolCAPIT)) + pptr pool + peek pptr + +newSymbols syms pool = newSequence (#size PgfSymbol) pokeSymbol syms pool + where + pokeSymbol p_sym sym = do + c_sym <- newSymbol sym pool + poke p_sym c_sym + +pokeAlternatives ptr [] pool = return () +pokeAlternatives ptr ((syms,prefixes):alts) pool = do + c_syms <- newSymbols syms pool + c_prefixes <- newSequence (#size GuString) (pokeString pool) prefixes pool + (#poke PgfAlternative, form) ptr c_syms + (#poke PgfAlternative, prefixes) ptr c_prefixes + pokeAlternatives (ptr `plusPtr` (#size PgfAlternative)) alts pool + +pokeString pool c_elem str = do + c_str <- newUtf8CString str pool + poke c_elem c_str + +newMap key_size hasher newKey elem_size pokeElem values pool = do + map <- gu_make_map key_size hasher + elem_size gu_null_struct + (#const GU_MAP_DEFAULT_INIT_SIZE) + pool + insert map values pool + return map + where + insert map [] pool = return () + insert map ((key,elem):values) pool = do + c_key <- newKey key pool + c_elem <- gu_map_insert map c_key + pokeElem c_elem elem + insert map values pool + + +writePGF :: FilePath -> PGF -> IO () +writePGF fpath p = do + pool <- gu_new_pool + exn <- gu_new_exn pool + withCString fpath $ \c_fpath -> + pgf_write (pgf p) c_fpath exn + touchPGF p + failed <- gu_exn_is_raised exn + if failed + then do is_errno <- gu_exn_caught exn gu_exn_type_GuErrno + if is_errno + then do perrno <- (#peek GuExn, data.data) exn + errno <- peek perrno + gu_pool_free pool + ioError (errnoToIOError "writePGF" (Errno errno) Nothing (Just fpath)) + else do gu_pool_free pool + throwIO (PGFError "The grammar cannot be stored") + else do gu_pool_free pool + return () + +sortByFst = sortBy (\(x,_) (y,_) -> compare x y) +sortByFst3 = sortBy (\(x,_,_) (y,_,_) -> compare x y) +sortByFst4 = sortBy (\(x,_,_,_) (y,_,_,_) -> compare x y) diff --git a/src/runtime/haskell-bind/PGF2/Type.hsc b/src/runtime/haskell-bind/PGF2/Type.hsc index ada2b5e03..57e7eeaa9 100644 --- a/src/runtime/haskell-bind/PGF2/Type.hsc +++ b/src/runtime/haskell-bind/PGF2/Type.hsc @@ -31,7 +31,7 @@ readType str = do c_str <- newUtf8CString str tmpPl guin <- gu_string_in c_str tmpPl exn <- gu_new_exn tmpPl - c_type <- pgf_read_type guin typPl exn + c_type <- pgf_read_type guin typPl tmpPl exn status <- gu_exn_is_raised exn if (not status && c_type /= nullPtr) then do typFPl <- newForeignPtr gu_pool_finalizer typPl @@ -62,10 +62,9 @@ showType scope (Type ty touch) = mkType :: [Hypo] -> CId -> [Expr] -> Type mkType hypos cat exprs = unsafePerformIO $ do typPl <- gu_new_pool - let n_exprs = fromIntegral (length exprs) :: CInt + let n_exprs = fromIntegral (length exprs) :: CSizeT c_type <- gu_malloc typPl ((#size PgfType) + n_exprs * (#size PgfExpr)) - c_hypos <- gu_make_seq (#size PgfHypo) (fromIntegral (length hypos)) typPl - hs <- pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos typPl + c_hypos <- newSequence (#size PgfHypo) (pokeHypo typPl) hypos typPl (#poke PgfType, hypos) c_type c_hypos ccat <- newUtf8CString cat typPl (#poke PgfType, cid) c_type ccat @@ -73,27 +72,25 @@ mkType hypos cat exprs = unsafePerformIO $ do pokeExprs (c_type `plusPtr` (#offset PgfType, exprs)) exprs typFPl <- newForeignPtr gu_pool_finalizer typPl return (Type c_type (mapM_ touchHypo hypos >> mapM_ touchExpr exprs >> touchForeignPtr typFPl)) - where - pokeHypos :: Ptr a -> [Hypo] -> Ptr GuPool -> IO () - pokeHypos c_hypo [] typPl = return () - pokeHypos c_hypo ((bind_type,cid,Type c_ty _) : hypos) typPl = do - (#poke PgfHypo, bind_type) c_hypo cbind_type - newUtf8CString cid typPl >>= (#poke PgfHypo, cid) c_hypo - (#poke PgfHypo, type) c_hypo c_ty - pokeHypos (plusPtr c_hypo (#size PgfHypo)) hypos typPl - where - cbind_type :: CInt - cbind_type = - case bind_type of - Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) - Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) - pokeExprs ptr [] = return () - pokeExprs ptr ((Expr e _):es) = do - poke ptr e - pokeExprs (plusPtr ptr (#size PgfExpr)) es +pokeHypo :: Ptr GuPool -> Ptr a -> Hypo -> IO () +pokeHypo pool c_hypo (bind_type,cid,Type c_ty _) = do + (#poke PgfHypo, bind_type) c_hypo cbind_type + newUtf8CString cid pool >>= (#poke PgfHypo, cid) c_hypo + (#poke PgfHypo, type) c_hypo c_ty + where + cbind_type :: CInt + cbind_type = + case bind_type of + Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) + Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) - touchHypo (_,_,ty) = touchType ty +pokeExprs ptr [] = return () +pokeExprs ptr ((Expr e _):es) = do + poke ptr e + pokeExprs (plusPtr ptr (#size PgfExpr)) es + +touchHypo (_,_,ty) = touchType ty -- | Decomposes a type into a list of hypothesises, a category and -- a list of arguments for the category. @@ -125,3 +122,20 @@ unType (Type c_type touch) = unsafePerformIO $ do es <- peekExprs ptr (i+1) n return (Expr e touch : es) | otherwise = return [] + +-- | renders a type as a 'String'. The list +-- of identifiers is the list of all free variables +-- in the type in order reverse to the order +-- of binding. +showContext :: [CId] -> [Hypo] -> String +showContext scope hypos = + unsafePerformIO $ + withGuPool $ \tmpPl -> + do (sb,out) <- newOut tmpPl + c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl + printCtxt <- newPrintCtxt scope tmpPl + exn <- gu_new_exn tmpPl + pgf_print_context c_hypos printCtxt out exn + mapM_ touchHypo hypos + s <- gu_string_buf_freeze sb tmpPl + peekUtf8CString s diff --git a/src/runtime/haskell-bind/SG/FFI.hs b/src/runtime/haskell-bind/SG/FFI.hs index 833e9aab3..ef1b06de8 100644 --- a/src/runtime/haskell-bind/SG/FFI.hs +++ b/src/runtime/haskell-bind/SG/FFI.hs @@ -65,10 +65,10 @@ foreign import ccall "sg/sg.h sg_triple_result_close" sg_triple_result_close :: Ptr SgTripleResult -> Ptr GuExn -> IO () foreign import ccall "sg/sg.h sg_query" - sg_query :: Ptr SgSG -> CInt -> Ptr PgfExpr -> Ptr GuExn -> IO (Ptr SgQueryResult) + sg_query :: Ptr SgSG -> CSizeT -> Ptr PgfExpr -> Ptr GuExn -> IO (Ptr SgQueryResult) foreign import ccall "sg/sg.h sg_query_result_columns" - sg_query_result_columns :: Ptr SgQueryResult -> IO CInt + sg_query_result_columns :: Ptr SgQueryResult -> IO CSizeT foreign import ccall "sg/sg.h sg_query_result_fetch" sg_query_result_fetch :: Ptr SgQueryResult -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt diff --git a/src/runtime/haskell-bind/examples/pgf-shell.hs b/src/runtime/haskell-bind/examples/pgf-shell.hs index 722770822..05c991691 100644 --- a/src/runtime/haskell-bind/examples/pgf-shell.hs +++ b/src/runtime/haskell-bind/examples/pgf-shell.hs @@ -37,18 +37,18 @@ execute cmd = P lang s -> do pgf <- gets fst c <- getConcr' pgf lang case parse c (startCat pgf) s of - Left tok -> do put (pgf,[]) - putln ("Parse error: "++tok) - Right ts -> do put (pgf,map show ts) - pop + ParseFailed _ tok -> do put (pgf,[]) + putln ("Parse error: "++tok) + ParseOk ts -> do put (pgf,map show ts) + pop T from to s -> do pgf <- gets fst cfrom <- getConcr' pgf from cto <- getConcr' pgf to case parse cfrom (startCat pgf) s of - Left tok -> do put (pgf,[]) - putln ("Parse error: "++tok) - Right ts -> do put (pgf,map (linearize cto.fst) ts) - pop + ParseFailed _ tok -> do put (pgf,[]) + putln ("Parse error: "++tok) + ParseOk ts -> do put (pgf,map (linearize cto.fst) ts) + pop I path -> do pgf <- liftIO (readPGF path) putln . unwords . M.keys $ languages pgf put (pgf,[]) diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal index 8f29ea969..178f15023 100644 --- a/src/runtime/haskell-bind/pgf2.cabal +++ b/src/runtime/haskell-bind/pgf2.cabal @@ -1,32 +1,31 @@ name: pgf2 version: 0.1.0.0 --- synopsis: --- description: +-- synopsis: +-- description: homepage: http://www.grammaticalframework.org license: LGPL-3 --license-file: LICENSE author: Krasimir Angelov, Inari -maintainer: --- copyright: +maintainer: +-- copyright: category: Language build-type: Simple extra-source-files: README cabal-version: >=1.10 library - exposed-modules: PGF2, SG, + exposed-modules: PGF2, PGF2.Internal, SG, -- backwards compatibility API: PGF, PGF.Internal other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI - build-depends: base >=4.3, bytestring >=0.9, + build-depends: base >=4.3, containers, pretty - -- hs-source-dirs: + -- hs-source-dirs: default-language: Haskell2010 build-tools: hsc2hs extra-libraries: sg pgf gu cc-options: -std=c99 - default-language: Haskell2010 c-sources: utils.c executable pgf-shell diff --git a/src/runtime/haskell/Data/Binary/Builder.hs b/src/runtime/haskell/Data/Binary/Builder.hs index 03531daa7..b69371f0e 100644 --- a/src/runtime/haskell/Data/Binary/Builder.hs +++ b/src/runtime/haskell/Data/Binary/Builder.hs @@ -100,6 +100,11 @@ newtype Builder = Builder { runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString] } +#if MIN_VERSION_base(4,11,0) +instance Semigroup Builder where + (<>) = append +#endif + instance Monoid Builder where mempty = empty {-# INLINE mempty #-} diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index 42519fb63..6c0002a8a 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -47,14 +47,14 @@ module PGF( Expr, showExpr, readExpr, mkAbs, unAbs, - mkApp, unApp, + mkApp, unApp, unapply, mkStr, unStr, mkInt, unInt, mkDouble, unDouble, mkFloat, unFloat, mkMeta, unMeta, -- extra - pExpr, + pExpr, exprSize, exprFunctions, -- * Operations -- ** Linearization @@ -66,7 +66,7 @@ module PGF( Forest.showBracketedString,flattenBracketedString, -- ** Parsing - parse, parseAllLang, parseAll, parse_, parseWithRecovery, + parse, parseAllLang, parseAll, parse_, parseWithRecovery, complete, -- ** Evaluation PGF.compute, paraphrase, @@ -273,6 +273,25 @@ parse_ pgf lang typ dp s = parseWithRecovery pgf lang typ open_typs dp s = Parse.parseWithRecovery pgf lang typ open_typs dp (words s) +complete :: PGF -> Language -> Type -> String -> String -> (BracketedString,String,Map.Map Token [CId]) +complete pgf from typ input prefix = + let ws = words input + ps0 = Parse.initState pgf from typ + (ps,ws') = loop ps0 ws + bs = snd (Parse.getParseOutput ps typ Nothing) + in if not (null ws') + then (bs, unwords (if null prefix then ws' else ws'++[prefix]), Map.empty) + else (bs, prefix, fmap getFuns (Parse.getCompletions ps prefix)) + where + loop ps [] = (ps,[]) + loop ps (w:ws) = case Parse.nextState ps (Parse.simpleParseInput w) of + Left es -> (ps,w:ws) + Right ps -> loop ps ws + + getFuns ps = [cid | (funid,cid,seq) <- snd . head $ Map.toList contInfo] + where + contInfo = Parse.getContinuationInfo ps + groupResults :: [[(Language,String)]] -> [(Language,[String])] groupResults = Map.toList . foldr more Map.empty . start . concat where @@ -314,6 +333,23 @@ functionType pgf fun = compute :: PGF -> Expr -> Expr compute pgf = PGF.Data.normalForm (funs (abstract pgf),const Nothing) 0 [] +exprSize :: Expr -> Int +exprSize (EAbs _ _ e) = exprSize e +exprSize (EApp e1 e2) = exprSize e1 + exprSize e2 +exprSize (ETyped e ty)= exprSize e +exprSize (EImplArg e) = exprSize e +exprSize _ = 1 + +exprFunctions :: Expr -> [CId] +exprFunctions (EAbs _ _ e) = exprFunctions e +exprFunctions (EApp e1 e2) = exprFunctions e1 ++ exprFunctions e2 +exprFunctions (ETyped e ty)= exprFunctions e +exprFunctions (EImplArg e) = exprFunctions e +exprFunctions (EFun f) = [f] +exprFunctions _ = [] + +--exprFunctions :: Expr -> [Fun] + browse :: PGF -> CId -> Maybe (String,[CId],[CId]) browse pgf id = fmap (\def -> (def,producers,consumers)) definition where diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs index 579d6b3bb..ef21ab229 100644 --- a/src/runtime/haskell/PGF/ByteCode.hs +++ b/src/runtime/haskell/PGF/ByteCode.hs @@ -2,7 +2,7 @@ module PGF.ByteCode(Literal(..), CodeLabel, Instr(..), IVal(..), TailInfo(..), ppLit, ppCode, ppInstr ) where - +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF.CId import Text.PrettyPrint diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs index 331a69d90..d015f18e0 100644 --- a/src/runtime/haskell/PGF/Expr.hs +++ b/src/runtime/haskell/PGF/Expr.hs @@ -2,7 +2,7 @@ module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(.. readExpr, showExpr, pExpr, pBinds, ppExpr, ppPatt, pattScope,
mkAbs, unAbs,
- mkApp, unApp, unAppForm,
+ mkApp, unApp, unapply,
mkStr, unStr,
mkInt, unInt,
mkDouble, unDouble,
@@ -108,13 +108,13 @@ mkApp f es = foldl EApp (EFun f) es -- | Decomposes an expression into application of function
unApp :: Expr -> Maybe (CId,[Expr])
-unApp e = case unAppForm e of
+unApp e = case unapply e of
(EFun f,es) -> Just (f,es)
_ -> Nothing
-- | Decomposes an expression into an application of a constructor such as a constant or a metavariable
-unAppForm :: Expr -> (Expr,[Expr])
-unAppForm = extract []
+unapply :: Expr -> (Expr,[Expr])
+unapply = extract []
where
extract es f@(EFun _) = (f,es)
extract es (EApp e1 e2) = extract (e2:es) e1
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs index de175616c..3fc7a5804 100644 --- a/src/runtime/haskell/PGF/Macros.hs +++ b/src/runtime/haskell/PGF/Macros.hs @@ -1,4 +1,5 @@ module PGF.Macros where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF.CId import PGF.Data diff --git a/src/runtime/haskell/PGF/Optimize.hs b/src/runtime/haskell/PGF/Optimize.hs index 8739c8665..6e7f51fb2 100644 --- a/src/runtime/haskell/PGF/Optimize.hs +++ b/src/runtime/haskell/PGF/Optimize.hs @@ -21,6 +21,7 @@ import qualified Data.IntMap as IntMap import qualified PGF.TrieMap as TrieMap import qualified Data.List as List import Control.Monad.ST +import Debug.Trace optimizePGF :: PGF -> PGF optimizePGF pgf = pgf{concretes=fmap (updateConcrete (abstract pgf) . @@ -178,26 +179,26 @@ topDownFilter startCat cnc = bottomUpFilter :: Concr -> Concr -bottomUpFilter cnc = cnc{productions=filterProductions IntMap.empty IntSet.empty (productions cnc)} +bottomUpFilter cnc = cnc{productions=filterProductions IntMap.empty (productions cnc)} -filterProductions prods0 hoc0 prods +filterProductions prods0 prods | prods0 == prods1 = prods0 - | otherwise = filterProductions prods1 hoc1 prods + | otherwise = filterProductions prods1 prods where - (prods1,hoc1) = IntMap.foldWithKey foldProdSet (IntMap.empty,IntSet.empty) prods + prods1 = IntMap.foldWithKey foldProdSet IntMap.empty prods + hoc = IntMap.fold (\set !hoc -> Set.fold accumHOC hoc set) IntSet.empty prods - foldProdSet fid set (!prods,!hoc) - | Set.null set1 = (prods,hoc) - | otherwise = (IntMap.insert fid set1 prods,hoc1) + foldProdSet fid set !prods + | Set.null set1 = prods + | otherwise = IntMap.insert fid set1 prods where set1 = Set.filter filterRule set - hoc1 = Set.fold accumHOC hoc set1 filterRule (PApply funid args) = all (\(PArg _ fid) -> isLive fid) args filterRule (PCoerce fid) = isLive fid filterRule _ = True - isLive fid = isPredefFId fid || IntMap.member fid prods0 || IntSet.member fid hoc0 + isLive fid = isPredefFId fid || IntMap.member fid prods0 || IntSet.member fid hoc accumHOC (PApply funid args) hoc = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc (_,fid) -> IntSet.insert fid hoc) hoc hypos) hoc args accumHOC _ hoc = hoc @@ -241,7 +242,7 @@ splitLexicalRules cnc p_prods = seq2prefix (SymALL_CAPIT :syms) = TrieMap.fromList [wf ["&|"]] updateConcrete abs cnc = - let p_prods0 = filterProductions IntMap.empty IntSet.empty (productions cnc) + let p_prods0 = filterProductions IntMap.empty (productions cnc) (lex,p_prods) = splitLexicalRules cnc p_prods0 l_prods = linIndex cnc p_prods0 in cnc{pproductions = p_prods, lproductions = l_prods, lexicon = lex} diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs index 43c270b13..07e94f866 100644 --- a/src/runtime/haskell/PGF/Printer.hs +++ b/src/runtime/haskell/PGF/Printer.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} module PGF.Printer (ppPGF,ppCat,ppFId,ppFunId,ppSeqId,ppSeq,ppFun) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF.CId import PGF.Data diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs index 5d884fafe..520eb59c3 100644 --- a/src/runtime/haskell/PGF/VisualizeTree.hs +++ b/src/runtime/haskell/PGF/VisualizeTree.hs @@ -23,6 +23,7 @@ module PGF.VisualizeTree , gizaAlignment , conlls2latexDoc ) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF.CId (wildCId,showCId,ppCId,mkCId) --CId,pCId, import PGF.Data diff --git a/src/runtime/java/jni_utils.c b/src/runtime/java/jni_utils.c index 59c4a7e54..93367bf37 100644 --- a/src/runtime/java/jni_utils.c +++ b/src/runtime/java/jni_utils.c @@ -1,6 +1,8 @@ #include <jni.h> #include <gu/utf8.h> #include <gu/string.h> +#include <pgf/pgf.h> +#include <pgf/linearizer.h> #include "jni_utils.h" #ifndef __MINGW32__ #include <alloca.h> @@ -34,16 +36,48 @@ gu2j_string(JNIEnv *env, GuString s) { } JPGF_INTERNAL jstring +gu2j_string_len(JNIEnv *env, const char* s, size_t len) { + const char* utf8 = s; + + jchar* utf16 = alloca(len*sizeof(jchar)); + jchar* dst = utf16; + while (s-utf8 < len) { + GuUCS ucs = gu_utf8_decode((const uint8_t**) &s); + + if (ucs <= 0xFFFF) { + *dst++ = ucs; + } else { + ucs -= 0x10000; + *dst++ = 0xD800+((ucs >> 10) & 0x3FF); + *dst++ = 0xDC00+(ucs & 0x3FF); + } + } + + return (*env)->NewString(env, utf16, dst-utf16); +} + +JPGF_INTERNAL jstring gu2j_string_buf(JNIEnv *env, GuStringBuf* sbuf) { - const char* s = gu_string_buf_data(sbuf); + return gu2j_string_len(env, gu_string_buf_data(sbuf), gu_string_buf_length(sbuf)); +} + +JPGF_INTERNAL jstring +gu2j_string_capit(JNIEnv *env, GuString s, PgfCapitState capit) { const char* utf8 = s; - size_t len = gu_string_buf_length(sbuf); + size_t len = strlen(s); jchar* utf16 = alloca(len*sizeof(jchar)); jchar* dst = utf16; while (s-utf8 < len) { GuUCS ucs = gu_utf8_decode((const uint8_t**) &s); + if (capit == PGF_CAPIT_FIRST) { + ucs = gu_ucs_to_upper(ucs); + capit = PGF_CAPIT_NONE; + } else if (capit == PGF_CAPIT_NEXT) { + ucs = gu_ucs_to_upper(ucs); + } + if (ucs <= 0xFFFF) { *dst++ = ucs; } else { diff --git a/src/runtime/java/jni_utils.h b/src/runtime/java/jni_utils.h index f2d050092..b69372979 100644 --- a/src/runtime/java/jni_utils.h +++ b/src/runtime/java/jni_utils.h @@ -21,8 +21,14 @@ JPGF_INTERNAL_DECL jstring gu2j_string(JNIEnv *env, GuString s); JPGF_INTERNAL_DECL jstring +gu2j_string_len(JNIEnv *env, const char* s, size_t len); + +JPGF_INTERNAL_DECL jstring gu2j_string_buf(JNIEnv *env, GuStringBuf* sbuf); +JPGF_INTERNAL jstring +gu2j_string_capit(JNIEnv *env, GuString s, PgfCapitState capit); + JPGF_INTERNAL_DECL GuString j2gu_string(JNIEnv *env, jstring s, GuPool* pool); diff --git a/src/runtime/java/jpgf.c b/src/runtime/java/jpgf.c index db662f5c2..bdfdc8e8c 100644 --- a/src/runtime/java/jpgf.c +++ b/src/runtime/java/jpgf.c @@ -188,7 +188,7 @@ Java_org_grammaticalframework_pgf_PGF_getFunctionProb(JNIEnv* env, jobject self, PgfPGF* pgf = get_ref(env, self); GuPool* tmp_pool = gu_local_pool(); PgfCId id = j2gu_string(env, jid, tmp_pool); - double prob = pgf_function_prob(pgf, id); + prob_t prob = pgf_function_prob(pgf, id); gu_pool_free(tmp_pool); return prob; @@ -508,7 +508,7 @@ jpgf_literal_callback_match(PgfLiteralCallback* self, PgfConcr* concr, size_t len = gu_string_buf_length(sbuf); GuIn* in = gu_data_in((uint8_t*) str, len, tmp_pool); - ep->expr = pgf_read_expr(in, out_pool, err); + ep->expr = pgf_read_expr(in, out_pool, tmp_pool, err); if (!gu_ok(err) || gu_variant_is_null(ep->expr)) { throw_string_exception(env, "org/grammaticalframework/pgf/PGFError", "The expression cannot be parsed"); gu_pool_free(tmp_pool); @@ -591,6 +591,30 @@ JNIEXPORT void JNICALL Java_org_grammaticalframework_pgf_Parser_addLiteralCallba j2gu_string(env, jcat, pool), &callback->callback); } +static void +throw_parse_error(JNIEnv *env, PgfParseError* err) +{ + jstring jtoken; + if (err->incomplete) + jtoken = NULL; + else { + jtoken = gu2j_string_len(env, err->token_ptr, err->token_len); + if (!jtoken) + return; + } + + jclass exception_class = (*env)->FindClass(env, "org/grammaticalframework/pgf/ParseError"); + if (!exception_class) + return; + jmethodID constrId = (*env)->GetMethodID(env, exception_class, "<init>", "(Ljava/lang/String;IZ)V"); + if (!constrId) + return; + jobject exception = (*env)->NewObject(env, exception_class, constrId, jtoken, err->offset, err->incomplete); + if (!exception) + return; + (*env)->Throw(env, exception); +} + JNIEXPORT jobject JNICALL Java_org_grammaticalframework_pgf_Parser_parseWithHeuristics (JNIEnv* env, jclass clazz, jobject jconcr, jstring jstartCat, jstring js, jdouble heuristics, jlong callbacksRef, jobject jpool) @@ -615,8 +639,7 @@ Java_org_grammaticalframework_pgf_Parser_parseWithHeuristics GuString msg = (GuString) gu_exn_caught_data(parse_err); throw_string_exception(env, "org/grammaticalframework/pgf/PGFError", msg); } else if (gu_exn_caught(parse_err, PgfParseError)) { - GuString tok = (GuString) gu_exn_caught_data(parse_err); - throw_string_exception(env, "org/grammaticalframework/pgf/ParseError", tok); + throw_parse_error(env, (PgfParseError*) gu_exn_caught_data(parse_err)); } gu_pool_free(out_pool); @@ -656,8 +679,7 @@ Java_org_grammaticalframework_pgf_Completer_complete(JNIEnv* env, jclass clazz, GuString msg = (GuString) gu_exn_caught_data(parse_err); throw_string_exception(env, "org/grammaticalframework/pgf/PGFError", msg); } else if (gu_exn_caught(parse_err, PgfParseError)) { - GuString tok = (GuString) gu_exn_caught_data(parse_err); - throw_string_exception(env, "org/grammaticalframework/pgf/ParseError", tok); + throw_parse_error(env, (PgfParseError*) gu_exn_caught_data(parse_err)); } gu_pool_free(pool); @@ -709,8 +731,8 @@ Java_org_grammaticalframework_pgf_TokenIterator_fetchTokenProb(JNIEnv* env, jcla return NULL; jclass tp_class = (*env)->FindClass(env, "org/grammaticalframework/pgf/TokenProb"); - jmethodID tp_constrId = (*env)->GetMethodID(env, tp_class, "<init>", "(DLjava/lang/String;Ljava/lang/String;)V"); - jobject jtp = (*env)->NewObject(env, tp_class, tp_constrId, tp->prob, gu2j_string(env,tp->tok), gu2j_string(env,tp->cat)); + jmethodID tp_constrId = (*env)->GetMethodID(env, tp_class, "<init>", "(DLjava/lang/String;Ljava/lang/String;Ljava/lang/String;)V"); + jobject jtp = (*env)->NewObject(env, tp_class, tp_constrId, (double) tp->prob, gu2j_string(env,tp->tok), gu2j_string(env,tp->cat), gu2j_string(env,tp->fun)); return jtp; } @@ -908,6 +930,9 @@ typedef struct { GuPool* tmp_pool; GuBuf* stack; GuBuf* list; + bool bind; + PgfCapitState capit; + jobject bind_instance; jclass object_class; jclass bracket_class; jmethodID bracket_constrId; @@ -919,12 +944,27 @@ pgf_bracket_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok) PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); JNIEnv* env = state->env; - jstring jname = gu2j_string(env, tok); - gu_buf_push(state->list, jobject, jname); + if (state->bind) { + jobject bind_instance = (*env)->NewLocalRef(env, state->bind_instance); + gu_buf_push(state->list, jobject, bind_instance); + state->bind = false; + } else { + if (state->capit == PGF_CAPIT_NEXT) + state->capit = PGF_CAPIT_NONE; + } + + if (state->capit == PGF_CAPIT_ALL) + state->capit = PGF_CAPIT_NEXT; + + jstring jtok = gu2j_string_capit(env, tok, state->capit); + gu_buf_push(state->list, jobject, jtok); + + if (state->capit == PGF_CAPIT_FIRST) + state->capit = PGF_CAPIT_NONE; } static void -pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); @@ -933,7 +973,7 @@ pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int linde } static void -pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); JNIEnv* env = state->env; @@ -972,6 +1012,20 @@ pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, } static void +pgf_bracket_lzn_symbol_bind(PgfLinFuncs** funcs) +{ + PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); + state->bind = true; +} + +static void +pgf_bracket_lzn_symbol_capit(PgfLinFuncs** funcs, PgfCapitState capit) +{ + PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); + state->capit = capit; +} + +static void pgf_bracket_lzn_symbol_meta(PgfLinFuncs** funcs, PgfMetaId id) { pgf_bracket_lzn_symbol_token(funcs, "?"); @@ -982,8 +1036,8 @@ static PgfLinFuncs pgf_bracket_lin_funcs = { .begin_phrase = pgf_bracket_lzn_begin_phrase, .end_phrase = pgf_bracket_lzn_end_phrase, .symbol_ne = NULL, - .symbol_bind = NULL, - .symbol_capit = NULL, + .symbol_bind = pgf_bracket_lzn_symbol_bind, + .symbol_capit = pgf_bracket_lzn_symbol_capit, .symbol_meta = pgf_bracket_lzn_symbol_meta }; @@ -1000,6 +1054,16 @@ Java_org_grammaticalframework_pgf_Concr_bracketedLinearize(JNIEnv* env, jobject jmethodID bracket_constrId = (*env)->GetMethodID(env, bracket_class, "<init>", "(Ljava/lang/String;Ljava/lang/String;II[Ljava/lang/Object;)V"); if (!bracket_constrId) return NULL; + + jclass bind_class = (*env)->FindClass(env, "org/grammaticalframework/pgf/BIND"); + if (!bind_class) + return NULL; + jfieldID bind_instance_id = (*env)->GetStaticFieldID(env, bind_class, "instance", "Lorg/grammaticalframework/pgf/BIND;"); + if (!bind_instance_id) + return NULL; + jobject bind_instance = (*env)->GetStaticObjectField(env, bind_class, bind_instance_id); + if (!bind_instance) + return NULL; GuPool* tmp_pool = gu_local_pool(); GuExn* err = gu_exn(tmp_pool); @@ -1034,6 +1098,9 @@ Java_org_grammaticalframework_pgf_Concr_bracketedLinearize(JNIEnv* env, jobject state.tmp_pool = tmp_pool; state.stack = gu_new_buf(GuBuf*, tmp_pool); state.list = gu_new_buf(jobject, tmp_pool); + state.bind = true; + state.capit = PGF_CAPIT_NONE; + state.bind_instance = bind_instance; state.object_class = object_class; state.bracket_class = bracket_class; state.bracket_constrId = bracket_constrId; @@ -1277,7 +1344,7 @@ Java_org_grammaticalframework_pgf_Expr_readExpr(JNIEnv* env, jclass clazz, jstri GuIn* in = gu_data_in((uint8_t*) buf, strlen(buf), tmp_pool); GuExn* err = gu_exn(tmp_pool); - PgfExpr e = pgf_read_expr(in, pool, err); + PgfExpr e = pgf_read_expr(in, pool, tmp_pool, err); if (!gu_ok(err) || gu_variant_is_null(e)) { throw_string_exception(env, "org/grammaticalframework/pgf/PGFError", "The expression cannot be parsed"); gu_pool_free(tmp_pool); @@ -1553,6 +1620,13 @@ Java_org_grammaticalframework_pgf_Expr_hashCode(JNIEnv* env, jobject self) return pgf_expr_hash(0, e); } +JNIEXPORT jint JNICALL +Java_org_grammaticalframework_pgf_Expr_size(JNIEnv* env, jobject self) +{ + PgfExpr e = gu_variant_from_ptr(l2p(get_ref(env, self))); + return pgf_expr_size(e); +} + JNIEXPORT jstring JNICALL Java_org_grammaticalframework_pgf_Type_getCategory(JNIEnv* env, jobject self) { @@ -1589,7 +1663,7 @@ Java_org_grammaticalframework_pgf_Type_readType(JNIEnv* env, jclass clazz, jstri GuIn* in = gu_data_in((uint8_t*) buf, strlen(buf), tmp_pool); GuExn* err = gu_exn(tmp_pool); - PgfType* ty = pgf_read_type(in, pool, err); + PgfType* ty = pgf_read_type(in, pool, tmp_pool, err); if (!gu_ok(err)) { throw_string_exception(env, "org/grammaticalframework/pgf/PGFError", "The type cannot be parsed"); gu_pool_free(tmp_pool); diff --git a/src/runtime/java/jsg.c b/src/runtime/java/jsg.c index 61ee2488e..9419ac127 100644 --- a/src/runtime/java/jsg.c +++ b/src/runtime/java/jsg.c @@ -1,6 +1,7 @@ #include <jni.h> #include <sg/sg.h> #include <pgf/expr.h> +#include <pgf/linearizer.h> #include "jni_utils.h" JNIEXPORT jobject JNICALL diff --git a/src/runtime/java/org/grammaticalframework/pgf/BIND.java b/src/runtime/java/org/grammaticalframework/pgf/BIND.java new file mode 100644 index 000000000..5cbbe4ce5 --- /dev/null +++ b/src/runtime/java/org/grammaticalframework/pgf/BIND.java @@ -0,0 +1,8 @@ +package org.grammaticalframework.pgf; + +public class BIND { + private BIND() { + } + + public static final BIND instance = new BIND(); +} diff --git a/src/runtime/java/org/grammaticalframework/pgf/Expr.java b/src/runtime/java/org/grammaticalframework/pgf/Expr.java index 40655cbcb..db0876bf8 100644 --- a/src/runtime/java/org/grammaticalframework/pgf/Expr.java +++ b/src/runtime/java/org/grammaticalframework/pgf/Expr.java @@ -108,6 +108,9 @@ public class Expr implements Serializable { return showExpr(ref); } + /** Computes the number of functions in the expression */ + public native int size(); + /** Reads a string in the GF syntax for abstract expressions * and returns an object representing the expression. */ public static native Expr readExpr(String s) throws PGFError; diff --git a/src/runtime/java/org/grammaticalframework/pgf/ParseError.java b/src/runtime/java/org/grammaticalframework/pgf/ParseError.java index 7fd332708..8b3f51ae2 100644 --- a/src/runtime/java/org/grammaticalframework/pgf/ParseError.java +++ b/src/runtime/java/org/grammaticalframework/pgf/ParseError.java @@ -4,11 +4,26 @@ package org.grammaticalframework.pgf; public class ParseError extends Exception { private static final long serialVersionUID = -6086991674218306569L; - public ParseError(String token) { - super(token); + private String token; + private int offset; + private boolean incomplete; + + public ParseError(String token, int offset, boolean incomplete) { + super(incomplete ? "The sentence is incomplete" : "Unexpected token: \""+token+"\""); + this.token = token; + this.offset = offset; + this.incomplete = incomplete; } - + public String getToken() { - return getMessage(); + return token; + } + + public int getOffset() { + return offset; + } + + public boolean isIncomplete() { + return incomplete; } } diff --git a/src/runtime/java/org/grammaticalframework/pgf/TokenProb.java b/src/runtime/java/org/grammaticalframework/pgf/TokenProb.java index 2c4ce4447..36db54273 100644 --- a/src/runtime/java/org/grammaticalframework/pgf/TokenProb.java +++ b/src/runtime/java/org/grammaticalframework/pgf/TokenProb.java @@ -4,12 +4,14 @@ package org.grammaticalframework.pgf; public class TokenProb { private String tok; private String cat; + private String fun; private double prob; - public TokenProb(double prob, String tok, String cat) { + public TokenProb(double prob, String tok, String cat, String fun) { this.prob = prob; this.tok = tok; - this.cat = cat; + this.cat = cat; + this.fun = fun; } /** Returns the negative logarithmic probability. */ @@ -26,4 +28,9 @@ public class TokenProb { public String getCategory() { return cat; } + + /** Returns the function from which this word was predicted. */ + public String getFunction() { + return fun; + } } diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c index 7da62e453..a2f77aa42 100644 --- a/src/runtime/python/pypgf.c +++ b/src/runtime/python/pypgf.c @@ -1163,7 +1163,10 @@ Iter_fetch_token(IterObject* self) PyObject* py_tok = PyString_FromString(tp->tok); PyObject* py_cat = PyString_FromString(tp->cat); - PyObject* res = Py_BuildValue("(f,O,O)", tp->prob, py_tok, py_cat); + PyObject* py_fun = PyString_FromString(tp->fun); + PyObject* res = Py_BuildValue("(f,O,O,O)", tp->prob, py_tok, py_cat, py_fun); + Py_DECREF(py_fun); + Py_DECREF(py_cat); Py_DECREF(py_tok); return res; @@ -1391,7 +1394,7 @@ pypgf_literal_callback_match(PgfLiteralCallback* self, PgfConcr* concr, gu_string_buf_length(sbuf), tmp_pool); - ep->expr = pgf_read_expr(in, out_pool, err); + ep->expr = pgf_read_expr(in, out_pool, tmp_pool, err); if (!gu_ok(err) || gu_variant_is_null(ep->expr)) { PyErr_SetString(PGFError, "The expression cannot be parsed"); gu_pool_free(tmp_pool); @@ -1545,13 +1548,28 @@ Concr_parse(ConcrObject* self, PyObject *args, PyObject *keywds) GuString msg = (GuString) gu_exn_caught_data(parse_err); PyErr_SetString(PGFError, msg); } else if (gu_exn_caught(parse_err, PgfParseError)) { - GuString tok = (GuString) gu_exn_caught_data(parse_err); - PyObject* py_tok = PyString_FromString(tok); - PyObject_SetAttrString(ParseError, "token", py_tok); - PyErr_Format(ParseError, "Unexpected token: \"%s\"", tok); - Py_DECREF(py_tok); + PgfParseError* err = (PgfParseError*) gu_exn_caught_data(parse_err); + PyObject* py_offset = PyInt_FromLong(err->offset); + if (err->incomplete) { + PyObject_SetAttrString(ParseError, "incomplete", Py_True); + PyObject_SetAttrString(ParseError, "offset", py_offset); + PyErr_Format(ParseError, "The sentence is incomplete"); + } else { + PyObject* py_tok = PyString_FromStringAndSize(err->token_ptr, + err->token_len); + PyObject_SetAttrString(ParseError, "incomplete", Py_False); + PyObject_SetAttrString(ParseError, "offset", py_offset); + PyObject_SetAttrString(ParseError, "token", py_tok); +#if PY_MAJOR_VERSION >= 3 + PyErr_Format(ParseError, "Unexpected token: \"%U\"", py_tok); +#else + PyErr_Format(ParseError, "Unexpected token: \"%s\"", PyString_AsString(py_tok)); +#endif + Py_DECREF(py_tok); + } + Py_DECREF(py_offset); } - + Py_DECREF(pyres); pyres = NULL; } @@ -2057,7 +2075,7 @@ pgf_bracket_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok) } static void -pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); @@ -2066,7 +2084,7 @@ pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int linde } static void -pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); @@ -2601,6 +2619,24 @@ PGF_dealloc(PGFObject* self) Py_TYPE(self)->tp_free((PyObject*)self); } +static PyObject * +PGF_repr(PGFObject *self) +{ + GuPool* tmp_pool = gu_local_pool(); + + GuExn* err = gu_exn(tmp_pool); + GuStringBuf* sbuf = gu_new_string_buf(tmp_pool); + GuOut* out = gu_string_buf_out(sbuf); + + pgf_print(self->pgf, out, err); + + PyObject* pystr = PyString_FromStringAndSize(gu_string_buf_data(sbuf), + gu_string_buf_length(sbuf)); + + gu_pool_free(tmp_pool); + return pystr; +} + static PyObject* PGF_getAbstractName(PGFObject *self, void *closure) { @@ -3221,7 +3257,7 @@ static PyTypeObject pgf_PGFType = { 0, /*tp_as_mapping*/ 0, /*tp_hash */ 0, /*tp_call*/ - 0, /*tp_str*/ + (reprfunc) PGF_repr, /*tp_str*/ 0, /*tp_getattro*/ 0, /*tp_setattro*/ 0, /*tp_as_buffer*/ @@ -3295,7 +3331,7 @@ pgf_readExpr(PyObject *self, PyObject *args) { GuExn* err = gu_new_exn(tmp_pool); pyexpr->pool = gu_new_pool(); - pyexpr->expr = pgf_read_expr(in, pyexpr->pool, err); + pyexpr->expr = pgf_read_expr(in, pyexpr->pool, tmp_pool, err); pyexpr->master = NULL; if (!gu_ok(err) || gu_variant_is_null(pyexpr->expr)) { @@ -3325,7 +3361,7 @@ pgf_readType(PyObject *self, PyObject *args) { GuExn* err = gu_new_exn(tmp_pool); pytype->pool = gu_new_pool(); - pytype->type = pgf_read_type(in, pytype->pool, err); + pytype->type = pgf_read_type(in, pytype->pool, tmp_pool, err); pytype->master = NULL; if (!gu_ok(err) || pytype->type == NULL) { diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index b1020b4b8..020349fbb 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -191,10 +191,11 @@ cpgfMain qsem command (t,(pgf,pc)) = -- Without caching parse results: parse' start mlimit ((from,concr),input) = - return $ maybe id take mlimit . drop start # cparse + case C.parseWithHeuristics concr cat input (-1) callbacks of + C.ParseOk ts -> return (Right (maybe id take mlimit (drop start ts))) + C.ParseFailed _ tok -> return (Left tok) + C.ParseIncomplete -> return (Left "") where - --cparse = C.parse concr cat input - cparse = C.parseWithHeuristics concr cat input (-1) callbacks callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.literalCallbacks cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs] {- @@ -277,8 +278,9 @@ cpgfMain qsem command (t,(pgf,pc)) = | isUpper c -> toLower c : cs s -> s - parse1 = either (const Nothing) (fmap fst . listToMaybe) . - C.parse concr cat + parse1 s = case C.parse concr cat s of + C.ParseOk ((t,_):ts) -> Just t + _ -> Nothing morph w = listToMaybe [t | (f,a,p)<-C.lookupMorpho concr w, t<-maybeToList (C.readExpr f)] @@ -661,19 +663,16 @@ doComplete pgf (mfrom,input) mcat mlimit full = showJSON froms = maybe (PGF.languages pgf) (:[]) mfrom cat = fromMaybe (PGF.startCat pgf) mcat -completionInfo :: PGF -> PGF.Token -> PGF.ParseState -> JSValue -completionInfo pgf token pstate = +completionInfo :: PGF -> PGF.Token -> [PGF.CId] -> JSValue +completionInfo pgf token funs = makeObj ["token".= token - ,"funs" .= (map mkFun (nubBy ignoreFunIds funs)) + ,"funs" .= map mkFun (nub funs) ] where - contInfo = PGF.getContinuationInfo pstate - funs = snd . head $ Map.toList contInfo -- always get [([],_)] ; funs :: [(fid,cid,seq)] - ignoreFunIds (_,cid1,seq1) (_,cid2,seq2) = (cid1,seq1) == (cid2,seq2) - mkFun (funid,cid,seq) = case PGF.functionType pgf cid of + mkFun cid = case PGF.functionType pgf cid of Just typ -> - makeObj [ {-"fid".=funid,-} "fun".=cid, "hyps".=hyps', "cat".=cat, "seq".=seq ] + makeObj [ {-"fid".=funid,-} "fun".=cid, "hyps".=hyps', "cat".=cat ] where (hyps,cat,_es) = PGF.unType typ hyps' = [ PGF.showType [] typ | (_,_,typ) <- hyps ] @@ -991,28 +990,17 @@ parse' pgf input mcat mfrom = cat = fromMaybe (PGF.startCat pgf) mcat complete' :: PGF -> PGF.Language -> PGF.Type -> Maybe Int -> String - -> (PGF.BracketedString, String, Map.Map PGF.Token PGF.ParseState) + -> (PGF.BracketedString, String, Map.Map PGF.Token [PGF.CId]) complete' pgf from typ mlimit input = let (ws,prefix) = tokensAndPrefix input - ps0 = PGF.initState pgf from typ - (ps,ws') = loop ps0 ws - bs = snd (PGF.getParseOutput ps typ Nothing) - in if not (null ws') - then (bs, unwords (if null prefix then ws' else ws'++[prefix]), Map.empty) - else (bs, prefix, PGF.getCompletions ps prefix) + in PGF.complete pgf from typ (unwords ws) prefix where - --order = sortBy (compare `on` map toLower) - tokensAndPrefix :: String -> ([String],String) tokensAndPrefix s | not (null s) && isSpace (last s) = (ws, "") | null ws = ([],"") | otherwise = (init ws, last ws) where ws = words s - loop ps [] = (ps,[]) - loop ps (w:ws) = case PGF.nextState ps (PGF.simpleParseInput w) of - Left es -> (ps,w:ws) - Right ps -> loop ps ws transfer lang = if "LaTeX" `isSuffixOf` show lang then fold -- OpenMath LaTeX transfer diff --git a/src/tools/gf-tools.cabal b/src/tools/gf-tools.cabal index 4222ae372..47ce0f01c 100644 --- a/src/tools/gf-tools.cabal +++ b/src/tools/gf-tools.cabal @@ -10,3 +10,22 @@ Executable gfdoc Executable htmls main-is: Htmls.hs build-depends: base + + +library + hs-source-dirs: gftest + exposed-modules: Grammar + other-modules: Mu, Graph, FMap, EqRel + build-depends: base + , containers + , pgf2 + +executable gftest + hs-source-dirs: gftest + main-is: Main.hs + build-depends: base + , pgf2 + , cmdargs + , containers + , filepath + , gf-tools
\ No newline at end of file diff --git a/src/tools/gftest/EqRel.hs b/src/tools/gftest/EqRel.hs new file mode 100644 index 000000000..823900ae0 --- /dev/null +++ b/src/tools/gftest/EqRel.hs @@ -0,0 +1,32 @@ +module EqRel where + +import qualified Data.Map as M +import Data.List ( sort ) + +data EqRel a = Top | Classes [[a]] deriving (Eq,Ord,Show) + +(/\) :: (Ord a) => EqRel a -> EqRel a -> EqRel a +Top /\ r = r +r /\ Top = r +Classes xss /\ Classes yss = Classes $ sort $ map sort $ concat -- maybe throw away singleton lists? + [ M.elems tabXs + | xs <- xss + , let tabXs = M.fromListWith (++) + [ (tabYs M.! x, [x]) + | x <- xs ] + ] + + where + tabYs = M.fromList [ (y,representative) + | ys <- yss + , let representative = head ys + , y <- ys ] + +basic :: (Ord a) => [a] -> EqRel Int +basic xs = Classes $ sort $ map sort $ M.elems $ M.fromListWith (++) + [ (x,[i]) | (x,i) <- zip xs [0..] ] + +rep :: EqRel Int -> Int -> Int +rep Top j = 0 +rep (Classes xss) j = head [ head xs | xs <- xss, j `elem` xs ] + diff --git a/src/tools/gftest/FMap.hs b/src/tools/gftest/FMap.hs new file mode 100644 index 000000000..f3a511706 --- /dev/null +++ b/src/tools/gftest/FMap.hs @@ -0,0 +1,62 @@ +module FMap where + +-------------------------------------------------------------------------------- +-- implementation + +data FMap a b = Ask a (FMap a b) (FMap a b) | Nil | Answer b + deriving ( Eq, Ord, Show ) + +toList :: FMap a b -> [([a],b)] +toList t = go [([],t)] + where + go [] = [] + go ((xs,Ask x yes no):xts) = go ((x:xs,yes):(xs,no):xts) + go ((_ ,Nil) :xts) = go xts + go ((xs,Answer z) :xts) = (reverse xs,z) : go xts + +isNil :: FMap a b -> Bool +isNil = null . toList + +nil :: FMap a b +nil = Nil + +unit :: [a] -> b -> FMap a b +unit [] y = Answer y +unit (x:xs) y = Ask x (unit xs y) Nil + +covers :: Ord a => FMap a b -> [a] -> Bool +Nil `covers` _ = False +_ `covers` [] = True +Answer _ `covers` _ = False +Ask x yes no `covers` zs@(y:ys) = + case x `compare` y of + LT -> (yes `covers` zs) || (no `covers` zs) + EQ -> yes `covers` ys + GT -> False + +ask :: a -> FMap a b -> FMap a b -> FMap a b +ask x Nil Nil = Nil +ask x s t = Ask x s t + +del :: Ord a => [a] -> FMap a b -> FMap a b +del _ Nil = Nil +del _ (Answer _) = Nil +del [] (Ask x yes no) = ask x yes (del [] no) +del (x:xs) t@(Ask y yes no) = + case x `compare` y of + LT -> del xs t + EQ -> ask y (del xs yes) (del xs no) + GT -> ask y yes (del (x:xs) no) + +add :: Ord a => [a] -> b -> FMap a b -> FMap a b +add [] y Nil = Answer y +add (x:xs) y Nil = Ask x (add xs y Nil) Nil +add xs@(_:_) y (Answer _) = add xs y Nil +add (x:xs) y t@(Ask z yes no) = + case x `compare` z of + LT -> Ask x (add xs y Nil) (del xs t) + EQ -> Ask x (add xs y yes) (del xs no) + GT -> Ask z yes (add (x:xs) y no) + +-------------------------------------------------------------------------------- + diff --git a/src/tools/gftest/Grammar.hs b/src/tools/gftest/Grammar.hs new file mode 100644 index 000000000..f8333e78b --- /dev/null +++ b/src/tools/gftest/Grammar.hs @@ -0,0 +1,1091 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + +module Grammar + ( Grammar(..), readGrammar + , Tree, top, Symbol(..), showTree + , Cat, ConcrCat(..) + , Lang, Name + + -- Categories, coercions + , ccats, ccatOf, arity + , coerces, uncoerce + , uncoerceAbsCat + + -- Testing and comparison + , testTree, testFun + , compareTree, Comparison(..) + , treesUsingFun + + -- Contexts + , contextsFor + + -- FEAT + , featIth, featCard + + -- Fields + , forgets, reachableFieldsFromTop + , emptyFields, equalFields, fieldNames + + -- misc + , showConcrFun, subTree, flatten + , diffCats, hasConcrString +) where + +import Data.Either ( lefts ) +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Char +import qualified Data.Set as S +import qualified Mu +import qualified FMap as F +import qualified Data.Tree as T +import EqRel + +import GHC.Exts ( the ) +import Debug.Trace + +import qualified PGF2 +import qualified PGF2.Internal as I + +-------------------------------------------------------------------------------- +-- grammar types + +-- name + +type Name = String + +-- concrete category + +type Cat = PGF2.Cat -- i.e. String + +data ConcrCat = CC (Maybe Cat) I.FId -- i.e. Int + deriving ( Eq ) + +instance Show ConcrCat where + show (CC (Just cat) fid) = cat ++ "_" ++ show fid + show (CC Nothing fid) = "_" ++ show fid + +instance Ord ConcrCat where + (CC _ fid1) `compare` (CC _ fid2) = fid1 `compare` fid2 + +ccatOf :: Tree -> ConcrCat +ccatOf (App tp _) = snd (ctyp tp) + +-- tree + +data RoseTree a + = App { top :: a, args :: [RoseTree a] } + deriving ( Eq, Ord ) + +-- from http://hackage.haskell.org/package/containers-0.5.11.0/docs/src/Data.Tree.html#foldTree +foldTree :: (a -> [b] -> b) -> RoseTree a -> b +foldTree f = go where + go (App x ts) = f x (map go ts) + +flatten :: RoseTree a -> [a] +flatten (App tp as) = tp : concatMap flatten as + +type Tree = RoseTree Symbol +type AmbTree = RoseTree [Symbol] -- used as an intermediate category for parsing + +instance Show Tree where + show = showTree + +showTree :: Tree -> String +showTree (App a []) = show a +showTree (App f xs) = unwords (show f : map showTreeArg xs) + where showTreeArg (App a []) = show a + showTreeArg t = "(" ++ showTree t ++ ")" + +subTree :: Symbol -> Tree -> Maybe Tree +subTree symb t@(App tp tr) + | symb==tp = Just t + | otherwise = listToMaybe $ mapMaybe (subTree symb) tr + +-- symbol + +type SeqId = Int + +data Symbol + = Symbol + { name :: Name + , seqs :: [SeqId] + , typ :: ([Cat], Cat) + , ctyp :: ([ConcrCat],ConcrCat) + } + deriving ( Eq, Ord ) + +instance Show Symbol where + show = name + +arity :: Symbol -> Int +arity = length . fst . ctyp + +hole :: ConcrCat -> Symbol +hole c = Symbol (show c) [] ([], "") ([],c) + +showConcrFun :: Grammar -> Symbol -> String +showConcrFun gr detCN = show detCN ++ " : " ++ args ++ show np_209 + where + (dets_cns,np_209) = ctyp detCN + args = concatMap (\x -> show x ++ " → ") dets_cns + +-- grammar + +type Lang = String + +data Grammar + = Grammar + { + concrLang :: Lang + , parse :: String -> [Tree] + , readTree :: String -> Tree + , linearize :: Tree -> String + , tabularLin :: Tree -> [(String,String)] + , concrCats :: [(PGF2.Cat,I.FId,I.FId,[String])] + , coercions :: [(ConcrCat,ConcrCat)] + , contextsTab :: M.Map ConcrCat (M.Map ConcrCat [Tree -> Tree]) + , startCat :: Cat + , symbols :: [Symbol] + , lookupSymbol :: String -> [Symbol] + , functionsByCat :: Cat -> [Symbol] + , concrSeqs :: SeqId -> [Either String (Int,Int)] + , feat :: FEAT + , nonEmptyCats :: S.Set ConcrCat + , allCats :: [ConcrCat] + } + +fieldNames :: Grammar -> Cat -> [String] +fieldNames gr c = map fst . tabularLin gr $ t + where + t:_ = [ t + | f <- functionsByCat gr c + , let (_,c') = ctyp f + , c' `S.member` nonEmptyCats gr + , t <- featAll gr c' + ] + + +-------------------------------------------------------------------------------- +-- grammar + +readGrammar :: Lang -> FilePath -> IO Grammar +readGrammar lang file = + do pgf <- PGF2.readPGF file + return (toGrammar pgf lang) + +toGrammar :: PGF2.PGF -> Lang -> Grammar +toGrammar pgf langName = + let gr = + Grammar + { concrLang = lname + + , parse = \s -> + case PGF2.parse lang (PGF2.startCat pgf) s of + PGF2.ParseOk es_fs -> map (mkTree gr.fst) es_fs + PGF2.ParseFailed i s -> error s + PGF2.ParseIncomplete -> error "Incomplete parse" + + , readTree = \s -> + case PGF2.readExpr s of + Just t -> mkTree gr t + Nothing -> error "readTree: no parse" + + , linearize = \t -> + PGF2.linearize lang (mkExpr t) + + , tabularLin = \t -> + PGF2.tabularLinearize lang (mkExpr t) + + , startCat = + mkCat (PGF2.startCat pgf) + + , concrCats = + I.concrCategories lang + + , symbols = + [ Symbol { + name = nm, + seqs = sqs, + ctyp = (argsCC, goalCC), + typ = (map (uncoerceAbsCat gr) argsCC, goalcat) + } + | (goalcat,bg,end,_) <- I.concrCategories lang + , goalfid <- [bg..end] + , I.PApply funId pargs <- I.concrProductions lang goalfid + , let goalCC = CC (Just goalcat) goalfid + , let argsCC = [ mkCC argfid | I.PArg _ argfid <- pargs ] + , let (nm,sqs) = I.concrFunction lang funId ] + + , lookupSymbol = lookupAll (symb2table `map` symbols gr) + + , functionsByCat = \c -> + [ symb + | symb <- symbols gr + , snd (typ symb) == c + , snd (ctyp symb) `elem` nonEmptyCats gr ] + + , coercions = + [ ( mkCC cfid, CC Nothing afid ) + | afid <- [0..I.concrTotalCats lang] + , I.PCoerce cfid <- I.concrProductions lang afid ] + + , contextsTab = + M.fromList + [ (top, M.fromList (contexts gr top)) + | top <- allCats gr ] + + , concrSeqs = + map cseq2Either . I.concrSequence lang + + , feat = + mkFEAT gr + + , allCats = S.toList $ S.fromList $ + [ a | f <- symbols gr, let (args,goal) = ctyp f + , a <- goal:args + ] ++ + [ c | (cat,coe) <- coercions gr + , c <- [coe,cat] + ] + , nonEmptyCats = S.fromList + [ c + | let -- all functions, organized by result type + funs = M.fromListWith (++) $ + [ (cat,[Right f]) + | f <- symbols gr + , let (_,cat) = ctyp f + ] ++ + [ (coe,[Left cat]) + | (cat,coe) <- coercions gr + ] + + -- all categories, with their dependencies + defs = + [ if or [ arity f == 0 | Right f <- fs ] + then (c, [], \_ -> True) -- has a word + else (c, ys, h) -- no word + | c <- allCats gr + , let -- relevant functions for c + fs = fromMaybe [] (M.lookup c funs) + + -- categories we depend on + ys = S.toList $ S.fromList $ + [ cat | Right f <- fs, cat <- fst (ctyp f) ] ++ + [ cat | Left cat <- fs ] + + -- compute if we're empty, given the emptiness of others + h bs = or $ + [ and [ tab M.! a | a <- args ] + | Right f <- fs + , let (args,_) = ctyp f + ] ++ + [ tab M.! cat + | Left cat <- fs + ] + where + tab = M.fromList (ys `zip` bs) + ] + , (c,True) <- allCats gr `zip` Mu.mu False defs (allCats gr) + ] + + + + } + in gr + where + -- language + (lang,lname) = case M.lookup langName (PGF2.languages pgf) of + Just la -> (la,langName) + Nothing -> let (defName,defGr) = head $ M.assocs $ PGF2.languages pgf + msg = "no grammar found with name " ++ langName ++ + ", using " ++ defName + in trace msg (defGr,defName) + + -- categories and expressions + mkCat tp = cat where (_, cat, _) = PGF2.unType tp + + mkExpr (App n []) | not (null s) && all isDigit s = + PGF2.mkInt (read s) + where + s = show n + + mkExpr (App f xs) = + PGF2.mkApp (name f) [ mkExpr x | x <- xs ] + + mkCC fid = CC ccat fid + where ccat = case [ cat | (cat,bg,end,_) <- I.concrCategories lang + , fid `elem` [bg..end] ] of + [] -> Nothing -- means it's coercion + xs -> Just $ the xs + + -- misc + symb2table s = (s, name s) + + cseq2Either (I.SymKS tok) = Left tok + cseq2Either (I.SymCat x y) = Right (x,y) + cseq2Either x = Left (show x) + +-- parsing and reading trees +mkTree :: Grammar -> PGF2.Expr -> Tree +mkTree gr = disambTree . ambTree + + where + ambTree t = -- :: PGF2.Expr -> AmbTree + case PGF2.unApp t of + Just (f,xs) -> App (lookupSymbol gr f) [ ambTree x | x <- xs ] + Nothing -> error (PGF2.showExpr [] t) + + disambTree at = -- :: AmbTree -> Tree + case foldTree reduce at of + App [x] ts -> App x [ disambTree t | t <- ts ] + App _ _ts -> error "mkTree: invalid tree" + + reduce fs as = -- :: [Symbol] -> [AmbTree] -> AmbTree + let red = [ symbol | symbol <- fs + , let argTypes = + uncoerce gr `map` fst (ctyp symbol) + , let goalTypes = + uncoerce gr `map` [ snd (ctyp s) | App [s] _ <- as ] + -- there should be only one symbol in (still ambiguous) fs + -- whose argument type matches its (already unambiguous) subtrees + , and [ intersect a r /= [] + | (a,r) <- zip argTypes goalTypes ] ] + in case red of + [x] -> App [x] as + _ -> App fs as + +-- categories and coercions +ccats :: Grammar -> Cat -> [ConcrCat] +ccats gr utt = [ cc + | cc@(CC (Just cat) _) <- S.toList (nonEmptyCats gr) + , cat == utt ] + +uncoerceAbsCat :: Grammar -> ConcrCat -> Cat +uncoerceAbsCat gr c = case c of + CC (Just cat) _ -> cat + CC Nothing _ -> the [ uncoerceAbsCat gr x | x <- uncoerce gr c ] + +uncoerce :: Grammar -> ConcrCat -> [ConcrCat] +uncoerce gr c = case c of + CC Nothing _ -> lookupAll (coercions gr) c + _ -> [c] + +coerces :: Grammar -> ConcrCat -> ConcrCat -> Bool +coerces gr coe cat = (cat,coe) `elem` coercions gr + +lookupAll :: (Eq a) => [(b,a)] -> a -> [b] +lookupAll kvs key = [ v | (v,k) <- kvs, k==key ] + +singleton [x] = True +singleton xs = False + +-------------------------------------------------------------------------------- +-- compute categories reachable from S + +reachableCatsFromTop :: Grammar -> ConcrCat -> [ConcrCat] +reachableCatsFromTop gr top = [ c | (c,True) <- cs `zip` rs ] + where + rs = Mu.mu False defs cs + cs = S.toList (nonEmptyCats gr) + + defs = + [ if c == top + then (c, [], \_ -> True) + else (c, ys, or) + | c <- cs + , let ys = S.toList $ S.fromList $ + [ b + | f <- symbols gr + , let (as,b) = ctyp f + , all (`S.member` nonEmptyCats gr) as + , c `elem` as + ] ++ + [ b + | (a,b) <- coercions gr + , a == c + , b `S.member` nonEmptyCats gr + ] + ] + +reachableFieldsFromTop :: Grammar -> ConcrCat -> [(ConcrCat,S.Set Int)] +reachableFieldsFromTop gr top = cs `zip` rs + where + rs = Mu.mu S.empty defs cs + cs = S.toList (nonEmptyCats gr) + + defs = + [ if c == top + then (c, [], \_ -> S.fromList [0]) -- this assumes the top only has one field + else (c, ys, h) + | c <- cs + , let fs = [ Right (f,k) + | f <- symbols gr + , let (as,_) = ctyp f + , all (`S.member` nonEmptyCats gr) as + , (a,k) <- as `zip` [0..] + , c == a + ] ++ + [ Left b + | (a,b) <- coercions gr + , a == c + , b `S.member` nonEmptyCats gr + ] + + ys = S.toList $ S.fromList + [ case f of + Right (f,_) -> snd (ctyp f) + Left b -> b + | f <- fs + ] + + h rs = S.unions + [ case f of + Right (f,k) -> apply (f,k) (args M.! snd (ctyp f)) + Left b -> args M.! b + | f <- fs + ] + where + args = M.fromList (ys `zip` rs) + ] + + apply (f,k) r = + S.fromList + [ j + | (sq,i) <- seqs f `zip` [0..] + , i `S.member` r + , Right (k',j) <- concrSeqs gr sq + , k' == k + ] + +-------------------------------------------------------------------------------- +-- analyzing contexts + +equalFields :: Grammar -> [(ConcrCat,EqRel Int)] +equalFields gr = cs `zip` eqrels + where + eqrels = Mu.mu Top defs cs + cs = S.toList (nonEmptyCats gr) + + defs = + [ (c, depcats, h) + | c <- cs + -- fs = everything that has c as a goal category + -- there's two possibilities: + , let fs = -- 1) c is not a coercion: functions can have c as a goal category + [ Right f + | f <- symbols gr + , all (`S.member` nonEmptyCats gr) (fst (ctyp f)) + , c == snd (ctyp f) + ] ++ + -- 2) c is a coercion: here's a list of (nonempty) categories c uncoerces into + [ Left cat + | (cat,coe) <- coercions gr + , coe == c + , cat `S.member` nonEmptyCats gr + ] + + -- all the categories c depends on + depcats = S.toList $ S.fromList $ concat + [ case f of + Right f -> fst (ctyp f) -- 1) if c is not a coercion: + -- all arg cats of the functions with c as goal cat + Left cat -> [cat] -- 2) if c is a coercion: just the cats that it uncoerces into + | f <- fs + ] + + -- Function to give to mu: + -- computes the equivalence relation, given the eq.rels of its arguments + h rs = foldr (/\) Top $ [ apply f eqs + | Right f <- fs + , let eqs = map (args M.!) (fst $ ctyp f) + ] ++ + [ args M.! cat + | Left cat <- fs + ] + where + args = M.fromList (depcats `zip` rs) + ] + where + apply f eqs = + basic [ concatMap lin (concrSeqs gr sq) + | sq <- seqs f + ] + where + lin (Left str) = [ str | not (null str) ] + lin (Right (i,j)) = [ show i ++ "#" ++ show (rep (eqs !! i) j) ] + +contextsFor :: Grammar -> ConcrCat -> ConcrCat -> [Tree -> Tree] +contextsFor gr top hole = [] `fromMaybe` M.lookup hole (contextsTab gr M.! top) + +contexts :: Grammar -> ConcrCat -> [(ConcrCat,[Tree -> Tree])] +contexts gr top = + [ (c, map (path2context . reverse . snd) (F.toList paths)) + | (c, paths) <- cs `zip` pathss + ] + where + pathss = Mu.muDiff F.nil F.isNil dif uni defs cs + cs = S.toList (nonEmptyCats gr) + + -- all symbols with at least one argument, and only good arguments + goodSyms = + [ f + | f <- symbols gr + , arity f >= 1 + , snd (ctyp f) `S.member` nonEmptyCats gr + , all (`S.member` nonEmptyCats gr) (fst (ctyp f)) + ] + + -- definitions table for fixpoint iteration + fm1 `dif` fm2 = + [ d | d@(xs,_) <- F.toList fm1, not (fm2 `F.covers` xs) ] `ins` F.nil + + fm1 `uni` fm2 = + F.toList fm1 `ins` fm2 + + paths `ins` fm = + foldl collect fm + . map snd + . sort + $ [ (size p, p) | p <- paths ] + where + collect fm (str,p) + | fm `F.covers` str = fm + | otherwise = F.add str p fm + + size (_,p) = + sum [ if i == j then 1 else smallest gr t + | (f,i) <- p + , let (ts,_) = ctyp f + , (t,j) <- ts `zip` [0..] + ] + + defs = + [ if c == top + then (c, [], \_ -> F.unit [0] []) + else (c, ys, h) + | c <- cs + + -- everything that uses c in one of the two ways: + , let fs = -- 1) Functions that take c as the kth argument + [ Right (f,k) + | f <- goodSyms + , (t,k) <- fst (ctyp f) `zip` [0..] + , t == c + ] ++ + -- 2) coercions that uncoerce to c + [ Left coe + | (cat,coe) <- coercions gr + , cat == c + , coe `S.member` nonEmptyCats gr + ] + + -- goal categories for c + ys = S.toList $ S.fromList $ + [ case f of + Right (f,_) -> snd (ctyp f) -- 1) goal category of the function that uses c + Left coe -> coe -- 2) (category of the) coercion that uncoerces to c + | f <- fs + ] + + -- function to give to Mu + h ps = ([ (apply (f,k) str, (f,k):fis) + | Right (f,k) <- fs + , (str,fis) <- args M.! snd (ctyp f) + ] ++ + [ q + | Left a <- fs + , q <- args M.! a + ]) `ins` F.nil + where + args = M.fromList (ys `zip` map F.toList ps) + ] + where -- fields of B that make it to the top + apply :: (Symbol, Int) -> [Int] -> [Int] -- fields of A that make it to the top + apply (f,k) is = + S.toList $ S.fromList $ + [ y + | (sq,i) <- seqs f `zip` [0..] + , i `elem` is + , Right (x,y) <- concrSeqs gr sq + , x == k + ] + + path2context [] x = x + path2context ((f,i):fis) x = + App f + [ if j == i + then path2context fis x + else head (featAll gr t) + | (t,j) <- fst (ctyp f) `zip` [0..] + ] + +forgets :: Grammar -> ConcrCat -> [(ConcrCat,[Tree])] +forgets gr top = + filter (not . null . snd) + [ (c, [ path2context (reverse p) (head (featAll gr c)) + | (is,p) <- F.toList paths + , length is == fields c -- all indices forgotten + ] + ) + | (c, paths) <- cs `zip` pathss + ] + where + pathss = Mu.muDiff F.nil F.isNil dif uni defs cs + cs = S.toList (nonEmptyCats gr) + + -- all symbols with at least one argument, and only good arguments + goodSyms = + [ f + | f <- symbols gr + , arity f >= 1 + , snd (ctyp f) `S.member` nonEmptyCats gr + , all (`S.member` nonEmptyCats gr) (fst (ctyp f)) + ] + + fieldsTab = + M.fromList $ + [ (b, length (seqs f)) + | f <- symbols gr + , let (as,b) = ctyp f + ] + + fields a = + head $ + [ n + | c <- a : [ b | (b,a') <- coercions gr, a' == a ] + , Just n <- [M.lookup c fieldsTab] + ] ++ + error (show a ++ " has no function creating it") + + -- definitions table for fixpoint iteration + fm1 `dif` fm2 = + [ d | d@(xs,_) <- F.toList fm1, not (fm2 `F.covers` xs) ] `ins` F.nil + + fm1 `uni` fm2 = + F.toList fm1 `ins` fm2 + + paths `ins` fm = + foldl collect fm + . map snd + . sort + $ [ (size p, p) | p <- paths ] + where + collect fm (str,p) + | fm `F.covers` str = fm + | otherwise = F.add str p fm + + size (_,p) = + sum [ if i == j then 1 else smallest gr t + | (f,i) <- p + , let (ts,_) = ctyp f + , (t,j) <- ts `zip` [0..] + ] + + defs = + [ if c == top + then (c, [], \_ -> F.unit [] []) + else (c, ys, h) + | c <- cs + + -- everything that uses c in one of the two ways: + , let fs = -- 1) Functions that take c as the kth argument + [ Right (f,k) + | f <- goodSyms + , (t,k) <- fst (ctyp f) `zip` [0..] + , t == c + ] ++ + -- 2) coercions that uncoerce to c + [ Left coe + | (cat,coe) <- coercions gr + , cat == c + , coe `S.member` nonEmptyCats gr + ] + + -- goal categories for c + ys = S.toList $ S.fromList $ + [ case f of + Right (f,_) -> snd (ctyp f) + Left coe -> coe + | f <- fs + ] + + h ps = ([ (apply (f,k) str, (f,k):fis) + | Right (f,k) <- fs + , (str,fis) <- args M.! snd (ctyp f) + , length str < fields c + ] ++ + [ q + | Left a <- fs + , q@(str,_) <- args M.! a + , length str < fields c + ]) `ins` F.nil + where + args = M.fromList (ys `zip` map F.toList ps) + ] + where + apply :: (Symbol, Int) -> [Int] -> [Int] + apply (f,k) is = + [ y + | y <- [0..fields (fst (ctyp f) !! k)-1] + , y `S.notMember` used + ] + where + used = S.fromList $ + [ y + | (sq,i) <- seqs f `zip` [0..] + , i `notElem` is + , Right (x,y) <- concrSeqs gr sq + , x == k + ] + + path2context [] x = x + path2context ((f,i):fis) x = + App f + [ if j == i + then path2context fis x + else head (featAll gr t) + | (t,j) <- fst (ctyp f) `zip` [0..] + ] + +--traceLength s xs = trace (s ++ ":" ++ show (length xs)) xs + +emptyFields :: Grammar -> [(ConcrCat,S.Set Int)] +emptyFields gr = cs `zip` fields + where + cs = S.toList (nonEmptyCats gr) + fields = Mu.mu (S.fromList [0..99999]) defs cs + + defs = + [ (c, ys, h) + | c <- cs + , let fs = -- everything that has c as a goal category + [ Right f + | f <- symbols gr + , all (`S.member` nonEmptyCats gr) (fst (ctyp f)) + , c == snd (ctyp f) + ] ++ + -- 2) c is a coercion: here's a list of (nonempty) categories c uncoerces into + [ Left cat + | (cat,coe) <- coercions gr + , coe == c + , cat `S.member` nonEmptyCats gr + ] + + -- all the categories c depends on + ys = S.toList $ S.fromList $ concat + [ case f of + Right f -> fst (ctyp f) + Left cat -> [cat] + | f <- fs + ] + + -- Function to give to mu: + -- computes whether the field is empty, given the emptiness of its arguments. + -- a field in C is empty, if there's some function + -- f :: A -> B -> C + -- and it uses only empty fields from A and B. + -- we're only looking at a given C at a time, + + h :: [S.Set Int] -> S.Set Int + h vs = foldr1 S.intersection $ [ apply f emptyfields + | Right f <- fs + , let emptyfields = map (args M.!) (fst $ ctyp f) + ] ++ + [ args M.! cat + | Left cat <- fs + ] + where + args :: M.Map ConcrCat (S.Set Int) -- empty fields of each category + args = M.fromList (ys `zip` vs) + ] + where + --apply :: Symbol -- some f :: A -> B + -- -> [S.Set Int] -- for each argument type to f, which fields are empty + -- -> S.Set Int -- empty fields in B + apply f empties = + S.fromList + [ i + | (sq,i) <- seqs f `zip` [0..] + , let isEmpty s = case s of + Left str -> str == "" + Right (k,j) -> j `S.member` (empties !! k) + , all isEmpty (concrSeqs gr sq) + ] +-------------------------------------------------------------------------------- +-- FEAT-style generator magic + +type FEAT = [ConcrCat] -> Int -> (Integer, Integer -> [Tree]) + +smallest :: Grammar -> ConcrCat -> Int +smallest gr c = head [ n | n <- [0..], featCard gr c n > 0 ] + +-- compute how many trees there are of a given size and type +featCard :: Grammar -> ConcrCat -> Int -> Integer +featCard gr c n = featCardVec gr [c] n + +-- generate the i-th tree of a given size and type +featIth :: Grammar -> ConcrCat -> Int -> Integer -> Tree +featIth gr c n i = head (featIthVec gr [c] n i) + +-- generate all trees (infinitely many) of a given type +featAll :: Grammar -> ConcrCat -> [Tree] +featAll gr c = [ featIth gr c n i | n <- [0..], i <- [0..featCard gr c n-1] ] + +-- compute how many tree-vectors there are of a given size and type-vector +featCardVec :: Grammar -> [ConcrCat] -> Int -> Integer +featCardVec gr cs n = fst (feat gr cs n) + +-- generate the i-th tree-vector of a given size and type-vector +featIthVec :: Grammar -> [ConcrCat] -> Int -> Integer -> [Tree] +featIthVec gr cs n i = snd (feat gr cs n) i + +mkFEAT :: Grammar -> FEAT +mkFEAT gr = catList + where + catList' :: FEAT + catList' [] 0 = (1, \0 -> []) + catList' [] _ = (0, error "indexing in an empty sequence") + + catList' [c] s = + parts $ + [ (n, \i -> [App f (h i)]) + | s > 0 + , f <- symbols gr + , let (xs,y) = ctyp f + , y == c + , let (n,h) = catList xs (s-1) + ] ++ + [ catList [x] s -- put (s-1) if it doesn't terminate + | s > 0 + , (x,y) <- coercions gr + , y == c + ] + + catList' (c:cs) s = + parts [ (nx*nxs, \i -> hx (i `mod` nx) ++ hxs (i `div` nx)) + | k <- [0..s] + , let (nx,hx) = catList [c] k + (nxs,hxs) = catList cs (s-k) + ] + + catList :: FEAT + catList = memoList (memoNat . catList') + where + -- all possible categories of the grammar + cats = S.toList $ S.fromList $ + [ x | f <- symbols gr + , let (xs,y) = ctyp f + , x <- y:xs ] ++ + [ z | (x,y) <- coercions gr + , z <- [x,y] ] + + memoList f = \cs -> case cs of + [] -> fNil + a:as -> fCons a as + where + fNil = f [] + fCons = (tab M.!) + tab = M.fromList [ (c, memoList (f . (c:))) | c <- cats ] + + memoNat f = (tab!!) + where + tab = [ f i | i <- [0..] ] + + parts [] = (0, error "indexing outside of a sequence") + parts ((n,h):nhs) = (n+n', \i -> if i < n then h i else h' (i-n)) + where + (n',h') = parts nhs + + +-------------------------------------------------------------------------------- +-- Functions used in Main + +-- compare two grammars +diffCats :: Grammar -> Grammar -> [(Cat,[Int],[String],[String])] +diffCats gr1 gr2 = + [ (acat1,[difFid c1, difFid c2],labels1 \\ labels2,labels2 \\ labels1) + | c1@(acat1,_i1,_j2,labels1) <- concrCats gr1 + , c2@(acat2,_i2,_j2,labels2) <- concrCats gr2 + , difFid c1 /= difFid c2 -- different amount of concrete categories + || labels1 /= labels2 -- or the labels are different + , acat1==acat2 ] + + where + difFid (_,i,j,_) = 1 + (j-i) + + +-- return a list of symbols that have a specified string, e.g. "it" in English +-- grammar appears in functions CleftAdv, CleftNP, ImpersCl, DefArt, it_Pron +hasConcrString :: Grammar -> String -> [Symbol] +hasConcrString gr str = + [ symb + | symb <- symbols gr + , str `elem` concatMap (lefts . concrSeqs gr) (seqs symb) ] + +-- nice printouts +type Context = String +type LinTree = ((Lang,Context),(Lang,String),(Lang,String),(Lang,String)) +data Comparison = Comparison { funTree :: String, linTree :: [LinTree] } +instance Show Comparison where + show c = unlines $ funTree c : map showLinTree (linTree c) + +dummyHole = App (Symbol "∅" [] ([], "") ([], CC Nothing 99999999)) [] + +showLinTree :: LinTree -> String +showLinTree ((an,hl),(l1,t1),(l2,t2),(_l,[])) = unlines ["", an++hl, l1++t1, l2++t2] +showLinTree ((an,hl),(l1,t1),(l2,t2),(l3,t3)) = unlines ["", an++hl, l1++t1, l2++t2, l3++t3] + +compareTree :: Grammar -> Grammar -> [Grammar] -> Tree -> Comparison +compareTree gr oldgr transgr t = Comparison { + funTree = "* " ++ show t +, linTree = [ ( ("** ",hl), (langName gr,newLin), (langName oldgr, oldLin), transLin ) + | ctx <- ctxs + , let hl = show (ctx dummyHole) + , let transLin = case transgr of + [] -> ("","") + g:_ -> (langName g, linearize g (ctx t)) + , let newLin = linearize gr (ctx t) + , let oldLin = linearize oldgr (ctx t) + , newLin /= oldLin ] } + where + w = top t + c = snd (ctyp w) + cs = [ coe + | (cat,coe) <- coercions gr + , c == cat ] + ctxs = concat + [ contextsFor gr sc cat + | sc <- ccats gr (startCat gr) + , cat <- cs ] + langName gr = concrLang gr ++ "> " + +type Result = String + +testFun :: Bool -> Grammar -> [Grammar] -> Cat -> Name -> Result +testFun debug gr trans startcat funname = + let test = testTree debug gr trans + in unlines [ test t n cs + | (n,(t,cs)) <- zip [1..] trees_Ctxs ] + + where + trees_Ctxs = [ (t,commonCtxs) | t <- reducedTrees + , not $ null commonCtxs ] ++ + [ (t,uniqueCtxs) | t <- allTrees + , not $ null uniqueCtxs ] + + (start:_) = ccats gr startcat + hl f c1 c2 = f (c1 dummyHole) == f (c2 dummyHole) +-- applyHole = hl id -- TODO why doesn't this work for equality of contexts? + applyHole = hl show -- :: (Tree -> Tree) -> (Tree -> Tree) -> Bool + + goalcats = map ccatOf allTrees :: [ConcrCat] -- these are not coercions (coercions can't be goals) + + coercionsThatCoverAllGoalcats = [ (c,fs) + | (c,fs) <- contexts gr start + , all (coerces gr c) goalcats ] + funs = case lookupSymbol gr funname of + [] -> error $ "Function "++funname++" not found" + fs -> fs + allTrees = treesUsingFun gr funs + ctxs = nubBy applyHole $ concatMap (contextsFor gr start) goalcats :: [Tree->Tree] + + (commonCtxs,reducedTrees) = case coercionsThatCoverAllGoalcats of + [] -> ([],[]) -- no coercion covers all goal cats -> all contexts are relevant + cs -> (cCtxs,rTrees) -- all goal cats coerce into same -> find redundant contexts + where + (coe,coercedCtxs) = head coercionsThatCoverAllGoalcats + cCtxs = intersectBy applyHole ctxs coercedCtxs + rTrees = concat $ bestExamples (head funs) gr + [ [ App newTop subtrees ] + | (App tp subtrees) <- allTrees + , let newTop = tp { ctyp = (fst $ ctyp tp, coe)} ] + uniqueCtxs = deleteFirstsBy applyHole ctxs commonCtxs + showCtx f = let t = f dummyHole in show t ++ "\t\t\t" ++ showConcrFun gr (top t) + +testTree :: Bool -> Grammar -> [Grammar] -> Tree -> Int -> [Tree -> Tree] -> Result +testTree debug gr tgrs t n ctxs = unlines + [ "* " ++ {- show n ++ ")" ++ -} show t + , showConcrFun gr w + , if debug then unlines $ tabularPrint gr t else "" + , unlines $ concat + [ [ "** " ++ show m ++ ") " ++ show (ctx (App (hole c) [])) + , langName gr ++ linearize gr (ctx t) + ] ++ + [ langName tgr ++ linearize tgr (ctx t) + | tgr <- tgrs ] + | (ctx,m) <- zip ctxs [1..] + ] + , "" ] + where + w = top t + c = snd (ctyp w) + langName gr = concrLang gr ++ "> " + + tabularPrint gr t = + let cseqs = [ concatMap showCSeq cseq + | cseq <- map (concrSeqs gr) (seqs $ top t) ] + tablins = tabularLin gr t :: [(String,String)] + in [ fieldname ++ ":\t" ++ lin ++ "\t" ++ s + | ((fieldname,lin),s) <- zip tablins cseqs ] + showCSeq (Left tok) = " " ++ show tok ++ " " + showCSeq (Right (i,j)) = " <" ++ show i ++ "," ++ show j ++ "> " + +-------------------------------------------------------------------------------- +-- Generate test trees + +treesUsingFun :: Grammar -> [Symbol] -> [Tree] +treesUsingFun gr detCNs = + [ tree + | detCN <- detCNs + , let (dets_cns,np_209) = ctyp detCN -- :: ([ConcrCat],ConcrCat) + , let bestArgs = case dets_cns of + [] -> [[]] + xs -> bestTrees detCN gr dets_cns + , tree <- App detCN `map` bestArgs ] + + +bestTrees :: Symbol -> Grammar -> [ConcrCat] -> [[Tree]] +bestTrees fun gr cats = + bestExamples fun gr $ take 200 -- change this to something else if too slow + [ featIthVec gr cats size i + | all (`S.member` nonEmptyCats gr) cats + , size <- [0..10] + , let card = featCardVec gr cats size + , i <- [0..card-1] + ] + +testsAsWellAs :: (Eq a, Eq b) => [a] -> [b] -> Bool +xs `testsAsWellAs` ys = go (xs `zip` ys) + where + go [] = + True + + go ((x,y):xys) = + and [ y' == y | (x',y') <- xys, x == x' ] && + go [ xy | xy@(x',_) <- xys, x /= x' ] + + +bestExamples :: Symbol -> Grammar -> [[Tree]] -> [[Tree]] +bestExamples fun gr vtrees = go [] vtrees_lins + where + syncategorematics = concatMap (lefts . concrSeqs gr) (seqs fun) + vtrees_lins = [ (vtree, syncategorematics ++ + concatMap (map snd . tabularLin gr) vtree) --linearise all trees at once + | vtree <- vtrees ] :: [([Tree],[String])] + + go cur [] = map fst cur + go cur (vt@(ts,lins):vts) + | any (`testsAsWellAs` lins) (map snd cur) = go cur vts + | otherwise = go' (vt:[ c | c@(_,clins) <- cur + , not (lins `testsAsWellAs` clins) ]) + vts + + go' cur vts | enough cur = map fst cur + | otherwise = go cur vts + + enough :: [([Tree],[String])] -> Bool + enough [(_,lins)] = all singleton (group $ sort lins) -- can stop earlier but let's not do that + enough _ = False +
\ No newline at end of file diff --git a/src/tools/gftest/Graph.hs b/src/tools/gftest/Graph.hs new file mode 100644 index 000000000..a440bf12d --- /dev/null +++ b/src/tools/gftest/Graph.hs @@ -0,0 +1,193 @@ +module Graph where + +import qualified Data.Map as M +import Data.Map( Map, (!) ) +import qualified Data.Set as S +import Data.Set( Set ) +import Data.List( nub, sort, (\\) ) +--import Test.QuickCheck hiding ( generate ) + +-- == almost everything in this module is inspired by King & Launchbury == + +-------------------------------------------------------------------------------- +-- depth-first trees + +data Tree a + = Node a [Tree a] + | Cut a + deriving ( Eq, Show ) + +type Forest a + = [Tree a] + +top :: Tree a -> a +top (Node x _) = x +top (Cut x) = x + +-- pruning a possibly infinite forest +prune :: Ord a => Forest a -> Forest a +prune ts = go S.empty ts + where + go seen [] = [] + go seen (Cut x :ts) = Cut x : go seen ts + go seen (Node x vs:ts) + | x `S.member` seen = Cut x : go seen ts + | otherwise = Node x (take n ws) : drop n ws + where + n = length vs + ws = go (S.insert x seen) (vs ++ ts) + +-- pre- and post-order traversals +preorder :: Tree a -> [a] +preorder t = preorderF [t] + +preorderF :: Forest a -> [a] +preorderF ts = go ts [] + where + go [] xs = xs + go (Cut x : ts) xs = go ts xs + go (Node x vs : ts) xs = x : go vs (go ts xs) + +postorder :: Tree a -> [a] +postorder t = postorderF [t] + +postorderF :: Forest a -> [a] +postorderF ts = go ts [] + where + go [] xs = xs + go (Cut x : ts) xs = go ts xs + go (Node x vs : ts) xs = go vs (x : go ts xs) + +-- computing back-arrows +backs :: Ord a => Tree a -> Set a +backs t = S.fromList (go S.empty t) + where + go ups (Node x ts) = concatMap (go (S.insert x ups)) ts + go ups (Cut x) = [x | x `S.member` ups ] + +-------------------------------------------------------------------------------- +-- graphs + +type Graph a + = Map a [a] + +vertices :: Graph a -> [a] +vertices g = [ x | (x,_) <- M.toList g ] + +transposeG :: Ord a => Graph a -> Graph a +transposeG g = + M.fromListWith (++) $ + [ (y,[x]) | (x,ys) <- M.toList g, y <- ys ] ++ + [ (x,[]) | x <- vertices g ] + +-------------------------------------------------------------------------------- +-- graphs and trees + +generate :: Ord a => Graph a -> a -> Tree a +generate g x = Node x (map (generate g) (g!x)) + +dfs :: Ord a => Graph a -> [a] -> Forest a +dfs g xs = prune (map (generate g) xs) + +reach :: Ord a => Graph a -> [a] -> Graph a +reach g xs = M.fromList [ (x,g!x) | x <- preorderF (dfs g xs) ] + +dff :: Ord a => Graph a -> Forest a +dff g = dfs g (vertices g) + +preOrd :: Ord a => Graph a -> [a] +preOrd g = preorderF (dff g) + +postOrd :: Ord a => Graph a -> [a] +postOrd g = postorderF (dff g) + +scc1 :: Ord a => Graph a -> Forest a +scc1 g = reverse (dfs (transposeG g) (reverse (postOrd g))) + +scc2 :: Ord a => Graph a -> Forest a +scc2 g = dfs g (reverse (postOrd (transposeG g))) + +scc :: Ord a => Graph a -> Forest a +scc g = scc2 g + +sccs :: Ord a => Graph a -> [[a]] +sccs = map preorder . scc + +-------------------------------------------------------------------------------- +-- testing correctness + +{- +newtype G = G (Graph Int) deriving ( Show ) + +set :: (Ord a, Num a, Arbitrary a) => Gen [a] +set = (nub . sort . map abs) `fmap` arbitrary + +instance Arbitrary G where + arbitrary = + do xs <- set `suchThat` (not . null) + yss <- sequence [ listOf (elements xs) | x <- xs ] + return (G (M.fromList (xs `zip` yss))) + + shrink (G g) = + [ G (delNode x g) + | (x,_) <- M.toList g + ] ++ + [ G (delEdge x y g) + | (x,ys) <- M.toList g + , y <- ys + ] + where + delNode v g = + M.fromList + [ (x,filter (v/=) ys) + | (x,ys) <- M.toList g + , x /= v + ] + + delEdge v w g = + M.insert v ((g!v) \\ [w]) g + +-- all vertices in a component can reach each other +prop_Scc_StronglyConnected (G g) = + whenFail (print cs) $ + and [ y `S.member` r | c <- cs, x <- c, let r = reach x, y <- c ] + where + cs = sccs g + + reach x = go S.empty [x] + where + go seen [] = seen + go seen (x:xs) + | x `S.member` seen = go seen xs + | otherwise = go (S.insert x seen) ((g!x) ++ xs) + +-- vertices cannot forward-reach to other components +prop_Scc_NotConnected (G g) = + whenFail (print cs) $ + -- every vertex is somewhere + and [ or [ x `elem` c | c <- cs ] + | x <- vertices g + ] && + -- cannot foward-reach + and [ y `S.notMember` rx + | (c,d) <- pairs cs + , x <- c + , let rx = reach x + , y <- d + ] + where + cs = sccs g + + pairs (x:xs) = [ (x,y) | y <- xs ] ++ pairs xs + pairs [] = [] + + reach x = go S.empty [x] + where + go seen [] = seen + go seen (x:xs) + | x `S.member` seen = go seen xs + | otherwise = go (S.insert x seen) ((g!x) ++ xs) +-} + +-------------------------------------------------------------------------------- + diff --git a/src/tools/gftest/Main.hs b/src/tools/gftest/Main.hs new file mode 100644 index 000000000..fcabb33c3 --- /dev/null +++ b/src/tools/gftest/Main.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Main where + +import Grammar +import EqRel + +import Control.Monad ( when ) +import Data.List ( intercalate, groupBy, sortBy, deleteFirstsBy, isInfixOf ) +import Data.Maybe ( fromMaybe, mapMaybe ) +import qualified Data.Set as S +import qualified Data.Map as M + +import System.Console.CmdArgs hiding ( name, args ) +import qualified System.Console.CmdArgs as A +import System.FilePath.Posix ( takeFileName ) +import System.IO ( stdout, hSetBuffering, BufferMode(..) ) + + +data GfTest + = GfTest + { grammar :: Maybe FilePath + -- Languages + , lang :: Lang + + -- Functions and cats + , function :: Name + , category :: Cat + , tree :: String + , start_cat :: Maybe Cat + , show_cats :: Bool + , show_funs :: Bool + , show_coercions:: Bool + , concr_string :: String + + -- Information about fields + , equal_fields :: Bool + , empty_fields :: Bool + , unused_fields :: Bool + , erased_trees :: Bool + + -- Compare to old grammar + , old_grammar :: Maybe FilePath + , only_changed_cats :: Bool + + -- Misc + , treebank :: Maybe FilePath + , count_trees :: Maybe Int + , debug :: Bool + , write_to_file :: Bool + + } deriving (Data,Typeable,Show,Eq) + +gftest = GfTest + { grammar = def &= typFile &= help "Path to the grammar (PGF) you want to test" + , lang = def &= A.typ "\"Eng Swe\"" + &= help "Concrete syntax + optional translations" + , tree = def &= A.typ "\"UseN tree_N\"" + &= A.name "t" &= help "Test the given tree" + , function = def &= A.typ "UseN" &= help "Test the given function(s)" + , category = def &= A.typ "NP" + &= A.name "c" &= help "Test all functions with given goal category" + , start_cat = def &= A.typ "Utt" + &= A.name "s" &= help "Use the given category as start category" + , concr_string = def &= A.typ "the" &= help "Show all functions that include given string" + , show_cats = def &= help "Show all available categories" + , show_funs = def &= help "Show all available functions" + , show_coercions= def &= help "Show coercions in the grammar" + , debug = def &= help "Show debug output" + , equal_fields = def &= A.name "q" &= help "Show fields whose strings are always identical" + , empty_fields = def &= A.name "e" &= help "Show fields whose strings are always empty" + , unused_fields = def &= help "Show fields that never make it into the top category" + , erased_trees = def &= A.name "r" &= help "Show trees that are erased" + , treebank = def &= typFile + &= A.name "b" &= help "Path to a treebank" + , count_trees = def &= A.typ "3" &= help "Number of trees of size <3>" + , old_grammar = def &= typFile + &= A.name "o" &= help "Path to an earlier version of the grammar" + , only_changed_cats = def &= help "When comparing against an earlier version of a grammar, only test functions in categories that have changed between versions" + , write_to_file = def &= help "Write the results in a file (<GRAMMAR>_<FUN>.org)" + } + + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + + args <- cmdArgs gftest + + case grammar args of + Nothing -> putStrLn "Usage: `gftest -g <PGF grammar> [OPTIONS]'\nTo see available commands, run `gftest --help' or visit https://github.com/GrammaticalFramework/GF/blob/master/src/tools/gftest/README.md" + Just fp -> do + let (absName,grName) = (takeFileName $ stripPGF fp, stripPGF fp ++ ".pgf") --doesn't matter if the name is given with or without ".pgf" + + (langName:langTrans) = case lang args of + [] -> [ absName ++ "Eng" ] -- if no English grammar found, it will be given a default value later + langs -> [ absName ++ t | t <- words langs ] + + -- Read grammar and translations + gr <- readGrammar langName grName + grTrans <- sequence [ readGrammar lt grName | lt <- langTrans ] + + -- in case the language given by the user was not valid, use some language that *is* in the grammar + let langName = concrLang gr + + let startcat = startCat gr `fromMaybe` start_cat args + + testTree' t n = testTree False gr grTrans t n ctxs + where + s = top t + c = snd (ctyp s) + ctxs = concat [ contextsFor gr sc c + | sc <- ccats gr startcat ] + + output = -- Print to stdout or write to a file + if write_to_file args + then \x -> + do let fname = concat [ langName, "_", function args, category args, ".org" ] + writeFile fname x + putStrLn $ "Wrote results in " ++ fname + else putStrLn + + + intersectConcrCats cats_fields intersection = + M.fromListWith intersection + ([ (c,fields) + | (CC (Just c) _,fields) <- cats_fields + ] ++ + [ (cat,fields) + | (c@(CC Nothing _),fields) <- cats_fields + , (CC (Just cat) _,coe) <- coercions gr + , c == coe + ]) + + printStats tab = + sequence_ [ do putStrLn $ "==> " ++ c ++ ": " + putStrLn $ unlines (map (fs!!) xs) + | (c,vs) <- M.toList tab + , let fs = fieldNames gr c + , xs@(_:_) <- [ S.toList vs ] ] + ----------------------------------------------------------------------------- + -- Testing functions + + -- Test a tree + case tree args of + [] -> return () + t -> output $ testTree' (readTree gr t) 1 + + -- Test a function + case category args of + [] -> return () + cat -> output $ unlines + [ testTree' t n + | (t,n) <- treesUsingFun gr (functionsByCat gr cat) `zip` [1..]] + + -- Test all functions in a category + case function args of + [] -> return () + fs -> let funs = if '*' `elem` fs + then let subs = filter (/="*") $ groupBy (\a b -> a/='*' && b/='*') fs + in nub [ f | s <- symbols gr, let f = show s + , all (`isInfixOf` f) subs + , arity s >= 1 ] + else words fs + in output $ unlines + [ testFun (debug args) gr grTrans startcat f + | f <- funs ] + +----------------------------------------------------------------------------- +-- Information about the grammar + + -- Show available categories + when (show_cats args) $ do + putStrLn "* Categories in the grammar:" + putStrLn $ unlines [ cat | (cat,_,_,_) <- concrCats gr ] + + -- Show available functions + when (show_funs args) $ do + putStrLn "* Functions in the grammar:" + putStrLn $ unlines $ nub [ show s | s <- symbols gr ] + + -- Show coercions in the grammar + when (show_coercions args) $ do + putStrLn "* Coercions in the grammar:" + putStrLn $ unlines [ show cat++"--->"++show coe | (cat,coe) <- coercions gr ] + + -- Show all functions that contain the given string + -- (e.g. English "it" appears in DefArt, ImpersCl, it_Pron, …) + case concr_string args of + [] -> return () + str -> do putStrLn $ "### The following functions contain the string '" ++ str ++ "':" + putStr "==> " + putStrLn $ intercalate ", " $ nub [ name s | s <- hasConcrString gr str] + + -- Show empty fields + when (empty_fields args) $ do + putStrLn "### Empty fields:" + printStats $ intersectConcrCats (emptyFields gr) S.intersection + putStrLn "" + + -- Show erased trees + when (erased_trees args) $ do + putStrLn "* Erased trees:" + sequence_ + [ do putStrLn ("** " ++ intercalate "," erasedTrees ++ " : " ++ uncoerceAbsCat gr c) + sequence_ + [ do putStrLn ("- Tree: " ++ showTree t) + putStrLn ("- Lin: " ++ s) + putStrLn $ unlines + [ "- Trans: "++linearize tgr t + | tgr <- grTrans ] + | t <- ts + , let s = linearize gr t + , let erasedSymbs = [ sym | sym <- flatten t, c==snd (ctyp sym) ] + ] + | top <- take 1 $ ccats gr startcat + , (c,ts) <- forgets gr top + , let erasedTrees = + concat [ [ showTree subtree + | sym <- flatten t + , let csym = snd (ctyp sym) + , c == csym || coerces gr c csym + , let Just subtree = subTree sym t ] + | t <- ts ] + ] + putStrLn "" + + -- Show unused fields + when (unused_fields args) $ do + + let unused = + [ (c,S.fromList notUsed) + | tp <- ccats gr startcat + , (c,is) <- reachableFieldsFromTop gr tp + , let ar = head $ + [ length (seqs f) + | f <- symbols gr, snd (ctyp f) == c ] ++ + [ length (seqs f) + | (b,a) <- coercions gr, a == c + , f <- symbols gr, snd (ctyp f) == b ] + notUsed = [ i | i <- [0..ar-1], i `notElem` is ] + , not (null notUsed) + ] + putStrLn "### Unused fields:" + printStats $ intersectConcrCats unused S.intersection + putStrLn "" + + -- Show equal fields + let tab = intersectConcrCats (equalFields gr) (/\) + when (equal_fields args) $ do + putStrLn "### Equal fields:" + sequence_ + [ putStrLn ("==> " ++ c ++ ":\n" ++ cl) + | (c,eqr) <- M.toList tab + , let fs = fieldNames gr c + , cl <- case eqr of + Top -> ["TOP"] + Classes xss -> [ unlines (map (fs!!) xs) + | xs@(_:_:_) <- xss ] + ] + putStrLn "" + + case count_trees args of + Nothing -> return () + Just n -> do let start = head $ ccats gr startcat + let i = featCard gr start n + let iTot = sum [ featCard gr start m | m <- [1..n] ] + putStr $ "There are "++show iTot++" trees up to size "++show n + putStrLn $ ", and "++show i++" of exactly size "++show n++".\nFor example: " + putStrLn $ "* " ++ show (featIth gr start n 0) + putStrLn $ "* " ++ show (featIth gr start n (i-1)) + +------------------------------------------------------------------------------- +-- Comparison with old grammar + + case old_grammar args of + Nothing -> return () + Just fp -> do + oldgr <- readGrammar langName (stripPGF fp ++ ".pgf") + let ogr = oldgr { concrLang = concrLang oldgr ++ "-OLD" } + difcats = diffCats ogr gr -- (acat, [#o, #n], olabels, nlabels) + + -------------------------------------------------------------------------- + -- generate statistics of the changes in the concrete categories + let ccatChangeFile = langName ++ "-ccat-diff.org" + writeFile ccatChangeFile "" + sequence_ + [ appendFile ccatChangeFile $ unlines + [ "* " ++ acat + , show o ++ " concrete categories in the old grammar," + , show n ++ " concrete categories in the new grammar." + , "** Labels only in old (" ++ show (length ol) ++ "):" + , intercalate ", " ol + , "** Labels only in new (" ++ show (length nl) ++ "):" + , intercalate ", " nl ] + | (acat, [o,n], ol, nl) <- difcats ] + when (debug args) $ + sequence_ + [ appendFile ccatChangeFile $ + unlines $ + ("* All concrete cats in the "++age++" grammar:"): + [ show cats | cats <- concrCats g ] + | (g,age) <- [(ogr,"old"),(gr,"new")] ] + + putStrLn $ "Created file " ++ ccatChangeFile + + -------------------------------------------------------------------------- + -- print out tests for all functions in the changed cats + + let changedFuns = + if only_changed_cats args + then [ (cat,functionsByCat gr cat) | (cat,_,_,_) <- difcats ] + else + case category args of + [] -> case function args of + [] -> [ (cat,functionsByCat gr cat) + | (cat,_,_,_) <- concrCats gr ] + fn -> [ (snd $ Grammar.typ f, [f]) + | f <- lookupSymbol gr fn ] + ct -> [ (ct,functionsByCat gr ct) ] + writeLinFile file grammar otherGrammar = do + writeFile file "" + putStrLn "Testing functions in… " + diff <- concat `fmap` + sequence [ do let cs = [ compareTree grammar otherGrammar grTrans t + | t <- treesUsingFun grammar funs ] + putStr $ cat ++ " \r" + -- prevent lazy evaluation; make printout accurate + appendFile ("/tmp/"++file) (unwords $ map show cs) + return cs + | (cat,funs) <- changedFuns ] + let relevantDiff = go [] [] diff where + go res seen [] = res + go res seen (Comparison f ls:cs) = + if null uniqLs then go res seen cs + else go (Comparison f uniqLs:res) (uniqLs++seen) cs + where uniqLs = deleteFirstsBy ctxEq ls seen + ctxEq (a,_,_,_) (b,_,_,_) = a==b + shorterTree c1 c2 = length (funTree c1) `compare` length (funTree c2) + writeFile file $ unlines + [ show comp + | comp <- sortBy shorterTree relevantDiff ] + + + writeLinFile (langName ++ "-lin-diff.org") gr ogr + putStrLn $ "Created file " ++ (langName ++ "-lin-diff.org") + + --------------------------------------------------------------------------- + -- Print statistics about the functions: e.g., in the old grammar, + -- all these 5 functions used to be in the same category: + -- [DefArt,PossPron,no_Quant,this_Quant,that_Quant] + -- but in the new grammar, they are split into two: + -- [DefArt,PossPron,no_Quant] and [this_Quant,that_Quant]. + let groupFuns grammar = -- :: Grammar -> [[Symbol]] + concat [ groupBy sameCCat $ sortBy compareCCat funs + | (cat,_,_,_) <- difcats + , let funs = functionsByCat grammar cat ] + + sortByName = sortBy (\s t -> name s `compare` name t) + writeFunFile groupedFuns file grammar = do + writeFile file "" + sequence_ [ do appendFile file "---\n" + appendFile file $ unlines + [ showConcrFun gr fun + | fun <- sortByName funs ] + | funs <- groupedFuns ] + + writeFunFile (groupFuns ogr) (langName ++ "-old-funs.org") ogr + writeFunFile (groupFuns gr) (langName ++ "-new-funs.org") gr + + putStrLn $ "Created files " ++ langName ++ "-(old|new)-funs.org" + +------------------------------------------------------------------------------- +-- Read trees from treebank. No fancier functionality yet. + + case treebank args of + Nothing -> return () + Just fp -> do + tb <- readFile fp + sequence_ [ do let tree = readTree gr str + ccat = ccatOf tree + putStrLn $ unlines [ "", showTree tree ++ " : " ++ show ccat] + putStrLn $ linearize gr tree + | str <- lines tb ] + + + where + + nub = S.toList . S.fromList + + sameCCat :: Symbol -> Symbol -> Bool + sameCCat s1 s2 = snd (ctyp s1) == snd (ctyp s2) + + compareCCat :: Symbol -> Symbol -> Ordering + compareCCat s1 s2 = snd (ctyp s1) `compare` snd (ctyp s2) + + stripPGF :: String -> String + stripPGF s = case reverse s of + 'f':'g':'p':'.':name -> reverse name + name -> s + diff --git a/src/tools/gftest/Mu.hs b/src/tools/gftest/Mu.hs new file mode 100644 index 000000000..4aa11e316 --- /dev/null +++ b/src/tools/gftest/Mu.hs @@ -0,0 +1,113 @@ +module Mu where + +import Data.Map( Map, (!) ) +import qualified Data.Map as M +import Data.Set( Set ) +import qualified Data.Set as S +import Graph + +-------------------------------------------------------------------------------- + +-- naive implementation of fixpoint computation +mu0 :: (Ord x, Eq a) => a -> [(x, [x], [a] -> a)] -> [x] -> [a] +mu0 bot defs zs = [ done!z | z <- zs ] + where + xs = [ x | (x, _, _) <- defs ] + done = iter [ bot | _ <- xs ] + + iter as + | as == as' = tab + | otherwise = iter as' + where + tab = M.fromList (xs `zip` as) + as' = [ f [ tab!y | y <- ys ] + | (_,(_, ys, f)) <- as `zip` defs + ] + +-------------------------------------------------------------------------------- + +-- scc-based implementation of fixpoint computation +{- + a --^ initial/bottom value (smallest element) in the fixpoint computation +-> [( x, [x] --^ A single category, its arguments + , [a] -> a) --^ function that takes as its argument a list of values that we want to compute for the [x] + ] +-> [x] --^ All categories that you want to see the answer for +-> [a] --^ Values for the given categories +-} + +mu :: (Ord x, Eq a) => a -> [(x, [x], [a] -> a)] -> [x] -> [a] +mu bot defs zs = [ vtab?z | z <- zs ] + where + ftab = M.fromList [ (x,f) | (x,_,f) <- defs ] + graph = reach (M.fromList [ (x,xs) | (x,xs,_) <- defs ]) zs + vtab = foldl compute M.empty (scc graph) + + compute vtab t = fix (-1) vtab (map (vtab ?) xs) + where + xs = S.toList (backs t) + + fix 0 vtab _ = vtab + fix n vtab as + | as' == as = vtab' + | otherwise = fix (n-1) vtab' as' + where + (_,vtab') = eval t vtab + as' = map (vtab' ?) xs + + eval (Cut x) vtab = (vtab?x, vtab) + eval (Node x ts) vtab = (a, M.insert x a vtab') + where + (as, vtab') = evalList ts vtab + a = (ftab!x) as + + evalList [] vtab = ([], vtab) + evalList (t:ts) vtab = (a:as, vtab'') + where + (a, vtab') = eval t vtab + (as,vtab'') = evalList ts vtab' + + vtab ? x = case M.lookup x vtab of + Nothing -> bot + Just a -> a + +-------------------------------------------------------------------------------- + +-- diff/scc-based implementation of fixpoint computation +muDiff :: (Ord x, Eq a) + => a -> (a->Bool) -> (a->a->a) -> (a->a->a) + -> [(x, [x], [a] -> a)] + -> [x] -> [a] +muDiff bot isBot diff apply defs zs = [ vtab?z | z <- zs ] + where + ftab = M.fromList [ (x,f) | (x,_,f) <- defs ] + graph = reach (M.fromList [ (x,xs) | (x,xs,_) <- defs ]) zs + vtab = foldl compute M.empty (scc graph) + + compute vtab t = fix vtab M.empty + where + xs = S.toList (backs t) + + fix dtab vtab + | all isBot ds = vtab' + | otherwise = fix (M.fromList (xs `zip` ds)) vtab' + where + dtab' = eval t dtab + vtab' = foldr (\(x,d) -> M.alter (Just . apply' d) x) vtab (M.toList dtab') + ds = map (dtab' ?) xs + + apply' d Nothing = apply d bot + apply' d (Just a) = apply d a + + eval (Cut x) tab = tab + eval (Node x ts) tab = M.insert x d tab' + where + tab' = foldl (flip eval) tab ts + d = (ftab!x) [ tab'?x | x <- map top ts ] `diff` (vtab?x) + + vtab ? x = case M.lookup x vtab of + Nothing -> bot + Just a -> a + +-------------------------------------------------------------------------------- + diff --git a/src/tools/gftest/README.md b/src/tools/gftest/README.md new file mode 100644 index 000000000..a71017004 --- /dev/null +++ b/src/tools/gftest/README.md @@ -0,0 +1,430 @@ +# gftest: Automatic systematic test case generation for GF grammars + +`gftest` is a program for automatically generating systematic test +cases for GF grammars. The basic use case is to give `gftest` a +PGF grammar, a concrete language and a function; then `gftest` generates a +representative and minimal set of example sentences for a human to look at. + +There are examples of actual generated test cases later in this +document, as well as the full list of options to give to `gftest`. + +## Table of Contents + +- [Installation](#installation) + - [Prerequisites](#prerequisites) + - [Install gftest](#install-gftest) +- [Common use cases](#common-use-cases) + - [Grammar: `-g`](#grammar--g) + - [Language: `-l`](#language--l) + - [Function(s) to test: `-f`](#functions-to-test--f) + - [Start category for context: `-s`](#start-category-for-context--s) + - [Category to test: `-c`](#category-to-test--c) + - [Tree to test: `-t`](#tree-to-test--t) + - [Compare against an old version of the grammar: `-o`](#compare-against-an-old-version-of-the-grammar--o) + - [Information about a particular string: `--concr-string`](#information-about-a-particular-string---concr-string) + - [Write into a file: `-w`](#write-into-a-file--w) +- [Less common use cases](#less-common-use-cases) + - [Empty or always identical fields: `-e`, `-q`](#empty-or-always-identical-fields--e--q) + - [Unused fields: `-u`](#unused-fields--u) + - [Erased trees: `-r`](#erased-trees--r) + - [--show-coercions](#--show-coercions) + - [--count-trees](#--count-trees) + + +## Installation + +### Prerequisites + +You need the library `PGF2`. Here are instructions how to install: + +1) Install C runtime: go to the directory [GF/src/runtime/c](https://github.com/GrammaticalFramework/GF/tree/master/src/runtime/c), see +instructions in INSTALL +1) Install PGF2 in one of the two ways: + * **EITHER** Go to the directory + [GF/src/runtime/haskell-bind](https://github.com/GrammaticalFramework/GF/tree/master/src/runtime/haskell-bind), + do `cabal install` + * **OR** Go to the root directory of + [GF](https://github.com/GrammaticalFramework/GF/) and compile GF + with C-runtime system support: `cabal + install -fc-runtime`, see more information [here](http://www.grammaticalframework.org/doc/gf-developers.html#toc16). + +### Install gftest + +Go to +[GF/src/tools](https://github.com/GrammaticalFramework/GF/tree/master/src/tools), +do `cabal install`. It creates an executable `gftest`. + + +## Common use cases + +Run `gftest --help` of `gftest -?` to get the list of options. + +``` +Common flags: + -g --grammar=FILE Path to the grammar (PGF) you want to test + -l --lang="Eng Swe" Concrete syntax + optional translations + -f --function=UseN Test the given function(s) + -c --category=NP Test all functions with given goal category + -t --tree="UseN tree_N" Test the given tree + -s --start-cat=Utt Use the given category as start category + --show-cats Show all available categories + --show-funs Show all available functions + --show-coercions Show coercions in the grammar + --concr-string=the Show all functions that include given string + -q --equal-fields Show fields whose strings are always identical + -e --empty-fields Show fields whose strings are always empty + -u --unused-fields Show fields that never make it into the top category + -r --erased-trees Show trees that are erased + -o --old-grammar=ITEM Path to an earlier version of the grammar + --only-changed-cats When comparing against an earlier version of a + grammar, only test functions in categories that have + changed between versions + -b --treebank=ITEM Path to a treebank + --count-trees=3 Number of trees of depth <depth> + -d --debug Show debug output + -w --write-to-file Write the results in a file (<GRAMMAR>_<FUN>.org) + -? --help Display help message + -V --version Print version information +``` + +### Grammar: `-g` + +Give the PGF grammar as an argument with `-g`. If the file is not in +the same directory, you need to give the full file path. + +You can give the grammar with or without `.pgf`. + +Without a concrete syntax you can't do much, but you can see the +available categories and functions with `--show-cats` and `--show-funs` + +Examples: + +* `gftest -g Foods --show-funs` +* `gftest -g /home/inari/grammars/LangEng.pgf --show-cats` + + +### Language: `-l` + +Give a concrete language. It assumes the format `AbsNameConcName`, and you should only give the `ConcName` part. + +You can give multiple languages, in which case it will create the test cases based on the first, and show translations in the rest. + +Examples: + +* `gftest -g Phrasebook -l Swe --show-cats` +* `gftest -g Foods -l "Spa Eng" -f Pizza` + +### Function(s) to test: `-f` + +Given a grammar (`-g`) and a concrete language ( `-l`), test a function or several functions. + +Examples: + +* `gftest -g Lang -l "Dut Eng" -f UseN` +* `gftest -g Phrasebook -l Spa -f "ByTransp ByFoot"` + +You can use the wildcard `*`, if you want to match multiple functions. Examples: + +* `gftest -g Lang -l Eng -f "*hat*"` + +matches `hat_N, hate_V2, that_Quant, that_Subj, whatPl_IP` and `whatSg_IP`. + +* `gftest -g Lang -l Eng -f "*hat*u*"` + +matches `that_Quant` and `that_Subj`. + +* `gftest -g Lang -l Eng -f "*"` + +matches all functions in the grammar. (As of March 2018, takes 13 +minutes for the English resource grammar, and results in ~40k +lines. You may not want to do this for big grammars.) + +### Start category for context: `-s` + +Give a start category for contexts. Used in conjunction with `-f`, +`-c`, `-t` or `--count-trees`. If not specified, contexts are created +for the start category of the grammar. + +Example: + +* `gftest -g Lang -l "Dut Eng" -f UseN -s Adv` + +This creates a hole of `CN` in `Adv`, instead of the default start category. + +### Category to test: `-c` + +Given a grammar (`-g`) and a concrete language ( `-l`), test all functions that return a given category. + +Examples: + +* `gftest -g Phrasebook -l Fre -c Modality` +* `gftest -g Phrasebook -l Fre -c ByTransport -s Action` + + +### Tree to test: `-t` + +Given a grammar (`-g`) and a concrete language ( `-l`), test a complete tree. + +Example: + +* `gftest -g Phrasebook -l Dut -t "ByTransp Bus"` + +You can combine it with any of the other flags, e.g. put it in a +different start category: + +* `gftest -g Phrasebook -l Dut -t "ByTransp Bus" -s Action` + + +This may be useful for the following case. Say you tested `PrepNP`, +and the default NP it gave you only uses the word *car*, but you +would really want to see it for some other noun—maybe `car_N` itself +is buggy, and you want to be sure that `PrepNP` works properly. So +then you can call the following: + +* `gftest -g TestLang -l Eng -t "PrepNP with_Prep (MassNP (UseN beer_N))"` + +### Compare against an old version of the grammar: `-o` + +Give a grammar, a concrete syntax, and an old version of the same +grammar as a separate PGF file. The program generates test sentences +for all functions, linearises with both grammars, and outputs those +that differ between the versions. It writes the differences into files. + +Example: + +``` +> gftest -g TestLang -l Eng -o TestLangOld +Created file TestLangEng-ccat-diff.org +Testing functions in… +<categories flashing by> +Created file TestLangEng-lin-diff.org +Created files TestLangEng-(old|new)-funs.org +``` + +* TestLangEng-ccat-diff.org: All concrete categories that have + changed. Shows e.g. if you added or removed a parameter or a + field. + +* TestLangEng-lin-diff.org: All trees that have different +linearisations in the following format. **This is usually the most +relevant file.** +``` +* send_V3 + +** UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron we_Pron) (ReflVP (Slash3V3 ∅ (UsePron it_Pron)))) +TestLangDut> we sturen onszelf ernaar +TestLangDut-OLD> we sturen zichzelf ernaar + + +** UseCl (TTAnt TPast ASimul) PPos (PredVP (UsePron we_Pron) (ReflVP (Slash3V3 ∅ (UsePron it_Pron)))) +TestLangDut> we stuurden onszelf ernaar +TestLangDut-OLD> we stuurden zichzelf ernaar +``` + +* TestLangEng-old-funs.org and TestLangEng-new-funs.org: groups the + functions by their concrete categories. Shows difference if you have + e.g. added or removed parameters, and that has created new versions of + some functions: say you didn't have gender in nouns, but now you + have, then all functions taking nouns have suddenly a gendered + version. **This is kind of hard to read, don't worry too much if the + output doesn't make any sense.** + +You can give an additional parameter, `--only-changed-cats`, if you +only want to test functions in those categories that you have changed, +like this: `gftest -g TestLang -l Eng -o TestLangOld +--only-changed-cats`. This makes it run faster. + +### Information about a particular string: `--concr-string` + +Show all functions where the given concrete string appears as syncategorematic string (i.e. not from the arguments). + +Example: + +* `gftest -l Eng --concr-string it` + +which gives the answer `==> CleftAdv, CleftNP, DefArt, ImpersCl, it_Pron` + + +### Write into a file: `-w` + +Writes the results into a file of format `<GRAMMAR>_<FUN or CAT>.org`, +e.g. TestLangEng-UseN.org. Recommended to open it in emacs org-mode, +so you get an overview, and you can maybe ignore some trees if you +think they are redundant. + +1) When you open the file, you see a list of generated test cases, like this:  +Place cursor to the left and click tab to open it. + +2) You get a list of contexts for the test case. Keep the cursor where it was if you want to open everything at the same time. Alternatively, scroll down to one of the contexts and press tab there, if you only want to open one. + + +3) Now you can read the linearisations. + + +If you want to close the test case, just press tab again, keeping the +cursor where it's been all the time (line 31 in the pictures). + +## Less common use cases + +The topics here require some more obscure GF-fu. No need to worry if +the terms are not familiar to you. + + +### Empty or always identical fields: `-e`, `-q` + +Information about the fields: always empty, or always equal to each +other. Example of empty fields: + +``` +> gftest -g Lang -l Dut -e +* Empty fields: +==> Ant: s + +==> Pol: s + +==> Temp: s + +==> Tense: s + +==> V: particle, prefix +``` + +The categories `Ant`, `Pol`, `Temp` and `Tense` are as expected empty; +there's no string to be added to the sentences, just a parameter that +*chooses* the right forms of the clause. + +`V` having empty fields `particle` and `prefix` is in this case just +an artefact of a small lexicon: we happen to have no intransitive +verbs with a particle or prefix in the core 300-word vocabulary. But a +grammarian would know that it's still relevant to keep those fields, +because in some bigger application such a verb may show up. + +On the other hand, if some other field is always empty, it might be a +hint for the grammarian to remove it altogether. + +Example of equal fields: + +``` +> gftest -g Lang -l Dut -q +* Equal fields: +==> RCl: +s Pres Simul Pos Utr Pl +s Pres Simul Pos Neutr Pl + +==> RCl: +s Pres Simul Neg Utr Pl +s Pres Simul Neg Neutr Pl + +==> RCl: +s Pres Anter Pos Utr Pl +s Pres Anter Pos Neutr Pl + +==> RCl: +s Pres Anter Neg Utr Pl +s Pres Anter Neg Neutr Pl + +==> RCl: +s Past Simul Pos Utr Pl +s Past Simul Pos Neutr Pl +… +``` + +Here we can see that in relative clauses, gender does not seem to play +any role in plural. This could be a hint for the grammarian to make a +leaner parameter type, e.g. `param RClAgr = SgAgr <everything incl. gender> | PlAgr <no gender here>`. + + +### Unused fields: `-u` + +These fields are not empty, but they are never used in the top +category. The top category can be specified by `-s`, otherwise it is +the default start category of the grammar. + +Note that if you give a start category from very low, such as `Adv`, +you get a whole lot of categories and fields that naturally have no +way of ever making it into an adverb. So this is mostly meaningful to +use for the start category. + + +### Erased trees: `-r` + +Show trees that are erased in some function, i.e. a function `F : A -> B -> C` has arguments A and B, but doesn't use one of them in the resulting tree of type C. This is usually a bug. + +Example: + +`gftest -g Lang -l "Dut Eng" -r` + +output: +``` +* Erased trees: + +** RelCl (ExistNP something_NP) : RCl +- Tree: AdvS (PrepNP with_Prep (RelNP (UsePron it_Pron) (UseRCl (TTAnt TPres ASimul) PPos (RelCl (ExistNP something_NP))))) (UseCl (TTAnt TPres ASimul) PPos (ExistNP something_NP)) +- Lin: ermee is er iets +- Trans: with it, such that there is something, there is something + +** write_V2 : V2 +- Tree: AdvS (PrepNP with_Prep (PPartNP (UsePron it_Pron) write_V2)) (UseCl (TTAnt TPres ASimul) PPos (ExistNP something_NP)) +- Lin: ermee is er iets +- Trans: with it written there is something +``` + +In the first result, an argument of type `RCl` is missing in the tree constructed by `RelNP`, and in the second result, the argument `write_V2` is missing in the tree constructed by `PPartNP`. In both cases, the English linearisation contains all the arguments, but in the Dutch one they are missing. (This bug is already fixed, just showing it here to demonstrate the feature.) + + +### --show-coercions + +First I'll explain what *coercions* are, then why it may be +interesting to show them. Let's take a Spanish Foods grammar, and +consider the category `Quality`—those `Good Pizza` and `Vegan Pizza` +that you saw in the previous section. `Good` +"bueno/buena/buenos/buenas" goes before the noun it modifies, whereas +`Vegan` "vegano/vegana/…" goes after, so these will become different +*concrete categories* in the PGF: `Quality_before` and +`Quality_after`. (In reality, they are something like `Quality_7` and +`Quality_8` though.) + +Now, this difference is meaningful only when the adjective is modifying +the noun: "la buena pizza" vs. "la pizza vegana". But when the +adjective is in a predicative position, they both behave the same: +"la pizza es buena" and "la pizza es vegana". For this, the grammar +creates a *coercion*: both `Quality_before` and `Quality_after` may be +treated as `Quality_whatever`. To save some redundant work, this coercion `Quality_whatever` +appears in the type of predicative function, whereas the +modification function has to be split into two different functions, +one taking `Quality_before` and other `Quality_after`. + +Now you know what coercions are, this is how it looks like in the program: + +``` +> gftest -g Foods -l Spa --show-coercions +* Coercions in the grammar: +Quality_7--->_11 +Quality_8--->_11 +``` + +(Just mentally replace 7 with `before`, 8 with `after` and 11 with `whatever`.) + +### --count-trees + +Number of trees up to given size. Gives a number how many trees, and a +couple of examples from the highest size. Examples: + +``` +> gftest -g TestLang -l Eng --count-trees 10 +There are 675312 trees up to size 10, and 624512 of exactly size 10. +For example: +* AdvS today_Adv (UseCl (TTAnt TPres ASimul) PPos (ExistNP (UsePron i_Pron))) +* UseCl (TTAnt TCond AAnter) PNeg (PredVP (SelfNP (UsePron they_Pron)) UseCopula) +``` + +This counts the number of trees in the start category. You can also +specify a category: + +``` +> gftest -g TestLang -l Eng --count-trees 4 -s Adv +There are 2409 trees up to size 4, and 2163 of exactly size 4. +For example: +* AdAdv very_AdA (PositAdvAdj young_A) +* PrepNP above_Prep (UsePron they_Pron) +``` diff --git a/src/ui/android/build.xml b/src/ui/android/build.xml index a10a91491..d60bf62f2 100644 --- a/src/ui/android/build.xml +++ b/src/ui/android/build.xml @@ -87,6 +87,6 @@ in order to avoid having your file be overridden by tools such as "android update project" --> <!-- version-tag: 1 --> - <import file="${sdk.dir}/tools/ant/build.xml" /> + <import file="/Users/aarne/Library/Android/apache-ant-1.9.4/fetch.xml" /> </project> diff --git a/src/ui/android/jni/Android.mk b/src/ui/android/jni/Android.mk index 57a8e4f25..f1f697bed 100644 --- a/src/ui/android/jni/Android.mk +++ b/src/ui/android/jni/Android.mk @@ -5,7 +5,7 @@ include $(CLEAR_VARS) jni_c_files := jpgf.c jsg.c jni_utils.c sg_c_files := sg.c sqlite3Btree.c pgf_c_files := data.c expr.c graphviz.c linearizer.c literals.c parser.c parseval.c pgf.c printer.c reader.c \ -reasoner.c evaluator.c jit.c typechecker.c lookup.c aligner.c +reasoner.c evaluator.c jit.c typechecker.c lookup.c aligner.c writer.c gu_c_files := assert.c choice.c exn.c fun.c in.c map.c out.c utf8.c \ bits.c defs.c enum.c file.c hash.c mem.c prime.c seq.c string.c ucs.c variant.c diff --git a/src/ui/android/src/org/grammaticalframework/ui/android/Translator.java b/src/ui/android/src/org/grammaticalframework/ui/android/Translator.java index 69f1eff5d..4bfe9690a 100644 --- a/src/ui/android/src/org/grammaticalframework/ui/android/Translator.java +++ b/src/ui/android/src/org/grammaticalframework/ui/android/Translator.java @@ -44,7 +44,8 @@ public class Translator { new Language("ru-RU", "Russian", "AppRus", R.xml.cyrillic), new Language("es-ES", "Spanish", "AppSpa", R.xml.qwerty), new Language("sv-SE", "Swedish", "AppSwe", R.xml.nordic), - new Language("th-TH", "Thai", "AppTha", R.xml.thai_page1, R.xml.thai_page2) + new Language("th-TH", "Thai", "AppTha", R.xml.thai_page1, R.xml.thai_page2), + new Language("ur-PK", "Urdu", "AppUrd", R.xml.qwerty), // TODO language code and keyboard to check }; private Context mContext; diff --git a/src/www/gfse/editor.js b/src/www/gfse/editor.js index a579a5eea..ddd8e0058 100644 --- a/src/www/gfse/editor.js +++ b/src/www/gfse/editor.js @@ -126,35 +126,70 @@ function draw_grammar_list() { function rmpublic(file) { return function() { remove_public(file,draw_grammar_list) } } - publiclist.appendChild(wrap("h3",text("Public grammars"))) - if(files.length>0) { - var unique_id=local.get("unique_id","-") - var t=empty_class("table","grammar_list") - for(var i in files) { - var file=files[i].path - var parts=file.split(/[-.]/) - var basename=parts[0] - var unique_name=parts[1]+"-"+parts[2] - var mine = my_grammar(unique_name)!=null - var del = mine - ? delete_button(rmpublic(file),"Don't publish this grammar") - : [] - var tip = mine - ? "This is a copy of your grammar" - : "Click to download a copy of this grammar" - var modt=new Date(files[i].time) - var fmtmodt=modt.toDateString()+", "+modt.toTimeString().split(" ")[0] - var when=wrap_class("small","modtime",text(" "+fmtmodt)) - t.appendChild(edtr([td(del), - td(title(tip, - a(jsurl('open_public("'+file+'")'), - [text(basename)]))), - td(when)])) + var h=wrap("h3",text("Public grammars")) + var ordermenu=wrap("select",[option("Newest first","byAge"), + option("Alphabetical","byName")]) + ordermenu.value=local.get("publicOrder","byAge") + ordermenu.onchange=function(){ + local.put("publicOrder",ordermenu.value) + if(n>1) show_grammars() + } + var n=files.length + var count=n==1 ? " (One grammar)" : " ("+n + " grammars)" + var t=table(tr([td(h),td(text(count)),td(ordermenu)])) + publiclist.appendChild(t) + for(var i in files) { + var file=files[i] + file.t=new Date(file.time) + file.s=file.t.getTime() + } + function sort_grammars() { + switch(ordermenu.value) { + case "byAge": + files.sort((f1,f2)=>f2.s-f1.s) + break; + case "byName": + files.sort((f1,f2)=>(f1.path>f2.path)-(f1.path<f2.path)) } - publiclist.appendChild(t) } + var gt=empty_class("table","grammar_list") + publiclist.appendChild(gt) + function show_grammars() { + clear(gt) + if(files.length>0) { + sort_grammars() + var unique_id=local.get("unique_id","-") + for(var i in files) { + var file=files[i].path + var parts=file.split(/[-.]/) + var basename=parts[0] + var unique_name=parts[1]+"-"+parts[2] + var mine = my_grammar(unique_name)!=null + var from_me = parts[1] == unique_id + var del = from_me || mine + ? delete_button(rmpublic(file),"Remove this public grammar") + : [] + var tip = mine + ? "This is a copy of your grammar" + : "Click to download a copy of this grammar" + var modt=new Date(files[i].time) + var fmtmodt=modt.toDateString()+", "+modt.toTimeString().split(" ")[0] + var when=wrap_class("small","modtime",text(" "+fmtmodt)) + gt.appendChild(edtr([td(del), + td(title(tip, + a(jsurl('open_public("'+file+'")'), + [text(basename)]))), + td(text(files[i].comment||"")), + td(when)])) + } + } else publiclist.appendChild(p(text("No public grammars are available."))) + // This is outside the table so it won't be cleared, + // but show_grammars is only called once then there is less + // than 2 grammars, so it's OK. + } + show_grammars() } if(navigator.onLine) gfcloud_public_json("ls-l",{},show_public,no_public) @@ -799,7 +834,7 @@ function draw_abstract(g) { } function draw_comment(g) { - return div_class("comment",editable("span",text(g.comment || ""),g,edit_comment,"Edit grammar description")); + return div_class("comment",editable("span",text(g.comment || "…"),g,edit_comment,"Edit grammar description")); } function module_name(g,ix) { |