PGF web API: add commands lookupmorpho and c-lookupmorpho

src/server/PGFService.hs

@@ -12,7 +12,7 @@ import URLEncoding
 
 #if C_RUNTIME
 import qualified PGF2 as C
-import Data.Time.Clock(UTCTime,getCurrentTime,diffUTCTime)
+--import Data.Time.Clock(UTCTime,getCurrentTime,diffUTCTime)
 #endif
 
 import Data.Time.Format(formatTime)
@@ -98,6 +98,7 @@ cpgfMain command (t,(pgf,pc)) =
     "c-parse"     -> out t=<< join (parse # input % start % limit % trie)
     "c-linearize" -> out t=<< lin # tree % to
     "c-translate" -> out t=<< join (trans # input % to % start % limit % trie)
+    "c-lookupmorpho" -> out t=<< morpho # from1 % textInput
     "c-flush"     -> out t=<< flush
     "c-grammar"   -> out t grammar
     _             -> badRequest "Unknown command" command
@@ -162,14 +163,22 @@ cpgfMain command (t,(pgf,pc)) =
                                      "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
+
+
     input = lexit # from % textInput
       where
         lexit (from,lex) input = (from,lex input)
 
-        from = maybe (missing "from") getlexer =<< getLang "from"
+        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
 
     getLangs = getLangs' readLang
@@ -255,6 +264,7 @@ pgfMain command (t,pgf) =
       "generate"       -> o =<< doGenerate pgf # cat % depth % limit % to
       "translate"      -> o =<< doTranslate pgf # input % cat % to % limit %trie
       "translategroup" -> o =<< doTranslateGroup pgf # input % cat % to % limit
+      "lookupmorpho"   -> o =<< doLookupMorpho pgf # from1 % textInput
       "grammar"        -> o =<< doGrammar pgf # requestAcceptLanguage
       "abstrtree"      -> outputGraphviz =<< abstrTree pgf # graphvizOptions % tree
       "alignment"      -> outputGraphviz =<< alignment pgf # tree % to
@@ -328,6 +338,7 @@ pgfMain command (t,pgf) =
         string name = maybe "" id # getInput name
         bool name = maybe False toBool # getInput name
 
+    from1 = maybe (missing "from") return =<< from
     from = getLang "from"
     to = (,) # getLangs "to" % unlexer
 
@@ -409,6 +420,14 @@ doExternal (Just cmd) input =
          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)
 
 doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> Bool -> JSValue
@@ -485,8 +504,6 @@ doTranslateGroup pgf (mfrom,input) mcat (tos,unlex) mlimit =
 
    notDisamb = (/="Disamb") . take 6 . PGF.showLanguage
 
-type From = (Maybe PGF.Language,String)
-
 doParse :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue
 doParse pgf (mfrom,input) mcat mlimit trie = showJSON $ map makeObj
      ["from".=from : "brackets".=bs : jsonParseOutput po