temporary add gf-scribe to the compiler

src/compiler/GF/Scribe.hs

@@ -0,0 +1,2 @@
+module GF.Scribe where
+

src/compiler/gf-scribe.hs

@@ -0,0 +1,139 @@
+import PGF2
+import Data.Char (toUpper)
+import GF.Scribe
+import GF.Infra.Ident
+import GF.Infra.CheckM
+import GF.Infra.Option
+import GF.Grammar.Grammar
+import GF.Grammar.Parser
+import GF.Grammar.Printer
+import GF.Grammar.Macros
+import qualified GF.Data.Operations as O
+import GF.Compile.Rename
+import GF.Compile.Compute.Concrete
+import GF.Compile
+import qualified Data.Map as Map
+import qualified Data.ByteString.Char8 as BS
+import System.Environment(getArgs)
+import System.Console.Haskeline
+import Network.HTTP
+import Control.Monad
+import Control.Monad.IO.Class
+import Text.JSON
+import Text.PrettyPrint
+
+main = do
+  (qid:lang:args) <- getArgs
+  gr <- readNGF "/usr/local/share/x86_64-linux-ghc-8.8.4/gf-4.0.0/www/robust/Parse.ngf"
+  let Just cnc = Map.lookup (toCnc lang) (languages gr)
+  rsp <- simpleHTTP (getRequest ("https://www.wikidata.org/wiki/Special:EntityData/"++qid++".json"))
+  case decode (rspBody rsp) >>= valFromObj "entities" >>= valFromObj qid >>= valFromObj "claims" of
+    Ok obj    -> do do (_,(mo,sgr)) <- batchCompile noOptions ["RGL.gf"]
+                       interactive (item2term obj) () mo sgr gr cnc qid
+    Error msg -> fail msg
+  where
+    toCnc (c:cs) = "Parse"++(toUpper c:cs)
+    toCnc s      = s
+
+item2term obj = 
+  R [assign (LIdent (rawIdentS prop))
+            (mkFV [term | value <- values,
+                          Ok term <- [claim2term value]])
+                | (prop,values) <- fromJSObject obj]
+  where
+    mkFV [t] = t
+    mkFV ts  = FV ts
+
+    claim2term value = do
+      t1 <- valFromObj "mainsnak"    value >>= snak2term
+      t2 <- (valFromObj "qualifiers" value >>= mods2term)
+            `mplus`
+            return []
+      t3 <- (valFromObj "references" value >>= mods2term)
+            `mplus`
+            return []
+      return (R (t1++t2++t3))
+
+    mods2term obj =
+      return [assign (LIdent (rawIdentS prop))
+                     (mkFV [R term | value <- values,
+                                   Ok term <- [snak2term value]])
+                         | (prop,values) <- fromJSObject obj]
+
+    snak2term value = valFromObj "datavalue" value >>= datavalue2term
+
+    datavalue2term dv =
+      do s <- valFromObj "value" dv                -- string
+         return [assign (LIdent (rawIdentS "s")) (K s)]
+      `mplus`
+      do value <- valFromObj "value" dv            -- wikibase-entityid
+         id <- valFromObj "id" value
+         return [assign (LIdent (rawIdentS "id")) (K id)]
+      `mplus`
+      do value     <- valFromObj "value" dv        -- globecoordinate
+         latitude  <- valFromObj "latitude" value
+         longitude <- valFromObj "longitude" value
+         precision <- valFromObj "precision" value
+         return [assign (LIdent (rawIdentS "latitude")) (EFloat latitude)
+                ,assign (LIdent (rawIdentS "longitude")) (EFloat longitude)
+                ,assign (LIdent (rawIdentS "longitude")) (EFloat precision)]
+      `mplus`
+      do value <- valFromObj "value" dv            -- quantity
+         amount <- valFromObj "amount" value >>= decimal
+         unit <- fmap dropURL (valFromObj "unit" value)
+         return [assign (LIdent (rawIdentS "amount")) amount
+                ,assign (LIdent (rawIdentS "unit")) (K unit)]
+      `mplus`
+      do value <- valFromObj "value" dv            -- time
+         time  <- valFromObj "time" value
+         model <- fmap dropURL (valFromObj "calendarmodel" value)
+         precision <- valFromObj "precision" value
+         return [assign (LIdent (rawIdentS "time")) (K time)
+                ,assign (LIdent (rawIdentS "calendarmodel")) (K model)
+                ,assign (LIdent (rawIdentS "precision")) (EInt precision)]
+      `mplus`
+      do value    <- valFromObj "value" dv
+         text     <- valFromObj "text" value
+         language <- valFromObj "language" value
+         return [assign (LIdent (rawIdentS "text")) (K text)
+                ,assign (LIdent (rawIdentS "language")) (K language)]
+      `mplus`
+      Error "Cannot parse a datavalue"
+
+    dropURL s = match "http://www.wikidata.org/entity/" s
+      where
+        match []     ys     = ys
+        match (x:xs) (y:ys)
+         | x == y           = match xs ys
+        match _      _      = s
+
+    decimal ('+':s) = decimal s
+    decimal s       =
+      case reads s of
+        [(n,"")] -> return (EInt n)
+        _        -> case reads s of
+                      [(d,"")] -> return (EFloat d)
+                      _        -> Error "Not a decimal"
+
+interactive entity db mo sgr gr cnc qid = runInputT defaultSettings loop
+  where
+    loop :: InputT IO ()
+    loop = do
+      minput <- getInputLine (qid++"> ")
+      case minput of
+        Nothing    -> return ()
+        Just input -> case runP pTerm (BS.pack input) of
+                        Right term     -> do case runCheck (checkComputeTerm term) of
+                                               O.Ok (terms,msg) -> do outputStr msg
+                                                                      mapM_ (\term -> outputStrLn (render (ppTerm Unqualified 0 term))) terms
+                                               O.Bad msg       -> do outputStrLn msg
+                                             loop
+                        Left (pos,msg) -> do outputStrLn (show pos ++ msg)
+                                             loop
+                                             
+    checkComputeTerm term = do
+      term <- renameSourceTerm sgr mo term
+      runEvalM sgr $ do
+        tnk <- newThunk [] entity
+        val <- eval [(identS "entity",tnk)] term []
+        value2term [] val

src/compiler/gf.cabal

@@ -238,3 +238,87 @@ test-suite gf-tests
     process >= 1.4.3 && < 1.7
   build-tool-depends: gf:gf
   default-language: Haskell2010
+
+executable gf-scribe
+  main-is: gf-scribe.hs
+  default-language:    Haskell2010
+  build-depends: pgf2 >= 4.0.0,
+                 base >= 4.6 && <5,
+                 array,
+                 containers,
+                 bytestring,
+                 utf8-string,
+                 random,
+                 pretty,
+                 mtl,
+                 ghc-prim,
+                 filepath, directory>=1.2, time,
+                 http-slim,
+                 process, haskeline, parallel>=3, json
+  if os(windows)
+    build-depends:
+      Win32 >= 2.3.1.1 && < 2.7
+  else
+    build-depends:
+      terminfo >=0.4.0 && < 0.5,
+      unix >= 2.7.2 && < 2.8
+  ghc-options: -threaded
+  other-modules:
+    GF.Scribe
+    Data.Binary
+    Data.Binary.Builder
+    Data.Binary.Get
+    Data.Binary.IEEE754
+    Data.Binary.Put
+    GF.Compile.Update
+    GF.Compile.Compute.Concrete
+    GF.Compile.CheckGrammar
+    GF.Compile.GenerateBC
+    GF.Compile.GeneratePMCFG
+    GF.Compile.GetGrammar
+    GF.Compile.GrammarToPGF
+    GF.Compile.OptimizePGF
+    GF.Compile.ReadFiles
+    GF.Compile.Rename
+    GF.Compile.SubExOpt
+    GF.Compile.Tags
+    GF.Compile.TypeCheck.Abstract
+    GF.Compile.TypeCheck.Concrete
+    GF.Compile.TypeCheck.ConcreteNew
+    GF.Compile.TypeCheck.Primitives
+    GF.Compile.TypeCheck.TC
+    GF.Compile
+    GF.CompileOne
+    GF.Data.ErrM
+    GF.Data.Operations
+    GF.Data.Relation
+    GF.Data.Str
+    GF.Data.Utilities
+    GF.Grammar
+    GF.Grammar.Lexer
+    GF.Grammar.Parser
+    GF.Grammar.BNFC
+    GF.Grammar.CFG
+    GF.Grammar.EBNF
+    GF.Grammar.Grammar
+    GF.Grammar.Lockfield
+    GF.Grammar.Lookup
+    GF.Grammar.Macros
+    GF.Grammar.Predef
+    GF.Grammar.Printer
+    GF.Grammar.Values
+    GF.Grammar.Binary
+    GF.Grammar.PatternMatch
+    GF.Grammar.Unify
+    GF.Infra.CheckM
+    GF.Infra.GetOpt
+    GF.Infra.Ident
+    GF.Infra.Location
+    GF.Infra.Option
+    GF.Infra.UseIO
+    GF.System.Catch
+    GF.System.Console
+    GF.System.Directory
+    GF.Text.Pretty
+    GF.Text.Coding
+    Paths_gf