diff --git a/gf.cabal b/gf.cabal index c70d4315c..1dc53d6ca 100644 --- a/gf.cabal +++ b/gf.cabal @@ -212,6 +212,41 @@ executable gf terminfo >=0.4.0 && < 0.5, unix >= 2.7.2 && < 2.8 + if flag(server) + build-depends: + cgi >= 3001.3.0.2 && < 3001.6, + httpd-shed >= 0.4.0 && < 0.5, + network>=2.3 && <2.7 + if flag(network-uri) + build-depends: + network-uri >= 2.6.1.0 && < 2.7, + network>=2.6 && <2.7 + else + build-depends: + network >= 2.5 && <2.6 + + cpp-options: -DSERVER_MODE + other-modules: + GF.Server + PGFService + RunHTTP + SimpleEditor.Convert + SimpleEditor.JSON + SimpleEditor.Syntax + URLEncoding + CGI + CGIUtils + Cache + hs-source-dirs: + src/server + src/server/transfer + + if flag(interrupt) + cpp-options: -DUSE_INTERRUPT + other-modules: GF.System.UseSignal + else + other-modules: GF.System.NoSignal + test-suite gf-tests type: exitcode-stdio-1.0 main-is: run.hs diff --git a/src/compiler/SimpleEditor/Convert.hs b/src/compiler/SimpleEditor/Convert.hs index 491a7a5b3..95a3359b1 100644 --- a/src/compiler/SimpleEditor/Convert.hs +++ b/src/compiler/SimpleEditor/Convert.hs @@ -17,7 +17,7 @@ import GF.Grammar.Printer(ppParams,ppTerm,getAbs,TermPrintQual(..)) import GF.Grammar.Parser(runP,pModDef) import GF.Grammar.Lexer(Posn(..)) import GF.Data.ErrM -import PGF2.Internal(Literal(LStr)) +import PGF2(Literal(LStr)) import SimpleEditor.Syntax as S import SimpleEditor.JSON @@ -119,7 +119,7 @@ convCncJment (name,jment) = case jment of ResParam ops _ -> return $ Pa $ Param i (maybe "" (render . ppParams q . unLoc) ops) - ResValue _ -> return Ignored + ResValue _ _ -> return Ignored CncCat (Just (L _ typ)) Nothing Nothing pprn _ -> -- ignores printname !! return $ LC $ Lincat i (render $ ppTerm q 0 typ) ResOper oltyp (Just lterm) -> return $ Op $ Oper lhs rhs diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 5022d2f6d..a7f388c66 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -44,7 +44,6 @@ import System.IO.Error(isDoesNotExistError) import System.Directory(removeFile) import System.FilePath(dropExtension,takeDirectory,(),(<.>)) import System.Mem(performGC) -import Fold(fold) -- transfer function for OpenMath LaTeX catchIOE :: IO a -> (E.IOException -> IO a) -> IO a catchIOE = E.catch @@ -103,62 +102,39 @@ getFile get path = pgfMain qsem command (t,pgf) = case command of -<<<<<<< HEAD - "parse" -> withQSem qsem $ - out t=<< join (parse # input % start % limit % treeopts) - "linearize" -> out t=<< lin # tree % to - "bracketedLinearize" - -> out t=<< bracketedLin # tree % to - "linearizeAll"-> out t=<< linAll # tree % to - "translate" -> withQSem qsem $ - out t=< 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 -======= - "c-parse" -> withQSem qsem $ + "parse" -> withQSem qsem $ out t=<< join (parse # input % cat % start % limit % treeopts) - "c-parseToChart"-> withQSem qsem $ - out t=<< join (parseToChart # input % cat % limit) - "c-linearize" -> out t=<< lin # tree % to - "c-bracketedLinearize" +-- "parseToChart" -> withQSem qsem $ +-- out t=<< join (parseToChart # input % cat % limit) + "linearize" -> out t=<< lin # tree % to + "bracketedLinearize" -> out t=<< bracketedLin # tree % to - "c-linearizeAll"-> out t=<< linAll # tree % to - "c-translate" -> withQSem qsem $ + "linearizeAll" -> out t=<< linAll # tree % to + "translate" -> withQSem qsem $ out t=< out t=<< morpho # from1 % textInput - "c-lookupcohorts"->out t=<< cohorts # from1 % getInput "filter" % 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 % cat % to + "lookupmorpho" -> out t=<< morpho # from1 % textInput + "lookupcohorts" -> out t=<< cohorts # from1 % getInput "filter" % 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 % cat % to _ -> badRequest "Unknown command" command ->>>>>>> master where flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty performGC return $ showJSON () -<<<<<<< HEAD - cat = startCat pgf - langs = languages pgf -======= - cat :: CGI C.Type + cat :: CGI Type cat = do mcat <- getInput1 "cat" case mcat of - Nothing -> return (C.startCat pgf) - Just cat -> case C.readType cat of + Nothing -> return (startCat pgf) + Just cat -> case readType cat of Nothing -> badRequest "Bad category" cat Just typ -> return typ - langs = C.languages pgf ->>>>>>> master + langs = languages pgf grammar = showJSON $ makeObj ["name".=abstractName pgf, @@ -180,48 +156,20 @@ pgfMain qsem command (t,pgf) = ,"prob".=prob ] -<<<<<<< HEAD - parse' start mlimit ((from,concr),input) = + -- Without caching parse results: + parse' cat start mlimit ((from,concr),input) = 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 "") -======= - -- Without caching parse results: - parse' cat 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 "") ->>>>>>> master - where - callbacks = maybe [] cb $ lookup (abstractName pgf) literalCallbacks - cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs] -<<<<<<< HEAD -======= -{- - -- 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 --} + where + callbacks = undefined - parseToChart ((from,concr),input) cat mlimit = + parseToChart ((from,concr),input) cat mlimit = undefined {- do r <- case C.parseToChart concr cat input (-1) callbacks (fromMaybe 5 mlimit) of - C.ParseOk chart -> return (good chart) - C.ParseFailed _ tok -> return (bad tok) - C.ParseIncomplete -> return (bad "") + ParseOk chart -> return (good chart) + ParseFailed _ tok -> return (bad tok) + ParseIncomplete -> return (bad "") return $ showJSON [makeObj ("from".=from:r)] where callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.literalCallbacks @@ -243,9 +191,8 @@ pgfMain qsem command (t,pgf) = mkChartProd (expr,args,prob) = makeObj ["tree".=expr,"args".=map mkChartPArg args,"prob".=prob] - mkChartPArg (C.PArg _ fid) = showJSON fid ->>>>>>> master - + mkChartPArg (PArg _ fid) = showJSON fid +-} linAll tree to = showJSON (linAll' tree to) linAll' tree (tos,unlex) = [makeObj ["to".=to, @@ -274,17 +221,10 @@ pgfMain qsem command (t,pgf) = | (tree,prob) <- parses] morpho (from,concr) input = -<<<<<<< HEAD - showJSON [makeObj ["lemma".=l,"analysis".=a,"prob".=p]|(l,a,p)<-ms] - where ms = lookupMorpho concr input - - - wordforword input@((from,_),_) = jsonWFW from . wordforword' input -======= showJSON [makeObj ["lemma".=l ,"analysis".=a ,"prob".=p] - | (l,a,p)<-C.lookupMorpho concr input] + | (l,a,p)<-lookupMorpho concr input] cohorts (from,concr) filter input = showJSON [makeObj ["start" .=showJSON s @@ -296,13 +236,12 @@ pgfMain qsem command (t,pgf) = ,"end" .=showJSON e ] | (s,w,ms,e) <- (case filter of - Just "longest" -> C.filterLongest - Just "best" -> C.filterBest + Just "longest" -> filterLongest + Just "best" -> filterBest _ -> id) - (C.lookupCohorts concr input)] + (lookupCohorts concr input)] wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat ->>>>>>> master jsonWFW from rs = showJSON @@ -408,118 +347,6 @@ unlexer' defaultUnlexer good = cleanMarker ('*':cs) = cs cleanMarker cs = cs --------------------------------------------------------------------------------- --- * Haskell run-time functionality -{- ---pgfMain :: Cache Labels -> FilePath -> String -> PGF -> CGI CGIResult -pgfMain lcs@(alc,clc) path command tpgf@(t,pgf) = - case command of - "parse" -> o =<< doParse pgf # input % cat % limit % treeopts - "complete" -> o =<< doComplete pgf # input % cat % limit % full - "linearize" -> o =<< doLinearize pgf # tree % to - "linearizeAll" -> o =<< doLinearizes pgf # tree % to - "linearizeTable" -> o =<< doLinearizeTabular pgf # tree % to - "random" -> o =<< join (doRandom pgf # cat % depth % limit % to) - "generate" -> o =<< doGenerate pgf # cat % depth % limit % to - "translate" -> o =<< doTranslate pgf # input % cat %to%limit%treeopts - "translategroup" -> o =<< doTranslateGroup pgf # input % cat % to % limit - "lookupmorpho" -> o =<< doLookupMorpho pgf # from1 % textInput - "grammar" -> join $ doGrammar tpgf - # liftIO (E.try (getLabels alc path pgf)) - % requestAcceptLanguage - "abstrtree" -> outputGraphviz =<< abstrTree pgf # graphvizOptions % tree - "alignment" -> outputGraphviz =<< alignment pgf # tree % to - "parsetree" -> outputGraphviz =<< parseTree pgf # from1 % graphvizOptions % tree - "deptree" -> join $ doDepTree lcs path pgf # format "dot" % to1 % tree - "abstrjson" -> o . jsonExpr =<< tree - "browse" -> join $ doBrowse pgf # optId % cssClass % href % format "html" % getIncludePrintNames - "external" -> do cmd <- getInput "external" - doExternal cmd =<< textInput - _ -> badRequest "Unknown command" command - where - o x = out t x - - input = do fr <- from - lex <- mlexer fr - inp <- textInput - return (fr,lex inp) - - mlexer Nothing = lexer (const False) - mlexer (Just lang) = lexer (PGF.isInMorpho morpho) - where morpho = PGF.buildMorpho pgf lang - - tree :: CGI PGF.Tree - tree = do ms <- getInput "tree" - s <- maybe (badRequest "No tree given" "") return ms - t <- maybe (badRequest "Bad tree" s) return (PGF.readExpr s) - t <- either (\err -> badRequest "Type incorrect tree" - (unlines $ - [PGF.showExpr [] t - ,render (PP.text "error:" <+> PGF.ppTcError err) - ])) - (return . fst) - (PGF.inferExpr pgf t) - return t - - cat :: CGI (Maybe PGF.Type) - cat = - do mcat <- getInput1 "cat" - case mcat of - Nothing -> return Nothing - Just cat -> case PGF.readType cat of - Nothing -> badRequest "Bad category" cat - Just typ -> return $ Just typ -- typecheck the category - - optId :: CGI (Maybe PGF.CId) - optId = maybe (return Nothing) rd =<< getInput "id" - where - rd = maybe err (return . Just) . PGF.readCId - err = badRequest "Bad identifier" [] - - cssClass, href :: CGI (Maybe String) - cssClass = getInput "css-class" - href = getInput "href" - - getIncludePrintNames :: CGI Bool - getIncludePrintNames = maybe False (const True) # getInput "printnames" - - graphvizOptions = - PGF.GraphvizOptions # bool "noleaves" - % bool "nofun" - % bool "nocat" - % bool "nodep" - % string "nodefont" - % string "leaffont" - % string "nodecolor" - % string "leafcolor" - % string "nodeedgestyle" - % string "leafedgestyle" - where - string name = maybe "" id # getInput name - bool name = maybe False toBool # getInput name - - from1 = maybe (missing "from") return =<< from - from = getLang "from" - - to1 = maybe (missing "to") return =<< getLang "to" - to = (,) # getLangs "to" % unlexerH - - getLangs = getLangs' readLang - getLang = getLang' readLang - - readLang :: String -> CGI PGF.Language - readLang l = - case PGF.readLanguage l of - Nothing -> badRequest "Bad language" l - Just lang | lang `elem` PGF.languages pgf -> return lang - | otherwise -> badRequest "Unknown language" l - - full :: CGI Bool - full = maybe False toBool # getInput "full" - --- * Request parameter access and related auxiliary functions - --} out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t setHeader "Last-Modified" fmt outputJSONP r @@ -563,228 +390,11 @@ 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 -doExternal Nothing input = badRequest "Unknown external command" "" -doExternal (Just cmd) input = - do liftIO $ logError ("External command: "++cmd) - cmds <- liftIO $ (fmap lines $ readFile "external_services") - `catchIOE` const (return []) - liftIO $ logError ("External services: "++show cmds) - if cmd `elem` cmds then ok else err - where - err = badRequest "Unknown external command" cmd - ok = - do let tmpfile1 = "external_input.txt" - tmpfile2 = "external_output.txt" - liftIO $ writeFile "external_input.txt" input - liftIO $ system $ cmd ++ " " ++ tmpfile1 ++ " > " ++ tmpfile2 - liftIO $ removeFile tmpfile1 - r <- outputJSONP =<< liftIO (readFile tmpfile2) - liftIO $ removeFile tmpfile2 - return r - -doLookupMorpho :: PGF -> PGF.Language -> String -> JSValue -doLookupMorpho pgf from input = - showJSON [makeObj ["lemma".=l,"analysis".=a]|(l,a)<-ms] - where - ms = PGF.lookupMorpho (PGF.buildMorpho pgf from) input - --} type From = (Maybe Concr,String) type To = ([Concr],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 - [makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po) - | (from,po,bs) <- parse' pgf input mcat mfrom] - where - jsonTranslateOutput output = - case output of - PGF.ParseOk trees -> - addTrie trie trees++ - ["translations".= - [makeObj (addTree jsontree tree++ - ["linearizations".= - [makeObj ["to".=to, "text".=text, - "brackets".=bs] - | (to,text,bs)<- linearizeAndUnlex pgf tos tree]]) - | tree <- maybe id take mlimit trees]] - PGF.ParseIncomplete -> ["incomplete".=True] - PGF.ParseFailed n -> ["parseFailed".=n] - PGF.TypeError errs -> jsonTypeErrors errs -jsonTypeErrors errs = - ["typeErrors".= [makeObj ["fid".=fid, "msg".=show (PGF.ppTcError err)] - | (fid,err) <- errs]] - --- used in phrasebook -doTranslateGroup :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> JSValue -doTranslateGroup pgf (mfrom,input) mcat tos mlimit = - showJSON - [makeObj ["from".=langOnly (PGF.showLanguage from), - "to".=langOnly (PGF.showLanguage to), - "linearizations".= - [toJSObject (("text",alt) : disamb lg from ts) - | let lg = length output, (ts,alt) <- output] - ] - | - (from,po,bs) <- parse' pgf input mcat mfrom, - (to,output) <- groupResults [(t, linearizeAndUnlex pgf tos t) | t <- case po of {PGF.ParseOk ts -> maybe id take mlimit ts; _ -> []}] - ] - where - groupResults = Map.toList . foldr more Map.empty . start . collect - where - collect tls = [(t,(l,s)) | (t,ls) <- tls, (l,s,_) <- ls, notDisamb l] - start ls = [(l,[([t],s)]) | (t,(l,s)) <- ls] - more (l,s) = Map.insertWith (\ [([t],x)] xs -> insertAlt t x xs) l s - - insertAlt t x xs = case xs of - (ts,y):xs2 -> if x==y then (t:ts,y):xs2 -- if string is there add only tree - else (ts,y) : insertAlt t x xs2 - _ -> [([t],x)] - - langOnly = reverse . take 3 . reverse - - disamb lg from ts = - if lg < 2 - then [] - else [("tree", "-- " ++ groupDisambs [disambLang from t | t <- ts])] - - groupDisambs = unwords . intersperse "/" - - disambLang f t = - let - disfl lang = PGF.mkCId ("Disamb" ++ lang) - disf = disfl (PGF.showLanguage f) - disfEng = disfl (reverse (drop 3 (reverse (PGF.showLanguage f))) ++ "Eng") - in - if elem disf (PGF.languages pgf) -- if Disamb f exists use it - then PGF.linearize pgf disf t - else if elem disfEng (PGF.languages pgf) -- else try DisambEng - then PGF.linearize pgf disfEng t - else "AST " ++ PGF.showExpr [] t -- else show abstract tree - - notDisamb = (/="Disamb") . take 6 . PGF.showLanguage - -doParse :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> TreeOpts -> JSValue -doParse pgf (mfrom,input) mcat mlimit (trie,jsontree) = showJSON $ map makeObj - ["from".=from : "brackets".=bs : jsonParseOutput po - | (from,po,bs) <- parse' pgf input mcat mfrom] - where - jsonParseOutput output = - case output of - PGF.ParseOk trees -> ["trees".=trees'] - ++["jsontrees".=map jsonExpr trees'|jsontree] - ++addTrie trie trees - where trees' = maybe id take mlimit trees - PGF.TypeError errs -> jsonTypeErrors errs - PGF.ParseIncomplete -> ["incomplete".=True] - PGF.ParseFailed n -> ["parseFailed".=n] - -addTrie trie trees = - ["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie] - -doComplete :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue -doComplete pgf (mfrom,input) mcat mlimit full = showJSON - [makeObj ( - ["from".=from, "brackets".=bs, "text".=s] ++ - if full - then [ "completions" .= Map.elems (Map.mapWithKey (completionInfo pgf) cs) ] - else [ "completions" .= Map.keys cs ] - ) - | from <- froms, let (bs,s,cs) = complete' pgf from cat mlimit input] - where - froms = maybe (PGF.languages pgf) (:[]) mfrom - cat = fromMaybe (PGF.startCat pgf) mcat - -completionInfo :: PGF -> PGF.Token -> [PGF.CId] -> JSValue -completionInfo pgf token funs = - makeObj - ["token".= token - ,"funs" .= map mkFun (nub funs) - ] - where - mkFun cid = case PGF.functionType pgf cid of - Just typ -> - makeObj [ {-"fid".=funid,-} "fun".=cid, "hyps".=hyps', "cat".=cat ] - where - (hyps,cat,_es) = PGF.unType typ - hyps' = [ PGF.showType [] typ | (_,_,typ) <- hyps ] - Nothing -> makeObj [ "error".=("Function "++show cid++" not found") ] -- shouldn't happen - -doLinearize :: PGF -> PGF.Tree -> To -> JSValue -doLinearize pgf tree tos = showJSON - [makeObj ["to".=to, "text".=text,"brackets".=bs] - | (to,text,bs) <- linearizeAndUnlex pgf tos tree] - -doLinearizes :: PGF -> PGF.Tree -> To -> JSValue -doLinearizes pgf tree (tos,unlex) = showJSON - [makeObj ["to".=to, "texts".=map unlex texts] - | (to,texts) <- linearizes' pgf tos tree] - where - linearizes' pgf tos tree = - [(to,lins to (transfer to tree)) | to <- langs] - where - langs = if null tos then PGF.languages pgf else tos - lins to = nub . concatMap (map snd) . PGF.tabularLinearizes pgf to - -doLinearizeTabular :: PGF -> PGF.Tree -> To -> JSValue -doLinearizeTabular pgf tree tos = showJSON - [makeObj ["to".=to, - "table".=[makeObj ["params".=ps,"texts".=ts] - | (ps,ts)<-texts]] - | (to,texts) <- linearizeTabular pgf tos tree] - -doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> To -> CGI JSValue -doRandom pgf mcat mdepth mlimit to = - liftIO $ - do g <- newStdGen - let trees = PGF.generateRandomDepth g pgf cat (Just depth) - return $ showJSON - [makeObj ["tree".=PGF.showExpr [] tree, - "linearizations".= doLinearizes pgf tree to] - | tree <- limit trees] - where cat = fromMaybe (PGF.startCat pgf) mcat - limit = take (fromMaybe 1 mlimit) - depth = fromMaybe 4 mdepth - -doGenerate :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> To -> JSValue -doGenerate pgf mcat mdepth mlimit tos = - showJSON [makeObj ["tree".=PGF.showExpr [] tree, - "linearizations".= - [makeObj ["to".=to, "text".=text] - | (to,text,bs) <- linearizeAndUnlex pgf tos tree]] - | tree <- limit trees] - where - trees = PGF.generateAllDepth pgf cat (Just depth) - cat = fromMaybe (PGF.startCat pgf) mcat - limit = take (fromMaybe 1 mlimit) - depth = fromMaybe 4 mdepth - -doGrammar :: (UTCTime,PGF) -> Either IOError (UTCTime,l) -> Maybe (Accept Language) -> CGI CGIResult -doGrammar (t1,pgf) elbls macc = out t $ showJSON $ makeObj - ["name".=PGF.abstractName pgf, - "lastmodified".=show t, - "hasDependencyLabels".=either (const False) (const True) elbls, - "userLanguage".=selectLanguage pgf macc, - "startcat".=PGF.showType [] (PGF.startCat pgf), - "categories".=categories, - "functions".=functions, - "languages".=languages] - where - t = either (const t1) (max t1 . fst) elbls - languages = - [makeObj ["name".= l, - "languageCode".= fromMaybe "" (PGF.languageCode pgf l)] - | 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 @@ -800,48 +410,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)) -parseTree pgf lang opts tree = PGF.graphvizParseTree pgf lang opts tree - -doDepTree (alc,clc) path pgf fmt lang tree = - do (_,lbls) <- liftIO $ getLabels alc path pgf - clbls <- liftIO $ getCncLabels clc path pgf lang - let vis = PGF.graphvizDependencyTree fmt False (Just lbls) clbls pgf lang tree - if fmt `elem` ["png","gif","gv"] - then outputGraphviz vis - else if fmt=="svg" - then outputText "image/svg+xml" vis - else outputPlain vis - -getLabels lc path pgf = - msum [readCache' lc path | path<-[{-path1,-}path2,path3]] - where - dir = takeDirectory path - --path1 = dir ...labels flag from abstract syntax... - path2 = dirPGF.showCId (PGF.abstractName pgf)<.>"labels" - path3 = dropExtension path <.> "labels" - -getCncLabels lc path pgf lang = - either fail ok =<< tryIO (readCache lc path2) - where - ok ls = do logError ("Found "++show (length ls)++" CncLabels for "++show lang++" in "++path2) - return (Just ls) - fail _ = do logError ("No CncLabels for "++show lang++" in "++path2) - return Nothing - dir = takeDirectory path - --path1 = dir ...labels flag from concrete syntax... - path2 = dirPGF.showCId lang<.>"labels" - --path3 = ... - -tryIO :: IO a -> IO (Either IOError a) -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) <- @@ -873,157 +442,10 @@ 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 - where - baseobj = ["def".=def, "producers".=ps, "consumers".=cs] - pnames = ["printnames".=makeObj [(show lang).=PGF.showPrintName pgf lang id | lang <- PGF.languages pgf]] - -doBrowse pgf (Just id) _ _ "json" pn = outputJSONP $ browse1json pgf id pn -doBrowse pgf Nothing _ _ "json" pn = - outputJSONP $ makeObj ["cats".=all (PGF.categories pgf), - "funs".=all (PGF.functions pgf)] - where - all = makeObj . map one - one id = PGF.showCId id.=browse1json pgf id pn - -doBrowse pgf Nothing cssClass href _ pn = errorMissingId -doBrowse pgf (Just id) cssClass href _ pn = -- default to "html" format - outputHTML $ - case PGF.browse pgf id of - Just (def,ps,cs) -> "
"++annotate def++"
\n"++ - syntax++ - (if not (null ps) - then "
"++ - "

Producers

"++ - "

"++annotateCIds ps++"

\n" - else "")++ - (if not (null cs) - then "
"++ - "

Consumers

"++ - "

"++annotateCIds cs++"

\n" - else "")++ - (if pn - then "
"++ - "

Print Names

"++ - "

"++annotatePrintNames++"

\n" - else "") - Nothing -> "" - where - syntax = - case PGF.functionType pgf id of - Just ty -> let (hypos,_,_) = PGF.unType ty - e = PGF.mkApp id (snd $ mapAccumL mkArg (1,1) hypos) - rows = [""++ - ""++PGF.showCId lang++""++ - ""++PGF.linearize pgf lang e++""++ - "" - | lang <- PGF.languages pgf] - in "
"++ - "

Syntax

"++ - "\n"++ - ""++ - ""++ - ""++ - "\n"++ - unlines rows++"\n
"++PGF.showCId (PGF.abstractName pgf)++""++PGF.showExpr [] e++"
" - Nothing -> "" - - mkArg (i,j) (_,_,ty) = ((i+1,j+length hypos),e) - where - e = foldr (\(j,(bt,_,_)) -> PGF.mkAbs bt (PGF.mkCId ('X':show j))) (PGF.mkMeta i) (zip [j..] hypos) - (hypos,_,_) = PGF.unType ty - - identifiers = PGF.functions pgf ++ PGF.categories pgf - - annotate [] = [] - annotate (c:cs) - | isIdentInitial c = let (id,cs') = break (not . isIdentChar) (c:cs) - in (if PGF.mkCId id `elem` identifiers - then mkLink id - else if id == "fun" || id == "data" || id == "cat" || id == "def" - then ""++id++"" - else id) ++ - annotate cs' - | otherwise = c : annotate cs - - annotateCIds ids = unwords (map (mkLink . PGF.showCId) ids) - - isIdentInitial c = isAlpha c || c == '_' - isIdentChar c = isAlphaNum c || c == '_' || c == '\'' - - hrefAttr id = - case href of - Nothing -> "" - Just s -> "href=\""++substId id s++"\"" - - substId id [] = [] - substId id ('$':'I':'D':cs) = id ++ cs - substId id (c:cs) = c : substId id cs - - classAttr = - case cssClass of - Nothing -> "" - Just s -> "class=\""++s++"\"" - - mkLink s = ""++s++"" - - annotatePrintNames = "
"++(unwords pns)++"
" - where pns = ["
"++(show lang)++"
"++(PGF.showPrintName pgf lang id)++"
" | lang <- PGF.languages pgf ] --} - -<<<<<<< HEAD instance JSON Expr where readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . readExpr showJSON = showJSON . showExpr [] -======= -class ToATree a where - showTree :: a -> String - toATree :: a -> PGF.ATree a - -instance ToATree PGF.Expr where - showTree = PGF.showExpr [] - toATree = PGF.toATree - --- | Render trees as JSON with numbered functions -jsonExpr e = evalState (expr (toATree e)) 0 - where - expr e = - case e of - PGF.Other e -> return (makeObj ["other".=e]) - PGF.App f es -> - do js <- mapM expr es - let children=["children".=js | not (null js)] - i<-inc - return $ makeObj (["fun".=f,"fid".=i]++children) - - inc :: State Int Int - inc = do i <- get; put (i+1); return i - -instance JSON PGF.Trie where - showJSON (PGF.Oth e) = makeObj ["other".=e] - showJSON (PGF.Ap f [[]]) = makeObj ["fun".=f] -- leaf --- showJSON (PGF.Ap f [es]) = makeObj ["fun".=f,"children".=es] -- one alternative - showJSON (PGF.Ap f alts) = makeObj ["fun".=f,"alts".=alts] - readJSON = error "PGF.Trie.readJSON intentionally not defined" - -instance JSON PGF.CId where - readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage - showJSON = showJSON . PGF.showLanguage - -instance JSON PGF.Expr where - readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . PGF.readExpr - showJSON = showJSON . PGF.showExpr [] - -instance JSON PGF.BracketedString where - readJSON x = return (PGF.Leaf "") - showJSON (PGF.Bracket cat fid _ index fun _ bs) = - makeObj ["cat".=cat, "fid".=fid, "index".=index, "fun".=fun, "children".=bs] - showJSON (PGF.Leaf s) = makeObj ["token".=s] ->>>>>>> master instance JSON BracketedString where readJSON x = return (Leaf "") @@ -1033,11 +455,6 @@ instance JSON BracketedString where -- * PGF utilities -transfer lang = if "LaTeX" `isSuffixOf` show lang - then fold -- OpenMath LaTeX transfer - else id - -<<<<<<< HEAD selectLanguage :: PGF -> Maybe (Accept Language) -> Concr selectLanguage pgf macc = case acceptable of [] -> case Map.elems (languages pgf) of @@ -1049,45 +466,6 @@ selectLanguage pgf macc = case acceptable of langCodeLanguage :: PGF -> String -> Maybe Concr langCodeLanguage pgf code = listToMaybe [concr | concr <- Map.elems (languages pgf), languageCode concr == Just code] -======= --- | tabulate all variants and their forms -linearizeTabular - :: PGF -> To -> PGF.Tree -> [(PGF.Language,[(String,[String])])] -linearizeTabular pgf (tos,unlex) tree = - [(to,lintab to (transfer to tree)) | to <- langs] - where - langs = if null tos then PGF.languages pgf else tos - lintab to t = [(p,map unlex (nub [t|(p',t)<-vs,p'==p]))|p<-ps] - where - ps = nub (map fst vs) - vs = concat (PGF.tabularLinearizes pgf to t) - -linearizeAndUnlex pgf (mto,unlex) tree = - [(to,s,bss) | to<-langs, - let bss = PGF.bracketedLinearize pgf to (transfer to tree) - s = unlex . unwords $ concatMap PGF.flattenBracketedString bss] - where - langs = if null mto then PGF.languages pgf else mto - -selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language -selectLanguage pgf macc = - case acceptable of - [] -> case PGF.languages pgf of - [] -> error "No concrete syntaxes in PGF grammar." - ls@(l1:_) -> case [l | l<-ls, langPart pgf l==Just "Eng"] of - eng:_ -> eng - _ -> l1 - Language c:_ -> fromJust (langCodeLanguage pgf c) - where langCodes = mapMaybe (PGF.languageCode pgf) (PGF.languages pgf) - acceptable = negotiate (map Language langCodes) macc - -langCodeLanguage :: PGF -> String -> Maybe PGF.Language -langCodeLanguage pgf code = - listToMaybe [l | l <- PGF.languages pgf, PGF.languageCode pgf l == Just code] - -langPart pgf lang = - stripPrefix (PGF.showCId (PGF.abstractName pgf)) (PGF.showCId lang) ->>>>>>> master -- * General utilities @@ -1096,7 +474,3 @@ infixl 2 #,% f .= v = (f,showJSON v) f # x = fmap f x f % x = ap f x - ---cleanFilePath :: FilePath -> FilePath ---cleanFilePath = takeFileName -