restore the web server

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

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

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 $
-    "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=<<join(trans # input % to % start % limit%treeopts)
-    "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
-=======
-    "c-parse"       -> withQSem qsem $
                        out t=<< join (parse # input % cat % start % limit % treeopts)
-    "c-parseToChart"-> withQSem qsem $
+--    "parseToChart"  -> withQSem qsem $
-                       out t=<< join (parseToChart # input % cat % limit)
+--                       out t=<< join (parseToChart # input % cat % limit)
-    "c-linearize"   -> out t=<< lin # tree % to
+    "linearize"     -> out t=<< lin # tree % to
-    "c-bracketedLinearize"
+    "bracketedLinearize"
                     -> out t=<< bracketedLin # 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 % cat % to % start % limit%treeopts)
-    "c-lookupmorpho"-> out t=<< morpho # from1 % textInput
+    "lookupmorpho"  -> out t=<< morpho # from1 % textInput
-    "c-lookupcohorts"->out t=<< cohorts # from1 % getInput "filter" % textInput
+    "lookupcohorts" -> out t=<< cohorts # from1 % getInput "filter" % 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 % cat % to
+    "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 :: CGI Type
-    cat = startCat pgf
-    langs = languages pgf
-=======
-    cat :: CGI C.Type
     cat =
        do mcat  <- getInput1 "cat"
           case mcat of
-            Nothing -> return (C.startCat pgf)
+            Nothing -> return (startCat pgf)
-            Just cat -> case C.readType cat of
+            Just cat -> case readType cat of
                           Nothing  -> badRequest "Bad category" cat
                           Just typ -> return typ
 
-    langs = C.languages pgf
+    langs = languages pgf
->>>>>>> master
 
     grammar = showJSON $ makeObj
                  ["name".=abstractName pgf,
@@ -180,48 +156,20 @@ pgfMain qsem command (t,pgf) =
                                  ,"prob".=prob
                                  ]
 
-<<<<<<< HEAD
+    -- Without caching parse results:
-    parse' start mlimit ((from,concr),input) =
+    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 "")
-=======
+        where
-    -- Without caching parse results:
+          callbacks = undefined
-    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
--}
 
-    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)
+                ParseOk chart     -> return (good chart)
-                C.ParseFailed _ tok -> return (bad tok)
+                ParseFailed _ tok -> return (bad tok)
-                C.ParseIncomplete   -> return (bad "")
+                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
+        mkChartPArg (PArg _ fid) = showJSON fid
->>>>>>> master
+-}
-
     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 "longest" -> filterLongest
-                                      Just "best"    -> C.filterBest
+                                      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 = dir</>PGF.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 = dir</>PGF.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) -> "<PRE>"++annotate def++"</PRE>\n"++
-                        syntax++
-                        (if not (null ps)
-                           then "<BR/>"++
-                                "<H3>Producers</H3>"++
-                                "<P>"++annotateCIds ps++"</P>\n"
-                           else "")++
-                        (if not (null cs)
-                           then "<BR/>"++
-                                "<H3>Consumers</H3>"++
-                                "<P>"++annotateCIds cs++"</P>\n"
-                           else "")++
-                        (if pn
-                           then "<BR/>"++
-                                "<H3>Print Names</H3>"++
-                                "<P>"++annotatePrintNames++"</P>\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 = ["<TR class=\"my-SyntaxRow\">"++
-                               "<TD class=\"my-SyntaxLang\">"++PGF.showCId lang++"</TD>"++
-                               "<TD class=\"my-SyntaxLin\">"++PGF.linearize pgf lang e++"</TD>"++
-                               "</TR>"
-                                            | lang <- PGF.languages pgf]
-                   in "<BR/>"++
-                      "<H3>Syntax</H3>"++
-                      "<TABLE class=\"my-SyntaxTable\">\n"++
-                      "<TR class=\"my-SyntaxRow\">"++
-                      "<TD class=\"my-SyntaxLang\">"++PGF.showCId (PGF.abstractName pgf)++"</TD>"++
-                      "<TD class=\"my-SyntaxLin\">"++PGF.showExpr [] e++"</TD>"++
-                      "</TR>\n"++
-                      unlines rows++"\n</TABLE>"
-        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 "<B>"++id++"</B>"
-                                        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 = "<A "++hrefAttr s++" "++classAttr++">"++s++"</A>"
-    
-    annotatePrintNames = "<DL>"++(unwords pns)++"</DL>"
-      where pns = ["<DT>"++(show lang)++"</DT><DD>"++(PGF.showPrintName pgf lang id)++"</DD>" | 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
-