Merge branch 'master' into stack-yaml-symlink

6 files changed, 102 insertions, 25 deletions

diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index 0e5c61404..2f2e802e0 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, CPP #-}
 module GF.Command.Commands (
   PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
   options,flags,
@@ -741,7 +741,7 @@ pgfCommands = Map.fromList [
                                      Nothing   -> do putStrLn ("unknown category of function identifier "++show id)
                                                      return void
          [e]         -> case inferExpr pgf e of
-                          Left tcErr   -> error $ render (ppTcError tcErr)
+                          Left tcErr   -> errorWithoutStackTrace $ render (ppTcError tcErr)
                           Right (e,ty) -> do putStrLn ("Expression:  "++showExpr [] e)
                                              putStrLn ("Type:        "++showType [] ty)
                                              putStrLn ("Probability: "++show (probTree pgf e))
@@ -1019,3 +1019,7 @@ stanzas = map unlines . chop . lines where
   chop ls = case break (=="") ls of
     (ls1,[])  -> [ls1]
     (ls1,_:ls2) -> ls1 : chop ls2
+
+#if !(MIN_VERSION_base(4,9,0))
+errorWithoutStackTrace = error
+#endif
\ No newline at end of file
diff --git a/src/runtime/haskell-bind/CHANGELOG.md b/src/runtime/haskell-bind/CHANGELOG.md
index aed2d9c4f..570c7fd73 100644
--- a/src/runtime/haskell-bind/CHANGELOG.md
+++ b/src/runtime/haskell-bind/CHANGELOG.md
@@ -1,7 +1,11 @@
+## 1.3.0
+
+- Add completion support.
+
 ## 1.2.1
 
-- Remove deprecated pgf_print_expr_tuple
-- Added an API for cloning expressions/types/literals
+- Remove deprecated `pgf_print_expr_tuple`.
+- Added an API for cloning expressions/types/literals.
 
 ## 1.2.0
 
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 4204867f1..38fae67ef 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -43,32 +43,28 @@ module PGF2 (-- * PGF
              mkCId,
              exprHash, exprSize, exprFunctions, exprSubstitute,
              treeProbability,
-
              -- ** Types
              Type, Hypo, BindType(..), startCat,
              readType, showType, showContext,
              mkType, unType,
-
              -- ** Type checking
              -- | Dynamically-built expressions should always be type-checked before using in other functions,
              -- as the exceptions thrown by using invalid expressions may not catchable.
              checkExpr, inferExpr, checkType,
-
              -- ** Computing
              compute,
 
              -- * Concrete syntax
              ConcName,Concr,languages,concreteName,languageCode,
-
              -- ** Linearization
              linearize,linearizeAll,tabularLinearize,tabularLinearizeAll,bracketedLinearize,bracketedLinearizeAll,
              FId, BracketedString(..), showBracketedString, flattenBracketedString,
              printName, categoryFields,
-
              alignWords,
              -- ** Parsing
              ParseOutput(..), parse, parseWithHeuristics,
              parseToChart, PArg(..),
+             complete,
              -- ** Sentence Lookup
              lookupSentence,
              -- ** Generation
@@ -976,6 +972,67 @@ parseWithOracle lang cat sent (predict,complete,literal) =
                          return ep
         Nothing    -> do return nullPtr
 
+-- | Returns possible completions of the current partial input.
+complete :: Concr      -- ^ the language with which we parse
+         -> Type       -- ^ the start category
+         -> String     -- ^ the input sentence (excluding token being completed)
+         -> String     -- ^ prefix (partial token being completed)
+         -> ParseOutput [(String, CId, CId, Float)]  -- ^ (token, category, function, probability)
+complete lang (Type ctype _) sent pfx =
+  unsafePerformIO $ do
+    parsePl <- gu_new_pool
+    exn     <- gu_new_exn parsePl
+    sent <- newUtf8CString sent parsePl
+    pfx  <- newUtf8CString pfx parsePl
+    enum <- pgf_complete (concr lang) ctype sent pfx exn parsePl
+    failed <- gu_exn_is_raised exn
+    if failed
+    then do
+      is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError
+      if is_parse_error
+      then do
+        c_err <- (#peek GuExn, data.data) exn
+        c_offset <- (#peek PgfParseError, offset) c_err
+        token_ptr <- (#peek PgfParseError, token_ptr) c_err
+        token_len <- (#peek PgfParseError, token_len) c_err
+        tok <- peekUtf8CStringLen token_ptr token_len
+        gu_pool_free parsePl
+        return (ParseFailed (fromIntegral (c_offset :: CInt)) tok)
+      else do
+        is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
+        if is_exn
+        then do
+          c_msg <- (#peek GuExn, data.data) exn
+          msg <- peekUtf8CString c_msg
+          gu_pool_free parsePl
+          throwIO (PGFError msg)
+        else do
+          gu_pool_free parsePl
+          throwIO (PGFError "Parsing failed")
+    else do
+      fpl <- newForeignPtr gu_pool_finalizer parsePl
+      ParseOk <$> fromCompletions enum fpl
+  where
+    fromCompletions :: Ptr GuEnum -> ForeignPtr GuPool -> IO [(String, CId, CId, Float)]
+    fromCompletions enum fpl =
+      withGuPool $ \tmpPl -> do
+        cmpEntry <- alloca $ \ptr ->
+                      withForeignPtr fpl $ \pl ->
+                        do gu_enum_next enum ptr pl
+                           peek ptr
+        if cmpEntry == nullPtr
+        then do
+          finalizeForeignPtr fpl
+          touchConcr lang
+          return []
+        else do
+          tok <- peekUtf8CString =<< (#peek PgfTokenProb, tok) cmpEntry
+          cat <- peekUtf8CString =<< (#peek PgfTokenProb, cat) cmpEntry
+          fun <- peekUtf8CString =<< (#peek PgfTokenProb, fun) cmpEntry
+          prob <- (#peek PgfTokenProb, prob) cmpEntry
+          toks <- unsafeInterleaveIO (fromCompletions enum fpl)
+          return ((tok, cat, fun, prob) : toks)
+
 -- | Returns True if there is a linearization defined for that function in that language
 hasLinearization :: Concr -> Fun -> Bool
 hasLinearization lang id = unsafePerformIO $
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc
index c72c48e3b..16f9ad46d 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hsc
+++ b/src/runtime/haskell-bind/PGF2/FFI.hsc
@@ -103,7 +103,7 @@ foreign import ccall unsafe "gu/file.h gu_file_in"
 
 foreign import ccall safe  "gu/enum.h gu_enum_next"
   gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO ()
- 
+
 foreign import ccall unsafe "gu/string.h gu_string_buf_freeze"
   gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString
 
@@ -241,7 +241,7 @@ newSequence elem_size pokeElem values pool = do
 type FId = Int
 data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
 
-peekFId :: Ptr a -> IO FId 
+peekFId :: Ptr a -> IO FId
 peekFId c_ccat = do
   c_fid <- (#peek PgfCCat, fid) c_ccat
   return (fromIntegral (c_fid :: CInt))
@@ -256,6 +256,7 @@ data PgfApplication
 data PgfConcr
 type PgfExpr = Ptr ()
 data PgfExprProb
+data PgfTokenProb
 data PgfExprParser
 data PgfFullFormEntry
 data PgfMorphoCallback
@@ -422,6 +423,9 @@ foreign import ccall
 foreign import ccall "pgf/pgf.h pgf_parse_with_oracle"
   pgf_parse_with_oracle :: Ptr PgfConcr -> CString -> CString -> Ptr PgfOracleCallback -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
 
+foreign import ccall "pgf/pgf.h pgf_complete"
+  pgf_complete :: Ptr PgfConcr -> PgfType -> CString -> CString -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuEnum)
+
 foreign import ccall "pgf/pgf.h pgf_lookup_morpho"
   pgf_lookup_morpho :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()
 
diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal
index 4ef9ed4f0..91e77c77b 100644
--- a/src/runtime/haskell-bind/pgf2.cabal
+++ b/src/runtime/haskell-bind/pgf2.cabal
@@ -1,5 +1,5 @@
 name: pgf2
-version: 1.2.1
+version: 1.3.0
 synopsis: Bindings to the C version of the PGF runtime
 description:
   GF, Grammatical Framework, is a programming language for multilingual grammar applications.
diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index e30ff8652..3f5307571 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -151,29 +151,37 @@ getFile get path =
 cpgfMain qsem command (t,(pgf,pc)) =
   case command of
     "c-parse"       -> withQSem qsem $
-                       out t=<< join (parse # input % start % limit % treeopts)
+                       out t=<< join (parse # input % cat % start % limit % treeopts)
     "c-parseToChart"-> withQSem qsem $
-                       out t=<< join (parseToChart # input % limit)
+                       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 % to % start % limit%treeopts)
+                       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 % to
+    "c-wordforword" -> out t =<< wordforword # input % cat % to
     _               -> badRequest "Unknown command" command
   where
     flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
                         performGC
                         return $ showJSON ()
 
-    cat = C.startCat 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
 
     grammar = showJSON $ makeObj
@@ -184,8 +192,8 @@ cpgfMain qsem command (t,(pgf,pc)) =
       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
@@ -195,7 +203,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
         tp (tree,prob) = makeObj (addTree json tree++["prob".=prob])
 
     -- Without caching parse results:
-    parse' start mlimit ((from,concr),input) =
+    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)
@@ -221,7 +229,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
                              -- remove unused parse results after 2 minutes
 -}
 
-    parseToChart ((from,concr),input) mlimit =
+    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)
@@ -262,8 +270,8 @@ cpgfMain qsem command (t,(pgf,pc)) =
     bracketedLin' tree (tos,unlex) =
         [makeObj ["to".=to,"brackets".=showJSON (C.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]]
@@ -297,7 +305,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
                                       _              -> id)
                                      (C.lookupCohorts concr input)]
 
-    wordforword input@((from,_),_) = jsonWFW from . wordforword' input
+    wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat
 
     jsonWFW from rs =
       showJSON
@@ -307,7 +315,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
                                         [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