From e993ae59f8aed4a2b83fb48f4e62c1abf3a771a1 Mon Sep 17 00:00:00 2001 From: krangelov Date: Thu, 19 Sep 2019 10:06:06 +0200 Subject: [PATCH] drop the haskell runtime, part 2 --- gf.cabal | 21 +-- src/compiler/GF/Compile/GenerateBC.hs | 5 - src/compiler/GF/Infra/BuildInfo.hs | 6 - src/compiler/GF/Infra/SIO.hs | 10 -- src/compiler/GF/Server.hs | 5 +- src/server/PGFService.hs | 190 ++++++++------------------ 6 files changed, 61 insertions(+), 176 deletions(-) diff --git a/gf.cabal b/gf.cabal index 3a5f2822e..11830ddf0 100644 --- a/gf.cabal +++ b/gf.cabal @@ -67,29 +67,15 @@ flag network-uri description: Get Network.URI from the network-uri package 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 - hs-source-dirs: src/programs, src/runtime/haskell/binary + hs-source-dirs: src/programs main-is: gf-main.hs 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 ghc-options: -threaded - if flag(c-runtime) - build-depends: pgf2 - else - build-depends: pgf - if impl(ghc>=7.0) ghc-options: -rtsopts -with-rtsopts=-I5 if impl(ghc<7.8) @@ -223,9 +209,6 @@ executable gf Data.Binary.Builder Data.Binary.IEEE754 - if flag(c-runtime) - cpp-options: -DC_RUNTIME - if flag(server) build-depends: httpd-shed>=0.4.0.3, network>=2.3 && <2.7, json, cgi>=3001.2.2.0 diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs index d6d6f255c..d89792677 100644 --- a/src/compiler/GF/Compile/GenerateBC.hs +++ b/src/compiler/GF/Compile/GenerateBC.hs @@ -9,7 +9,6 @@ import qualified Data.Map as Map import Data.List(nub,mapAccumL) import Data.Maybe(fromMaybe) -#if C_RUNTIME generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]] generateByteCode gr arity eqs = 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 i 0 is = is push_is i n is = ARG_VAR i : push_is (i-1) (n-1) is - -#else -generateByteCode = error "generateByteCode is not implemented" -#endif diff --git a/src/compiler/GF/Infra/BuildInfo.hs b/src/compiler/GF/Infra/BuildInfo.hs index f0230246b..cba9bc0d0 100644 --- a/src/compiler/GF/Infra/BuildInfo.hs +++ b/src/compiler/GF/Infra/BuildInfo.hs @@ -14,9 +14,3 @@ buildInfo = #ifdef SERVER_MODE ++" server" #endif -#ifdef NEW_COMP - ++" new-comp" -#endif -#ifdef C_RUNTIME - ++" c-runtime" -#endif diff --git a/src/compiler/GF/Infra/SIO.hs b/src/compiler/GF/Infra/SIO.hs index 75c57601b..453b94348 100644 --- a/src/compiler/GF/Infra/SIO.hs +++ b/src/compiler/GF/Infra/SIO.hs @@ -12,9 +12,6 @@ module GF.Infra.SIO( newStdGen,print,putStr,putStrLn, -- ** Specific to GF importGrammar,importSource, -#ifdef C_RUNTIME - readPGF2, -#endif putStrLnFlush,runInterruptibly,lazySIO, -- * Restricted accesss to arbitrary (potentially unsafe) IO operations -- | 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.System.Signal as IO(runInterruptibly) import qualified GF.Command.Importing as GF(importGrammar, importSource) -#ifdef C_RUNTIME -import qualified PGF2 -#endif -- * The SIO monad @@ -123,7 +117,3 @@ lazySIO = lift1 lazyIO importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files importSource opts files = lift0 $ GF.importSource opts files - -#ifdef C_RUNTIME -readPGF2 = lift0 . PGF2.readPGF -#endif diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs index de0ec6abc..477f41e7c 100644 --- a/src/compiler/GF/Server.hs +++ b/src/compiler/GF/Server.hs @@ -179,7 +179,7 @@ handle logLn documentroot state0 cache execute1 stateVar translatePath rpath = rootrpath -- hmm, check for ".." - versionInfo (c1,c2) = + versionInfo c = html200 . unlines $ "": "": @@ -187,8 +187,7 @@ handle logLn documentroot state0 cache execute1 stateVar "": ("

"++hdr++"

"): (zipWith (++) ("

":repeat "
") buildinfo)++ - sh "Haskell run-time system" c1++ - sh "C run-time system" c2 + sh "Run-time system" c where hdr:buildinfo = lines gf_version rel = makeRelative documentroot diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 1774a8cff..23ecba22c 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -4,6 +4,7 @@ module PGFService(cgiMain,cgiMain',getPath, Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where import PGF (PGF,Labels,CncLabels) +import PGF2 import GF.Text.Lexing import qualified PGF import Cache @@ -15,11 +16,6 @@ import CGI(CGI,readInput,getInput,getVarWithDefault, Accept(..),Language(..),negotiate,liftIO) 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.Format(formatTime) #if MIN_VERSION_time(1,5,0) @@ -60,43 +56,18 @@ withQSem qsem = bracket_ (liftIO $ waitQSem qsem) (liftIO $ signalQSem qsem) logFile :: FilePath logFile = "pgf-error.log" -#ifdef C_RUNTIME -data Caches = Caches { pgfCache::Cache PGF, - 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)] +data Caches = Caches { qsem :: QSem, + pgfCache :: Cache PGF, + labelsCache :: Cache Labels } -newPGFCache jobs = do pgfCache <- newCache' PGF.readPGF - lblCache <- newCache' (fmap PGF.getDepLabels . readFile) - clblCache <- newCache'(fmap PGF.getCncDepLabels .readFile) - let n = maybe 4 id jobs +newPGFCache jobs = do let n = maybe 4 id jobs qsem <- newQSem n - cCache <- newCache' $ \ path -> do pgf <- C.readPGF path - --pc <- newMVar Map.empty - return (pgf,({-pc-})) - return $ Caches pgfCache lblCache clblCache (cCache,qsem) + pgfCache <- newCache' PGF.readPGF + lblCache <- newCache' (fmap PGF.getDepLabels . readFile) + return $ Caches qsem pgfCache lblCache flushPGFCache c = do flushCache (pgfCache c) flushCache (labelsCache c) - flushCache (fst (cpgfCache 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) +listPGFCache c = listCache (pgfCache c) newCache' rd = do c <- newCache rd forkIO $ forever $ clean c @@ -121,20 +92,8 @@ cgiMain' cache path = (getInput "command") case command of "download" -> outputBinary =<< getFile BS.readFile path - 'c':'-':_ -> optionalCpgfMain cache path command _ -> do tpgf <- getFile (readCache' (pgfCache cache)) path - pgfMain (labelsCaches cache) path 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 + pgfMain (qsem cache) command tpgf getFile get path = either failed return =<< liftIO (E.try (get path)) @@ -143,38 +102,34 @@ getFile get path = then notFound path else liftIO $ ioError e --------------------------------------------------------------------------------- --- * C run-time functionality -#ifdef C_RUNTIME ---cpgfMain :: String -> (C.PGF,MVar ParseCache) -> CGI CGIResult -cpgfMain qsem command (t,(pgf,pc)) = +pgfMain qsem command (t,pgf) = case command of - "c-parse" -> withQSem qsem $ + "parse" -> withQSem qsem $ out t=<< join (parse # input % start % limit % treeopts) - "c-linearize" -> out t=<< lin # tree % to - "c-linearizeAll"-> out t=<< linAll # tree % to - "c-translate" -> withQSem qsem $ + "linearize" -> out t=<< lin # tree % to + "linearizeAll"-> out t=<< linAll # tree % to + "translate" -> withQSem qsem $ out t=< out t=<< morpho # from1 % textInput - "c-flush" -> out t=<< flush - "c-grammar" -> out t grammar - "c-abstrtree" -> outputGraphviz=<< C.graphvizAbstractTree pgf C.graphvizDefaults # tree - "c-parsetree" -> outputGraphviz=<< (\cnc -> C.graphvizParseTree cnc C.graphvizDefaults) . snd # from1 %tree - "c-wordforword" -> out t =<< wordforword # input % to - _ -> badRequest "Unknown command" command + "lookupmorpho"-> out t=<< morpho # from1 % textInput + "flush" -> out t=<< flush + "grammar" -> out t grammar + "abstrtree" -> outputGraphviz=<< graphvizAbstractTree pgf graphvizDefaults # tree + "parsetree" -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from1 %tree + "wordforword" -> out t =<< wordforword # input % to + _ -> badRequest "Unknown command" command where flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty performGC return $ showJSON () - cat = C.startCat pgf - langs = C.languages pgf + cat = startCat pgf + langs = languages pgf grammar = showJSON $ makeObj - ["name".=C.abstractName pgf, + ["name".=abstractName pgf, "lastmodified".=show t, - "startcat".=C.showType [] (C.startCat pgf), + "startcat".=showType [] (startCat pgf), "languages".=languages] where 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 tp (tree,prob) = makeObj (addTree json tree++["prob".=prob]) - -- Without caching parse results: parse' start mlimit ((from,concr),input) = - 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 "") + case parseWithHeuristics concr cat input (-1) callbacks of + ParseOk ts -> return (Right (maybe id take mlimit (drop start ts))) + ParseFailed _ tok -> return (Left tok) + ParseIncomplete -> return (Left "") 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] -{- - -- 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 (tos,unlex) = [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 (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) = do parses <- parse' start mlimit input @@ -240,7 +178,7 @@ cpgfMain qsem command (t,(pgf,pc)) = morpho (from,concr) input = 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 @@ -259,7 +197,7 @@ cpgfMain qsem command (t,(pgf,pc)) = where lin_word' c = either id (lin1 c) - lin1 c = dropq . C.linearize c + lin1 c = dropq . linearize c where dropq (q:' ':s) | q `elem` "+*" = s dropq s = s @@ -278,12 +216,12 @@ cpgfMain qsem command (t,(pgf,pc)) = | isUpper c -> toLower c : cs s -> s - parse1 s = case C.parse concr cat s of - C.ParseOk ((t,_):ts) -> Just t - _ -> Nothing + parse1 s = case PGF2.parse concr cat s of + ParseOk ((t,_):ts) -> Just t + _ -> Nothing morph w = listToMaybe - [t | (f,a,p)<-C.lookupMorpho concr w, - t<-maybeToList (C.readExpr f)] + [t | (f,a,p)<-lookupMorpho concr w, + t<-maybeToList (readExpr f)] --- @@ -303,28 +241,17 @@ cpgfMain qsem command (t,(pgf,pc)) = getLangs = getLangs' readLang getLang = getLang' readLang - readLang :: String -> CGI (String,C.Concr) + readLang :: String -> CGI (String,Concr) readLang lang = case Map.lookup lang langs of Nothing -> badRequest "Bad language" lang Just c -> return (lang,c) tree = do s <- maybe (missing "tree") return =<< getInput1 "tree" - let t = C.readExpr s - maybe (badRequest "bad tree" s) return t + maybe (badRequest "bad tree" s) return (readExpr s) - 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 @@ -355,7 +282,7 @@ unlexer good = maybe (return id) unlexerfun =<< getInput "unlexer" -------------------------------------------------------------------------------- -- * Haskell run-time functionality - +{- --pgfMain :: Cache Labels -> FilePath -> String -> PGF -> CGI CGIResult pgfMain lcs@(alc,clc) path command tpgf@(t,pgf) = case command of @@ -464,7 +391,7 @@ pgfMain lcs@(alc,clc) path command tpgf@(t,pgf) = -- * Request parameter access and related auxiliary functions ---out = outputJSONP +-} out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t setHeader "Last-Modified" fmt outputJSONP r @@ -508,7 +435,7 @@ throw code msg extra = throwCGIError code msg [msg ++(if null extra then "" else ": "++extra)] format def = maybe def id # getInput "format" - +{- -- * Request implementations -- Hook for simple extensions of the PGF service @@ -537,11 +464,11 @@ doLookupMorpho pgf from input = where ms = PGF.lookupMorpho (PGF.buildMorpho pgf from) input - +-} type From = (Maybe PGF.Language,String) type To = ([PGF.Language],Unlexer) type TreeOpts = (Bool,Bool) -- (trie,jsontree) - +{- doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> TreeOpts -> JSValue doTranslate pgf (mfrom,input) mcat tos mlimit (trie,jsontree) = showJSON @@ -633,10 +560,10 @@ doParse pgf (mfrom,input) mcat mlimit (trie,jsontree) = showJSON $ map makeObj addTrie trie trees = ["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie] - +-} addTree json tree = "tree".=showTree tree: ["jsontree".= jsonExpr tree | json] - +{- doComplete :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue doComplete pgf (mfrom,input) mcat mlimit full = showJSON [makeObj ( @@ -732,7 +659,7 @@ doGrammar (t1,pgf) elbls macc = out t $ showJSON $ makeObj | l <- PGF.languages pgf] categories = [PGF.showCId cat | cat <- PGF.categories pgf] functions = [PGF.showCId fun | fun <- PGF.functions pgf] - +-} outputGraphviz code = do fmt <- format "png" case fmt of @@ -748,7 +675,7 @@ outputGraphviz code = "svg" -> "image/svg+xml" -- ... _ -> "application/binary" - +{- abstrTree pgf opts tree = PGF.graphvizAbstractTree pgf opts' tree 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 where tos' = if null tos then PGF.languages pgf else tos - +-} pipeIt2graphviz :: String -> String -> IO BS.ByteString pipeIt2graphviz fmt code = do (Just inh, Just outh, _, pid) <- @@ -821,7 +748,7 @@ pipeIt2graphviz fmt code = do case ex of ExitSuccess -> return output ExitFailure r -> fail ("pipeIt2graphviz: (exit " ++ show r ++ ")") - +{- browse1json pgf id pn = makeObj . maybe [] obj $ PGF.browse pgf id where 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 = "

"++(unwords pns)++"
" where pns = ["
"++(show lang)++"
"++(PGF.showPrintName pgf lang id)++"
" | lang <- PGF.languages pgf ] - +-} class ToATree a where showTree :: a -> String toATree :: a -> PGF.ATree a @@ -961,11 +888,7 @@ instance JSON PGF.Expr where instance JSON PGF.BracketedString where readJSON x = return (PGF.Leaf "") -#ifdef C_RUNTIME 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] showJSON (PGF.Leaf s) = makeObj ["token".=s] @@ -1038,3 +961,4 @@ f % x = ap f x --cleanFilePath :: FilePath -> FilePath --cleanFilePath = takeFileName +