Merge branch 'master' into c-runtime

src/server/CGI.hs

@@ -4,7 +4,7 @@ import Network.CGI as C(
        CGI,ContentType(..),Accept(..),Language(..),
        getVarWithDefault,readInput,negotiate,requestAcceptLanguage,getInput,
        setHeader,output,outputFPS,outputError,
-       handleErrors,catchCGI,throwCGI,
+       handleErrors,
        liftIO)
 import Network.CGI.Protocol as C(CGIResult(..),CGIRequest(..),Input(..),
                                  Headers,HeaderName(..))

src/server/CGIUtils.hs

@@ -15,11 +15,14 @@ import System.Posix
 #endif
 
 import CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
-           getInput,catchCGI,throwCGI)
+           getInput)
 
 import Text.JSON
 import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
 import qualified Data.ByteString.Lazy as BS
+import Control.Monad.Catch (MonadThrow(throwM))
+import Network.CGI.Monad (catchCGI)
+import Control.Monad.Catch (MonadCatch(catch))
 
 -- * Logging
 
@@ -53,11 +56,11 @@ instance Exception CGIError where
   fromException (SomeException e) = cast e
 
 throwCGIError :: Int -> String -> [String] -> CGI a
-throwCGIError c m t = throwCGI $ toException $ CGIError c m t
+throwCGIError c m t = throwM $ toException $ CGIError c m t
 
 handleCGIErrors :: CGI CGIResult -> CGI CGIResult
 handleCGIErrors x =
-    x `catchCGI` \e -> case fromException e of
+    x `catch` \e -> case fromException e of
                          Nothing -> throw e
                          Just (CGIError c m t) -> do setXO; outputError c m t
 

src/server/PGFService.hs

@@ -33,7 +33,7 @@ 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 Data.List ({-sortBy,-}intersperse,mapAccumL,nub,isSuffixOf,nubBy,stripPrefix)
 import qualified Data.Map as Map
 import Data.Maybe
 import System.Random
@@ -103,6 +103,7 @@ 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
@@ -118,13 +119,46 @@ pgfMain qsem command (t,pgf) =
     "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 $
+                       out t=<< join (parseToChart # input % cat % limit)
+    "c-linearize"   -> out t=<< lin # tree % to
+    "c-bracketedLinearize"
+                    -> out t=<< bracketedLin # tree % to
+    "c-linearizeAll"-> out t=<< linAll # tree % to
+    "c-translate"   -> withQSem qsem $
+                       out t=<<join(trans # input % cat % to % start % limit%treeopts)
+    "c-lookupmorpho"-> 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
+    _               -> 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 =
+       do mcat  <- getInput1 "cat"
+          case mcat of
+            Nothing -> return (C.startCat pgf)
+            Just cat -> case C.readType cat of
+                          Nothing  -> badRequest "Bad category" cat
+                          Just typ -> return typ
+
+    langs = C.languages pgf
+>>>>>>> master
 
     grammar = showJSON $ makeObj
                  ["name".=abstractName pgf,
@@ -134,8 +168,8 @@ pgfMain qsem command (t,pgf) =
       where
         languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs]
 
-    parse input@((from,_),_) start mlimit (trie,json) =
-        do r <- parse' start mlimit input
+    parse input@((from,_),_) cat start mlimit (trie,json) =
+        do r <- parse' cat start mlimit input
            return $ showJSON [makeObj ("from".=from:jsonParseResult json r)]
 
     jsonParseResult json = either bad good
@@ -146,14 +180,71 @@ pgfMain qsem command (t,pgf) =
                                  ,"prob".=prob
                                  ]
 
+<<<<<<< HEAD
     parse' 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
+-}
+
+    parseToChart ((from,concr),input) cat mlimit =
+      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 "")
+         return $ showJSON [makeObj ("from".=from:r)]
+      where
+        callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.literalCallbacks
+        cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs]
+
+        bad  err           = ["parseFailed".=err]
+        good (roots,chart) = ["roots".=showJSON roots,
+                              "chart".=makeObj [show fid .= mkChartObj inf | (fid,inf)<-Map.toList chart]]
+
+        mkChartObj (brackets,prods,cat) =
+          makeObj ["brackets".=map mkChartBracket brackets
+                  ,"prods"   .=map mkChartProd prods
+                  ,"cat"     .=cat
+                  ]
+
+        mkChartBracket (s,e,ann) =
+          makeObj ["start".=s,"end".=e,"ann".=ann]
+
+        mkChartProd (expr,args,prob) =
+          makeObj ["tree".=expr,"args".=map mkChartPArg args,"prob".=prob]
+
+        mkChartPArg (C.PArg _ fid) = showJSON fid
+>>>>>>> master
 
     linAll tree to = showJSON (linAll' tree to)
     linAll' tree (tos,unlex) =
@@ -168,8 +259,8 @@ pgfMain qsem command (t,pgf) =
     bracketedLin' tree (tos,unlex) =
         [makeObj ["to".=to,"brackets".=showJSON (bracketedLinearize c tree)]|(to,c)<-tos]
 
-    trans input@((from,_),_) to start mlimit (trie,jsontree) =
-      do parses <- parse' start mlimit input
+    trans input@((from,_),_) cat to start mlimit (trie,jsontree) =
+      do parses <- parse' cat start mlimit input
          return $
            showJSON [ makeObj ["from".=from,
                                "translations".= jsonParses parses]]
@@ -183,11 +274,35 @@ 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]
+
+    cohorts (from,concr) filter input =
+      showJSON [makeObj ["start" .=showJSON s
+                        ,"word"  .=showJSON w
+                        ,"morpho".=showJSON [makeObj ["lemma".=l
+                                                     ,"analysis".=a
+                                                     ,"prob".=p] 
+                                                | (l,a,p)<-ms]
+                        ,"end"   .=showJSON e
+                        ]
+                   | (s,w,ms,e) <- (case filter of
+                                      Just "longest" -> C.filterLongest
+                                      Just "best"    -> C.filterBest
+                                      _              -> id)
+                                     (C.lookupCohorts concr input)]
+
+    wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat
+>>>>>>> master
 
     jsonWFW from rs =
       showJSON
@@ -197,7 +312,7 @@ pgfMain qsem command (t,pgf) =
                                         [makeObj["to".=to,"text".=text]
                                          | (to,text)<-rs]]]]]
 
-    wordforword' inp@((from,concr),input) (tos,unlex) =
+    wordforword' inp@((from,concr),input) cat (tos,unlex) =
         [(to,unlex . unwords $ map (lin_word' c) pws)
          |let pws=map parse_word' (words input),(to,c)<-tos]
       where
@@ -242,7 +357,7 @@ pgfMain qsem command (t,pgf) =
     from1 = maybe (missing "from") return =<< from'
     from' = getLang "from"
 
-    to = (,) # getLangs "to" % unlexer (const False)
+    to = (,) # getLangs "to" % unlexerC (const False)
 
     getLangs = getLangs' readLang
     getLang = getLang' readLang
@@ -274,8 +389,15 @@ lexer good = maybe (return id) lexerfun =<< getInput "lexer"
 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"
+unlexerC :: (String -> Bool) -> CGI Unlexer
+unlexerC = unlexer' id
+
+-- | Unlexing for the Haskell runtime system, the default is to just apply &+
+unlexerH :: CGI Unlexer
+unlexerH = unlexer' (unwords . bindTok . words) (const False)
+
+unlexer' defaultUnlexer good =
+    maybe (return defaultUnlexer) unlexerfun =<< getInput "unlexer"
   where
     unlexerfun name =
        case stringOp good ("unlex"++name) of
@@ -380,7 +502,7 @@ pgfMain lcs@(alc,clc) path command tpgf@(t,pgf) =
     from = getLang "from"
 
     to1 = maybe (missing "to") return =<< getLang "to"
-    to = (,) # getLangs "to" % unlexer (const False)
+    to = (,) # getLangs "to" % unlexerH
 
     getLangs = getLangs' readLang
     getLang = getLang' readLang
@@ -853,9 +975,55 @@ doBrowse pgf (Just id) cssClass href _ pn = -- default to "html" format
       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 "")
@@ -869,6 +1037,7 @@ 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
@@ -880,6 +1049,45 @@ 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
 

src/server/RunHTTP.hs

@@ -5,7 +5,7 @@ import CGI(CGIResult(..),CGIRequest(..),Input(..),
                             Headers,HeaderName(..))
 import CGI(runCGIT)
 import Network.Shed.Httpd(initServer,Request(..),Response(..))
-import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack)
+import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack,empty)
 import qualified Data.Map as M(fromList)
 import URLEncoding(decodeQuery)
 
@@ -25,7 +25,9 @@ httpResp (hdrs,r) = Response code (map name hdrs) (body r)
     name (HeaderName n,v) = (n,v)
 
 cgiReq :: String -> Request -> CGIRequest
-cgiReq root (Request method uri hdrs body) = CGIRequest vars inputs body'
+cgiReq root (Request method uri hdrs body)
+  | method == "POST" = CGIRequest vars (map input (decodeQuery body)) BS.empty
+  | otherwise        = CGIRequest vars (map input (decodeQuery qs  )) BS.empty -- assumes method=="GET"
   where
     vars = M.fromList [("REQUEST_METHOD",method),
                        ("REQUEST_URI",show uri),
@@ -37,15 +39,6 @@ cgiReq root (Request method uri hdrs body) = CGIRequest vars inputs body'
            '?':s -> s
            s -> s
     al = maybe "" id $ lookup "Accept-Language" hdrs
---  inputs = map input $ queryToArguments $ fixplus qs  -- assumes method=="GET"
-    inputs = map input $ decodeQuery qs  -- assumes method=="GET"
-    body' = BS.pack body
 
     input (name,val) = (name,Input (BS.pack val) Nothing plaintext)
     plaintext = ContentType "text" "plain" []
-{-
-    fixplus = concatMap decode
-      where
-        decode '+' = "%20" -- httpd-shed bug workaround
-        decode c   = [c]
--}

src/server/URLEncoding.hs

@@ -6,9 +6,9 @@ import Data.Char (chr,digitToInt,isHexDigit)
 -- | Decode hexadecimal escapes
 urlDecodeUnicode :: String -> String
 urlDecodeUnicode [] = ""
-urlDecodeUnicode ('%':'u':x1:x2:x3:x4:s) 
+urlDecodeUnicode ('%':'u':x1:x2:x3:x4:s)
     | all isHexDigit [x1,x2,x3,x4] =
-    chr (    digitToInt x1 `shiftL` 12 
+    chr (    digitToInt x1 `shiftL` 12
          .|. digitToInt x2 `shiftL` 8
          .|. digitToInt x3 `shiftL` 4
          .|. digitToInt x4) : urlDecodeUnicode s
@@ -45,8 +45,8 @@ fromhex2 d1 d2 = 16*digitToInt d1+digitToInt d2
 -- Repeatedly extract (and transform) values until a predicate hold.  Return the list of values.
 unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
 unfoldr f p x | p x       = []
-	      | otherwise = y:unfoldr f p x'
-			      where (y, x') = f x
+              | otherwise = y:unfoldr f p x'
+                              where (y, x') = f x
 
 chopList :: ([a] -> (b, [a])) -> [a] -> [b]
 chopList f l = unfoldr f null l
@@ -54,8 +54,8 @@ chopList f l = unfoldr f null l
 breakAt :: (Eq a) => a -> [a] -> ([a], [a])
 breakAt _ [] = ([], [])
 breakAt x (x':xs) =
-	if x == x' then
-	    ([], xs)
-	else
-	    let (ys, zs) = breakAt x xs
-	    in  (x':ys, zs)
+    if x == x' then
+        ([], xs)
+    else
+        let (ys, zs) = breakAt x xs
+        in  (x':ys, zs)

src/server/transfer/Fold.hs

@@ -14,13 +14,18 @@ fold t =
   case unApp t of
     Just (i,[x])  ->
         case M.lookup i foldable of
-	        Just j -> appFold j x
-	        _      -> mkApp i [fold x]
+          Just j -> appFold j x
+          _      -> mkApp i [fold x]
     Just (i,xs)   -> mkApp i $ map fold xs
     _             -> t
 
+<<<<<<< HEAD
 appFold :: Fun -> Expr -> Expr
 appFold j t = 
+=======
+appFold :: CId -> Tree -> Tree
+appFold j t =
+>>>>>>> master
   case unApp t of
     Just (i,[t,ts]) | isPre i "Cons"  -> mkApp j [fold t, appFold j ts]
     Just (i,[t,s])  | isPre i "Base"  -> mkApp j [fold t, fold s]