diff --git a/src/compiler/GF/Scribe.hs b/src/compiler/GF/Scribe.hs new file mode 100644 index 000000000..300325cfc --- /dev/null +++ b/src/compiler/GF/Scribe.hs @@ -0,0 +1,2 @@ +module GF.Scribe where + diff --git a/src/compiler/gf-scribe.hs b/src/compiler/gf-scribe.hs new file mode 100644 index 000000000..8e78ba966 --- /dev/null +++ b/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 diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal index de54c7d53..1bcf5f37f 100644 --- a/src/compiler/gf.cabal +++ b/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