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

drop the haskell runtime, part 2

Browse Source
This commit is contained in:
krangelov
2019-09-19 10:06:06 +02:00
parent f12557acf8
commit e993ae59f8
6 changed files with 61 additions and 176 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
gf.cabal
View File

@@ -67,29 +67,15 @@ flag network-uri
description: Get Network.URI from the network-uri package description: Get Network.URI from the network-uri package
default: True default: True
--flag new-comp
-- Description: Make -new-comp the default
-- Default: True
flag c-runtime
Description: Include functionality from the C run-time library (which must be installed already)
Default: False
executable gf executable gf
hs-source-dirs: src/programs, src/runtime/haskell/binary hs-source-dirs: src/programs
main-is: gf-main.hs main-is: gf-main.hs
default-language: Haskell2010 default-language: Haskell2010
build-depends: base, filepath, directory, time, time-compat, old-locale, pretty, mtl, array, random, build-depends: pgf2, base, filepath, directory, time, time-compat, old-locale, pretty, mtl, array, random,
process, haskeline, parallel>=3, exceptions, bytestring, utf8-string, containers process, haskeline, parallel>=3, exceptions, bytestring, utf8-string, containers
ghc-options: -threaded ghc-options: -threaded
if flag(c-runtime)
build-depends: pgf2
else
build-depends: pgf
if impl(ghc>=7.0) if impl(ghc>=7.0)
ghc-options: -rtsopts -with-rtsopts=-I5 ghc-options: -rtsopts -with-rtsopts=-I5
if impl(ghc<7.8) if impl(ghc<7.8)
@@ -223,9 +209,6 @@ executable gf
Data.Binary.Builder Data.Binary.Builder
Data.Binary.IEEE754 Data.Binary.IEEE754
if flag(c-runtime)
cpp-options: -DC_RUNTIME
if flag(server) if flag(server)
build-depends: httpd-shed>=0.4.0.3, network>=2.3 && <2.7, json, build-depends: httpd-shed>=0.4.0.3, network>=2.3 && <2.7, json,
cgi>=3001.2.2.0 cgi>=3001.2.2.0

5
src/compiler/GF/Compile/GenerateBC.hs
View File

@@ -9,7 +9,6 @@ import qualified Data.Map as Map
import Data.List(nub,mapAccumL) import Data.List(nub,mapAccumL)
import Data.Maybe(fromMaybe) import Data.Maybe(fromMaybe)
#if C_RUNTIME
generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]] generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]]
generateByteCode gr arity eqs = generateByteCode gr arity eqs =
let (bs,instrs) = compileEquations gr arity (arity+1) is let (bs,instrs) = compileEquations gr arity (arity+1) is
@@ -302,7 +301,3 @@ freeVars xs e = collectOp (freeVars xs) e
push_is :: Int -> Int -> [IVal] -> [IVal] push_is :: Int -> Int -> [IVal] -> [IVal]
push_is i 0 is = is push_is i 0 is = is
push_is i n is = ARG_VAR i : push_is (i-1) (n-1) is push_is i n is = ARG_VAR i : push_is (i-1) (n-1) is
#else
generateByteCode = error "generateByteCode is not implemented"
#endif

6
src/compiler/GF/Infra/BuildInfo.hs
View File

@@ -14,9 +14,3 @@ buildInfo =
#ifdef SERVER_MODE #ifdef SERVER_MODE
++" server" ++" server"
#endif #endif
#ifdef NEW_COMP
++" new-comp"
#endif
#ifdef C_RUNTIME
++" c-runtime"
#endif

10
src/compiler/GF/Infra/SIO.hs
View File

@@ -12,9 +12,6 @@ module GF.Infra.SIO(
newStdGen,print,putStr,putStrLn, newStdGen,print,putStr,putStrLn,
-- ** Specific to GF -- ** Specific to GF
importGrammar,importSource, importGrammar,importSource,
#ifdef C_RUNTIME
readPGF2,
#endif
putStrLnFlush,runInterruptibly,lazySIO, putStrLnFlush,runInterruptibly,lazySIO,
-- * Restricted accesss to arbitrary (potentially unsafe) IO operations -- * Restricted accesss to arbitrary (potentially unsafe) IO operations
-- | If the environment variable GF_RESTRICTED is defined, these -- | If the environment variable GF_RESTRICTED is defined, these
@@ -39,9 +36,6 @@ import qualified System.Random as IO(newStdGen)
import qualified GF.Infra.UseIO as IO(getLibraryDirectory) import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
import qualified GF.System.Signal as IO(runInterruptibly) import qualified GF.System.Signal as IO(runInterruptibly)
import qualified GF.Command.Importing as GF(importGrammar, importSource) import qualified GF.Command.Importing as GF(importGrammar, importSource)
#ifdef C_RUNTIME
import qualified PGF2
#endif
-- * The SIO monad -- * The SIO monad
@@ -123,7 +117,3 @@ lazySIO = lift1 lazyIO
importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files
importSource opts files = lift0 $ GF.importSource opts files importSource opts files = lift0 $ GF.importSource opts files
#ifdef C_RUNTIME
readPGF2 = lift0 . PGF2.readPGF
#endif

5
src/compiler/GF/Server.hs
View File

@@ -179,7 +179,7 @@ handle logLn documentroot state0 cache execute1 stateVar
translatePath rpath = root</>rpath -- hmm, check for ".." translatePath rpath = root</>rpath -- hmm, check for ".."
versionInfo (c1,c2) = versionInfo c =
html200 . unlines $ html200 . unlines $
"<!DOCTYPE html>": "<!DOCTYPE html>":
"<meta name = \"viewport\" content = \"width = device-width\">": "<meta name = \"viewport\" content = \"width = device-width\">":
@@ -187,8 +187,7 @@ handle logLn documentroot state0 cache execute1 stateVar
"": "":
("<h2>"++hdr++"</h2>"): ("<h2>"++hdr++"</h2>"):
(zipWith (++) ("<p>":repeat "<br>") buildinfo)++ (zipWith (++) ("<p>":repeat "<br>") buildinfo)++
sh "Haskell run-time system" c1++ sh "Run-time system" c
sh "C run-time system" c2
where where
hdr:buildinfo = lines gf_version hdr:buildinfo = lines gf_version
rel = makeRelative documentroot rel = makeRelative documentroot

190
src/server/PGFService.hs
View File

@@ -4,6 +4,7 @@ module PGFService(cgiMain,cgiMain',getPath,
Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
import PGF (PGF,Labels,CncLabels) import PGF (PGF,Labels,CncLabels)
import PGF2
import GF.Text.Lexing import GF.Text.Lexing
import qualified PGF import qualified PGF
import Cache import Cache
@@ -15,11 +16,6 @@ import CGI(CGI,readInput,getInput,getVarWithDefault,
Accept(..),Language(..),negotiate,liftIO) Accept(..),Language(..),negotiate,liftIO)
import URLEncoding import URLEncoding
#if C_RUNTIME
import qualified PGF2 as C
--import Data.Time.Clock(getCurrentTime,diffUTCTime)
#endif
import Data.Time.Clock(UTCTime) import Data.Time.Clock(UTCTime)
import Data.Time.Format(formatTime) import Data.Time.Format(formatTime)
#if MIN_VERSION_time(1,5,0) #if MIN_VERSION_time(1,5,0)
@@ -60,43 +56,18 @@ withQSem qsem = bracket_ (liftIO $ waitQSem qsem) (liftIO $ signalQSem qsem)
logFile :: FilePath logFile :: FilePath
logFile = "pgf-error.log" logFile = "pgf-error.log"
#ifdef C_RUNTIME data Caches = Caches { qsem :: QSem,
data Caches = Caches { pgfCache::Cache PGF, pgfCache :: Cache PGF,
labelsCache::Cache Labels, labelsCache :: Cache Labels }
cncLabelsCache::Cache CncLabels,
cpgfCache::(Cache (C.PGF,({-MVar ParseCache-})),QSem) }
--type Caches = (Cache PGF,Cache (C.PGF,({-MVar ParseCache-})))
--type ParseCache = Map.Map (String,String) (ParseResult,UTCTime)
--type ParseResult = Either String [(C.Expr,Float)]
newPGFCache jobs = do pgfCache <- newCache' PGF.readPGF newPGFCache jobs = do let n = maybe 4 id jobs
lblCache <- newCache' (fmap PGF.getDepLabels . readFile)
clblCache <- newCache'(fmap PGF.getCncDepLabels .readFile)
let n = maybe 4 id jobs
qsem <- newQSem n qsem <- newQSem n
cCache <- newCache' $ \ path -> do pgf <- C.readPGF path pgfCache <- newCache' PGF.readPGF
--pc <- newMVar Map.empty lblCache <- newCache' (fmap PGF.getDepLabels . readFile)
return (pgf,({-pc-})) return $ Caches qsem pgfCache lblCache
return $ Caches pgfCache lblCache clblCache (cCache,qsem)
flushPGFCache c = do flushCache (pgfCache c) flushPGFCache c = do flushCache (pgfCache c)
flushCache (labelsCache c) flushCache (labelsCache c)
flushCache (fst (cpgfCache c)) listPGFCache c = listCache (pgfCache c)
listPGFCache c = (,) # listCache (pgfCache c) % listCache (fst (cpgfCache c))
#else
data Caches = Caches { pgfCache::Cache PGF,
labelsCache::Cache Labels,
cncLabelsCache::Cache CncLabels }
newPGFCache _ = do pgfCache <- newCache' PGF.readPGF
lblCache <- newCache' (fmap PGF.getDepLabels . readFile)
clblCache <- newCache'(fmap PGF.getCncDepLabels .readFile)
return $ Caches pgfCache lblCache clblCache
flushPGFCache c = flushCache (pgfCache c)
listPGFCache :: Caches -> IO ([(FilePath,UTCTime)],[(FilePath,UTCTime)])
listPGFCache c = (,) # listCache (pgfCache c) % return []
#endif
labelsCaches c = (labelsCache c,cncLabelsCache c)
newCache' rd = do c <- newCache rd newCache' rd = do c <- newCache rd
forkIO $ forever $ clean c forkIO $ forever $ clean c
@@ -121,20 +92,8 @@ cgiMain' cache path =
(getInput "command") (getInput "command")
case command of case command of
"download" -> outputBinary =<< getFile BS.readFile path "download" -> outputBinary =<< getFile BS.readFile path
'c':'-':_ -> optionalCpgfMain cache path command
_ -> do tpgf <- getFile (readCache' (pgfCache cache)) path _ -> do tpgf <- getFile (readCache' (pgfCache cache)) path
pgfMain (labelsCaches cache) path command tpgf pgfMain (qsem cache) command tpgf
optionalCpgfMain cache path command =
#ifdef C_RUNTIME
cpgfMain (snd (cpgfCache cache)) command
=<< getFile (readCache' (fst (cpgfCache cache))) path
#else
serverError "Server configured without C run-time support" ""
serverError = throw 500
#endif
getFile get path = getFile get path =
either failed return =<< liftIO (E.try (get path)) either failed return =<< liftIO (E.try (get path))
@@ -143,38 +102,34 @@ getFile get path =
then notFound path then notFound path
else liftIO $ ioError e else liftIO $ ioError e
--------------------------------------------------------------------------------
-- * C run-time functionality
#ifdef C_RUNTIME pgfMain qsem command (t,pgf) =
--cpgfMain :: String -> (C.PGF,MVar ParseCache) -> CGI CGIResult
cpgfMain qsem command (t,(pgf,pc)) =
case command of case command of
"c-parse" -> withQSem qsem $ "parse" -> withQSem qsem $
out t=<< join (parse # input % start % limit % treeopts) out t=<< join (parse # input % start % limit % treeopts)
"c-linearize" -> out t=<< lin # tree % to "linearize" -> out t=<< lin # tree % to
"c-linearizeAll"-> out t=<< linAll # tree % to "linearizeAll"-> out t=<< linAll # tree % to
"c-translate" -> withQSem qsem $ "translate" -> withQSem qsem $
out t=<<join(trans # input % to % start % limit%treeopts) out t=<<join(trans # input % to % start % limit%treeopts)
"c-lookupmorpho"-> out t=<< morpho # from1 % textInput "lookupmorpho"-> out t=<< morpho # from1 % textInput
"c-flush" -> out t=<< flush "flush" -> out t=<< flush
"c-grammar" -> out t grammar "grammar" -> out t grammar
"c-abstrtree" -> outputGraphviz=<< C.graphvizAbstractTree pgf C.graphvizDefaults # tree "abstrtree" -> outputGraphviz=<< graphvizAbstractTree pgf graphvizDefaults # tree
"c-parsetree" -> outputGraphviz=<< (\cnc -> C.graphvizParseTree cnc C.graphvizDefaults) . snd # from1 %tree "parsetree" -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from1 %tree
"c-wordforword" -> out t =<< wordforword # input % to "wordforword" -> out t =<< wordforword # input % to
_ -> badRequest "Unknown command" command _ -> badRequest "Unknown command" command
where where
flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
performGC performGC
return $ showJSON () return $ showJSON ()
cat = C.startCat pgf cat = startCat pgf
langs = C.languages pgf langs = languages pgf
grammar = showJSON $ makeObj grammar = showJSON $ makeObj
["name".=C.abstractName pgf, ["name".=abstractName pgf,
"lastmodified".=show t, "lastmodified".=show t,
"startcat".=C.showType [] (C.startCat pgf), "startcat".=showType [] (startCat pgf),
"languages".=languages] "languages".=languages]
where where
languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs] languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs]
@@ -189,40 +144,23 @@ cpgfMain qsem command (t,(pgf,pc)) =
good trees = "trees".=map tp trees :[] -- :addTrie trie trees good trees = "trees".=map tp trees :[] -- :addTrie trie trees
tp (tree,prob) = makeObj (addTree json tree++["prob".=prob]) tp (tree,prob) = makeObj (addTree json tree++["prob".=prob])
-- Without caching parse results:
parse' start mlimit ((from,concr),input) = parse' start mlimit ((from,concr),input) =
case C.parseWithHeuristics concr cat input (-1) callbacks of case parseWithHeuristics concr cat input (-1) callbacks of
C.ParseOk ts -> return (Right (maybe id take mlimit (drop start ts))) ParseOk ts -> return (Right (maybe id take mlimit (drop start ts)))
C.ParseFailed _ tok -> return (Left tok) ParseFailed _ tok -> return (Left tok)
C.ParseIncomplete -> return (Left "") ParseIncomplete -> return (Left "")
where where
callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.literalCallbacks callbacks = maybe [] cb $ lookup (abstractName pgf) literalCallbacks
cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs] cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs]
{-
-- Caching parse results:
parse' start mlimit ((from,concr),input) =
liftIO $ do t <- getCurrentTime
fmap (maybe id take mlimit . drop start)
# modifyMVar pc (parse'' t)
where
key = (from,input)
parse'' t pc = maybe new old $ Map.lookup key pc
where
new = return (update (res,t) pc,res)
where res = C.parse concr cat input
old (res,_) = return (update (res,t) pc,res)
update r = Map.mapMaybe purge . Map.insert key r
purge r@(_,t') = if diffUTCTime t t'<120 then Just r else Nothing
-- remove unused parse results after 2 minutes
-}
linAll tree to = showJSON (linAll' tree to) linAll tree to = showJSON (linAll' tree to)
linAll' tree (tos,unlex) = linAll' tree (tos,unlex) =
[makeObj ["to".=to, [makeObj ["to".=to,
"texts".=map unlex (C.linearizeAll c tree)]|(to,c)<-tos] "texts".=map unlex (linearizeAll c tree)]|(to,c)<-tos]
lin tree to = showJSON (lin' tree to) lin tree to = showJSON (lin' tree to)
lin' tree (tos,unlex) = lin' tree (tos,unlex) =
[makeObj ["to".=to,"text".=unlex (C.linearize c tree)]|(to,c)<-tos] [makeObj ["to".=to,"text".=unlex (linearize c tree)]|(to,c)<-tos]
trans input@((from,_),_) to start mlimit (trie,jsontree) = trans input@((from,_),_) to start mlimit (trie,jsontree) =
do parses <- parse' start mlimit input do parses <- parse' start mlimit input
@@ -240,7 +178,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
morpho (from,concr) input = morpho (from,concr) input =
showJSON [makeObj ["lemma".=l,"analysis".=a,"prob".=p]|(l,a,p)<-ms] showJSON [makeObj ["lemma".=l,"analysis".=a,"prob".=p]|(l,a,p)<-ms]
where ms = C.lookupMorpho concr input where ms = lookupMorpho concr input
wordforword input@((from,_),_) = jsonWFW from . wordforword' input wordforword input@((from,_),_) = jsonWFW from . wordforword' input
@@ -259,7 +197,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
where where
lin_word' c = either id (lin1 c) lin_word' c = either id (lin1 c)
lin1 c = dropq . C.linearize c lin1 c = dropq . linearize c
where where
dropq (q:' ':s) | q `elem` "+*" = s dropq (q:' ':s) | q `elem` "+*" = s
dropq s = s dropq s = s
@@ -278,12 +216,12 @@ cpgfMain qsem command (t,(pgf,pc)) =
| isUpper c -> toLower c : cs | isUpper c -> toLower c : cs
s -> s s -> s
parse1 s = case C.parse concr cat s of parse1 s = case PGF2.parse concr cat s of
C.ParseOk ((t,_):ts) -> Just t ParseOk ((t,_):ts) -> Just t
_ -> Nothing _ -> Nothing
morph w = listToMaybe morph w = listToMaybe
[t | (f,a,p)<-C.lookupMorpho concr w, [t | (f,a,p)<-lookupMorpho concr w,
t<-maybeToList (C.readExpr f)] t<-maybeToList (readExpr f)]
--- ---
@@ -303,28 +241,17 @@ cpgfMain qsem command (t,(pgf,pc)) =
getLangs = getLangs' readLang getLangs = getLangs' readLang
getLang = getLang' readLang getLang = getLang' readLang
readLang :: String -> CGI (String,C.Concr) readLang :: String -> CGI (String,Concr)
readLang lang = readLang lang =
case Map.lookup lang langs of case Map.lookup lang langs of
Nothing -> badRequest "Bad language" lang Nothing -> badRequest "Bad language" lang
Just c -> return (lang,c) Just c -> return (lang,c)
tree = do s <- maybe (missing "tree") return =<< getInput1 "tree" tree = do s <- maybe (missing "tree") return =<< getInput1 "tree"
let t = C.readExpr s maybe (badRequest "bad tree" s) return (readExpr s)
maybe (badRequest "bad tree" s) return t
c_lexer concr = lexer (not . null . C.lookupMorpho concr) c_lexer concr = lexer (not . null . lookupMorpho concr)
--------------------------------------------------------------------------------
-- | Convert a 'Tree' to an 'ATree'
cToATree :: C.Expr -> PGF.ATree C.Expr
cToATree e = maybe (PGF.Other e) app (C.unApp e)
where
app (f,es) = PGF.App (read f) (map cToATree es)
#endif
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- * Lexing -- * Lexing
@@ -355,7 +282,7 @@ unlexer good = maybe (return id) unlexerfun =<< getInput "unlexer"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- * Haskell run-time functionality -- * Haskell run-time functionality
{-
--pgfMain :: Cache Labels -> FilePath -> String -> PGF -> CGI CGIResult --pgfMain :: Cache Labels -> FilePath -> String -> PGF -> CGI CGIResult
pgfMain lcs@(alc,clc) path command tpgf@(t,pgf) = pgfMain lcs@(alc,clc) path command tpgf@(t,pgf) =
case command of case command of
@@ -464,7 +391,7 @@ pgfMain lcs@(alc,clc) path command tpgf@(t,pgf) =
-- * Request parameter access and related auxiliary functions -- * Request parameter access and related auxiliary functions
--out = outputJSONP -}
out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t
setHeader "Last-Modified" fmt setHeader "Last-Modified" fmt
outputJSONP r outputJSONP r
@@ -508,7 +435,7 @@ throw code msg extra =
throwCGIError code msg [msg ++(if null extra then "" else ": "++extra)] throwCGIError code msg [msg ++(if null extra then "" else ": "++extra)]
format def = maybe def id # getInput "format" format def = maybe def id # getInput "format"
{-
-- * Request implementations -- * Request implementations
-- Hook for simple extensions of the PGF service -- Hook for simple extensions of the PGF service
@@ -537,11 +464,11 @@ doLookupMorpho pgf from input =
where where
ms = PGF.lookupMorpho (PGF.buildMorpho pgf from) input ms = PGF.lookupMorpho (PGF.buildMorpho pgf from) input
-}
type From = (Maybe PGF.Language,String) type From = (Maybe PGF.Language,String)
type To = ([PGF.Language],Unlexer) type To = ([PGF.Language],Unlexer)
type TreeOpts = (Bool,Bool) -- (trie,jsontree) type TreeOpts = (Bool,Bool) -- (trie,jsontree)
{-
doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> TreeOpts -> JSValue doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> TreeOpts -> JSValue
doTranslate pgf (mfrom,input) mcat tos mlimit (trie,jsontree) = doTranslate pgf (mfrom,input) mcat tos mlimit (trie,jsontree) =
showJSON showJSON
@@ -633,10 +560,10 @@ doParse pgf (mfrom,input) mcat mlimit (trie,jsontree) = showJSON $ map makeObj
addTrie trie trees = addTrie trie trees =
["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie] ["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie]
-}
addTree json tree = "tree".=showTree tree: addTree json tree = "tree".=showTree tree:
["jsontree".= jsonExpr tree | json] ["jsontree".= jsonExpr tree | json]
{-
doComplete :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue doComplete :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue
doComplete pgf (mfrom,input) mcat mlimit full = showJSON doComplete pgf (mfrom,input) mcat mlimit full = showJSON
[makeObj ( [makeObj (
@@ -732,7 +659,7 @@ doGrammar (t1,pgf) elbls macc = out t $ showJSON $ makeObj
| l <- PGF.languages pgf] | l <- PGF.languages pgf]
categories = [PGF.showCId cat | cat <- PGF.categories pgf] categories = [PGF.showCId cat | cat <- PGF.categories pgf]
functions = [PGF.showCId fun | fun <- PGF.functions pgf] functions = [PGF.showCId fun | fun <- PGF.functions pgf]
-}
outputGraphviz code = outputGraphviz code =
do fmt <- format "png" do fmt <- format "png"
case fmt of case fmt of
@@ -748,7 +675,7 @@ outputGraphviz code =
"svg" -> "image/svg+xml" "svg" -> "image/svg+xml"
-- ... -- ...
_ -> "application/binary" _ -> "application/binary"
{-
abstrTree pgf opts tree = PGF.graphvizAbstractTree pgf opts' tree abstrTree pgf opts tree = PGF.graphvizAbstractTree pgf opts' tree
where opts' = (not (PGF.noFun opts),not (PGF.noCat opts)) where opts' = (not (PGF.noFun opts),not (PGF.noCat opts))
@@ -789,7 +716,7 @@ tryIO = E.try
alignment pgf tree (tos,unlex) = PGF.graphvizAlignment pgf tos' tree alignment pgf tree (tos,unlex) = PGF.graphvizAlignment pgf tos' tree
where tos' = if null tos then PGF.languages pgf else tos where tos' = if null tos then PGF.languages pgf else tos
-}
pipeIt2graphviz :: String -> String -> IO BS.ByteString pipeIt2graphviz :: String -> String -> IO BS.ByteString
pipeIt2graphviz fmt code = do pipeIt2graphviz fmt code = do
(Just inh, Just outh, _, pid) <- (Just inh, Just outh, _, pid) <-
@@ -821,7 +748,7 @@ pipeIt2graphviz fmt code = do
case ex of case ex of
ExitSuccess -> return output ExitSuccess -> return output
ExitFailure r -> fail ("pipeIt2graphviz: (exit " ++ show r ++ ")") ExitFailure r -> fail ("pipeIt2graphviz: (exit " ++ show r ++ ")")
{-
browse1json pgf id pn = makeObj . maybe [] obj $ PGF.browse pgf id browse1json pgf id pn = makeObj . maybe [] obj $ PGF.browse pgf id
where where
obj (def,ps,cs) = if pn then (baseobj ++ pnames) else baseobj obj (def,ps,cs) = if pn then (baseobj ++ pnames) else baseobj
@@ -921,7 +848,7 @@ doBrowse pgf (Just id) cssClass href _ pn = -- default to "html" format
annotatePrintNames = "<DL>"++(unwords pns)++"</DL>" annotatePrintNames = "<DL>"++(unwords pns)++"</DL>"
where pns = ["<DT>"++(show lang)++"</DT><DD>"++(PGF.showPrintName pgf lang id)++"</DD>" | lang <- PGF.languages pgf ] where pns = ["<DT>"++(show lang)++"</DT><DD>"++(PGF.showPrintName pgf lang id)++"</DD>" | lang <- PGF.languages pgf ]
-}
class ToATree a where class ToATree a where
showTree :: a -> String showTree :: a -> String
toATree :: a -> PGF.ATree a toATree :: a -> PGF.ATree a
@@ -961,11 +888,7 @@ instance JSON PGF.Expr where
instance JSON PGF.BracketedString where instance JSON PGF.BracketedString where
readJSON x = return (PGF.Leaf "") readJSON x = return (PGF.Leaf "")
#ifdef C_RUNTIME
showJSON (PGF.Bracket cat fid index fun bs) = showJSON (PGF.Bracket cat fid index fun bs) =
#else
showJSON (PGF.Bracket cat fid index fun _ bs) =
#endif
makeObj ["cat".=cat, "fid".=fid, "index".=index, "fun".=fun, "children".=bs] makeObj ["cat".=cat, "fid".=fid, "index".=index, "fun".=fun, "children".=bs]
showJSON (PGF.Leaf s) = makeObj ["token".=s] showJSON (PGF.Leaf s) = makeObj ["token".=s]
@@ -1038,3 +961,4 @@ f % x = ap f x
--cleanFilePath :: FilePath -> FilePath --cleanFilePath :: FilePath -> FilePath
--cleanFilePath = takeFileName --cleanFilePath = takeFileName