content: {-# LANGUAGE CPP #-}
  module PGFService(cgiMain,cgiMain',getPath,
                    logFile,stderrToFile,
                    Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
  
  import PGF (PGF,Labels,CncLabels)
  import GF.Text.Lexing
  import qualified PGF
  import Cache
  import CGIUtils(outputJSONP,outputPlain,outputHTML,outputText,
                  outputBinary,outputBinary',
                  logError,handleCGIErrors,throwCGIError,stderrToFile)
  import CGI(CGI,readInput,getInput,getVarWithDefault,
             CGIResult,requestAcceptLanguage,handleErrors,setHeader,
             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)
  import Data.Time.Format(defaultTimeLocale,rfc822DateFormat)
  #else
  import System.Locale(defaultTimeLocale,rfc822DateFormat)
  #endif
  import Text.JSON
  import Text.PrettyPrint as PP(render, text, (<+>))
  import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
  import qualified Data.ByteString.Lazy as BS
  
  import Control.Concurrent
  import qualified Control.Exception as E
  import Control.Monad
  import Control.Monad.State(State,evalState,get,put)
  import Control.Monad.Catch(bracket_)
  import Data.Char
  --import Data.Function (on)
  import Data.List ({-sortBy,-}intersperse,mapAccumL,nub,isSuffixOf,nubBy)
  import qualified Data.Map as Map
  import Data.Maybe
  import System.Random
  import System.Process
  import System.Exit
  import System.IO
  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
  
  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)]
  
  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
                        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)
  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)
  
  newCache' rd = do c <- newCache rd
                    forkIO $ forever $ clean c
                    return c
    where
      clean c = do threadDelay 2000000000 -- 2000 seconds, i.e. ~33 minutes
                   expireCache (24*60*60) c -- 24 hours
  
  getPath =
      do path <- getVarWithDefault "PATH_TRANSLATED" "" -- apache mod_fastcgi
         if null path
            then getVarWithDefault "SCRIPT_FILENAME" "" -- lighttpd
            else return path
  
  cgiMain :: Caches -> CGI CGIResult
  cgiMain cache = handleErrors . handleCGIErrors $
                    cgiMain' cache =<< getPath
  
  cgiMain' :: Caches -> FilePath -> CGI CGIResult
  cgiMain' cache path =
      do command <- liftM (maybe "grammar" (urlDecodeUnicode . UTF8.decodeString))
                          (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
  
  getFile get path =
     either failed return =<< liftIO (E.try (get path))
    where
      failed e = if isDoesNotExistError e
                 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)) =
    case command of
      "c-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 $
                         out t=<<join(trans # input % to % start % limit%treeopts)
      "c-lookupmorpho"-> 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
    where
      flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
                          performGC
                          return $ showJSON ()
  
      cat = C.startCat pgf
      langs = C.languages pgf
  
      grammar = showJSON $ makeObj
                   ["name".=C.abstractName pgf,
                    "lastmodified".=show t,
                    "startcat".=C.showType [] (C.startCat pgf),
                    "languages".=languages]
        where
          languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs]
  
      parse input@((from,_),_) start mlimit (trie,json) =
          do r <- parse' start mlimit input
             return $ showJSON [makeObj ("from".=from:jsonParseResult json r)]
  
      jsonParseResult json = either bad good
        where
          bad err = ["parseFailed".=err]
          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 "")
        where
          callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.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]
  
      lin tree to = showJSON (lin' tree to)
      lin' tree (tos,unlex) =
          [makeObj ["to".=to,"text".=unlex (C.linearize c tree)]|(to,c)<-tos]
  
      trans input@((from,_),_) to start mlimit (trie,jsontree) =
        do parses <- parse' start mlimit input
           return $
             showJSON [ makeObj ["from".=from,
                                 "translations".= jsonParses parses]]
        where
          jsonParses = either bad good
            where
              bad err = [makeObj ["error".=err]]
              good parses = [makeObj (addTree jsontree tree++
                                      ["prob".=prob,
                                       "linearizations".=lin' tree to])
                                      | (tree,prob) <- parses]
  
      morpho (from,concr) input =
          showJSON [makeObj ["lemma".=l,"analysis".=a,"prob".=p]|(l,a,p)<-ms]
        where ms = C.lookupMorpho concr input
  
  
      wordforword input@((from,_),_) = jsonWFW from . wordforword' input
  
      jsonWFW from rs =
        showJSON
          [makeObj
            ["from".=from,
             "translations".=[makeObj ["linearizations".=
                                          [makeObj["to".=to,"text".=text]
                                           | (to,text)<-rs]]]]]
  
      wordforword' inp@((from,concr),input) (tos,unlex) =
          [(to,unlex . unwords $ map (lin_word' c) pws)
           |let pws=map parse_word' (words input),(to,c)<-tos]
        where
          lin_word' c = either id (lin1 c)
  
          lin1 c = dropq . C.linearize c
            where
              dropq (q:' ':s) | q `elem` "+*" = s
              dropq s = s
  
          parse_word' w = if all (\c->isSpace c||isPunctuation c) w
                          then Left w
                          else parse_word w
  
  
          parse_word w =
              maybe (Left ("["++w++"]")) Right $
              msum [parse1 w,parse1 ow,morph w,morph ow]
            where
              ow = case w of
                     c:cs | isLower c -> toUpper c : cs
                          | isUpper c -> toLower c : cs
                     s                -> s
  
              parse1 s = case C.parse concr cat s of
                           C.ParseOk ((t,_):ts) -> Just t
                           _                    -> Nothing
              morph w = listToMaybe
                          [t | (f,a,p)<-C.lookupMorpho concr w,
                               t<-maybeToList (C.readExpr f)]
  
      ---
  
      input = lexit # from % textInput
        where
          lexit (from,lex) input = (from,lex input)
  
          from = maybe (missing "from") getlexer =<< from'
            where
              getlexer f@(_,concr) = (,) f # c_lexer concr
  
      from1 = maybe (missing "from") return =<< from'
      from' = getLang "from"
  
      to = (,) # getLangs "to" % unlexer (const False)
  
      getLangs = getLangs' readLang
      getLang = getLang' readLang
  
      readLang :: String -> CGI (String,C.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
  
      c_lexer concr = lexer (not . null . C.lookupMorpho concr)
  
  --------------------------------------------------------------------------------
  
  {-
  instance JSON C.CId where
      readJSON x = readJSON x >>= maybe (fail "Bad language.") return . C.readCId
      showJSON = showJSON . C.showCId
  -}
  instance JSON C.Expr where
      readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . C.readExpr
      showJSON = showJSON . C.showExpr []
  
  
  -- | 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)
  
  instance ToATree C.Expr where
    showTree = show
    toATree = cToATree
  
  #endif
  
  --------------------------------------------------------------------------------
  -- * Lexing
  
  -- | Standard lexers
  lexer good = maybe (return id) lexerfun =<< getInput "lexer" 
    where
      lexerfun name =
        case stringOp good ("lex"++name) of
          Just fn -> return fn
          Nothing -> badRequest "Unknown lexer" name
  
  
  type Unlexer = String->String
  
  -- | Unlexing for the C runtime system, &+ is already applied
  unlexer :: (String -> Bool) -> CGI Unlexer
  unlexer good = maybe (return id) unlexerfun =<< getInput "unlexer"
    where
      unlexerfun name =
         case stringOp good ("unlex"++name) of
           Just fn -> return (fn . cleanMarker)
           Nothing -> badRequest "Unknown unlexer" name
      
      cleanMarker ('+':cs) = cs
      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" % unlexer (const False)
  
      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 = outputJSONP
  out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t
               setHeader "Last-Modified" fmt
               outputJSONP r
  
  getInput1 x = nonEmpty # getInput x
  nonEmpty (Just "") = Nothing
  nonEmpty r = r
  
  textInput :: CGI String
  textInput = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input"
  
  getLangs' readLang i = mapM readLang . maybe [] words =<< getInput i
  
  getLang' readLang i =
     do mlang <- getInput i
        case mlang of
          Just l@(_:_) -> Just # readLang l
          _            -> return Nothing
  
  
  limit, depth :: CGI (Maybe Int)
  limit = readInput "limit"
  depth = readInput "depth"
  
  start :: CGI Int
  start = maybe 0 id # readInput "start"
  
  treeopts :: CGI TreeOpts
  treeopts = (,) # getBool "trie" % getBool "jsontree"
  
  getBool x = maybe False toBool # getInput x
  toBool s = s `elem` ["","yes","true","True"]
  
  missing = badRequest "Missing parameter"
  errorMissingId = badRequest "Missing identifier" ""
  
  notFound = throw 404 "Not found"
  badRequest = throw 400
  
  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 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
       [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]
  
  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 (
          ["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
         "gv" -> outputPlain code
         _ -> outputFPS' fmt =<< liftIO (pipeIt2graphviz fmt code)
    where
      outputFPS' = outputBinary' . mimeType
  
      mimeType fmt =
        case fmt of
          "png" -> "image/png"
          "gif" -> "image/gif"
          "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) <-
          createProcess (proc "dot" ["-T",fmt])
                        { std_in  = CreatePipe,
                          std_out = CreatePipe,
                          std_err = Inherit }
  
      hSetBinaryMode outh True
      hSetEncoding inh  utf8
  
      -- fork off a thread to start consuming the output
      output  <- BS.hGetContents outh
      outMVar <- newEmptyMVar
      _ <- forkIO $ E.evaluate (BS.length output) >> putMVar outMVar ()
  
      -- now write and flush any input
      hPutStr inh code
      hFlush inh
      hClose inh -- done with stdin
  
      -- wait on the output
      takeMVar outMVar
      hClose outh
  
      -- wait on the process
      ex <- waitForProcess pid
  
      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 ]
  
  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]
  
  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]
  
  -- * PGF utilities
  {-
  cat :: PGF -> Maybe PGF.Type -> PGF.Type
  cat pgf mcat = fromMaybe (PGF.startCat pgf) mcat
  -}
  parse' :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [(PGF.Language,PGF.ParseOutput,PGF.BracketedString)]
  parse' pgf input mcat mfrom = 
     [(from,po,bs) | from <- froms, (po,bs) <- [PGF.parse_ pgf from cat Nothing input]]
    where froms = maybe (PGF.languages pgf) (:[]) mfrom
          cat = fromMaybe (PGF.startCat pgf) mcat
  
  complete' :: PGF -> PGF.Language -> PGF.Type -> Maybe Int -> String
           -> (PGF.BracketedString, String, Map.Map PGF.Token [PGF.CId])
  complete' pgf from typ mlimit input =
    let (ws,prefix) = tokensAndPrefix input
    in PGF.complete pgf from typ (unwords ws) prefix
    where
      tokensAndPrefix :: String -> ([String],String)
      tokensAndPrefix s | not (null s) && isSpace (last s) = (ws, "")
                        | null ws = ([],"")
                        | otherwise = (init ws, last ws)
          where ws = words s
  
  
  transfer lang = if "LaTeX" `isSuffixOf` show lang
                  then fold -- OpenMath LaTeX transfer
                  else id
  
  -- | 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."
                                       l:_ -> l
                              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]
  
  -- * General utilities
  
  infixl 2 #,%
  
  f .= v = (f,showJSON v)
  f # x = fmap f x
  f % x = ap f x
  
  --cleanFilePath :: FilePath -> FilePath
  --cleanFilePath = takeFileName
  