From e2401f32ca20f8ec9bea23df909139878ad3f8bf Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@johnjcamilleri.com>
Date: Wed, 28 Nov 2018 19:22:19 +0100
Subject: Revert "remove the example-based folder. The code is still in the
 archive"

This reverts commit 05c2cfb628147f7d6fa0a6c2f38eb9d67b2eb007.
---
 src/example-based/ExampleService.hs | 128 ++++++++++++++++++++++++++++++++++++
 1 file changed, 128 insertions(+)
 create mode 100644 src/example-based/ExampleService.hs

(limited to 'src/example-based/ExampleService.hs')

diff --git a/src/example-based/ExampleService.hs b/src/example-based/ExampleService.hs
new file mode 100644
index 000000000..e6312bf96
--- /dev/null
+++ b/src/example-based/ExampleService.hs
@@ -0,0 +1,128 @@
+module ExampleService(cgiMain,cgiMain',newPGFCache) where
+import System.Random(newStdGen)
+import System.FilePath((</>),makeRelative)
+import Data.Map(fromList)
+import Data.Char(isDigit)
+import Data.Maybe(fromJust)
+import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
+import PGF
+import GF.Compile.ToAPI
+import Network.CGI
+import Text.JSON
+import CGIUtils
+import Cache
+import qualified ExampleDemo as E
+
+newPGFCache = newCache readPGF
+
+
+cgiMain :: Cache PGF -> CGI CGIResult
+cgiMain = handleErrors . handleCGIErrors . cgiMain' "." "."
+
+cgiMain' root cwd cache =
+  do command <- getInp "command"
+     environ <- parseEnviron =<< getInp "state"
+     case command of
+       "possibilities"    -> doPossibilities environ
+       "provide_example"  -> doProvideExample root cwd cache environ
+       "abstract_example" -> doAbstractExample cwd cache environ
+       "test_function"    -> doTestFunction cwd cache environ
+       _ -> throwCGIError 400 ("Unknown command: "++command) []
+
+doPossibilities environ =
+  do example_environ <- parseEnviron =<< getInp "example_state"
+     outputJSONP (E.getNext environ example_environ)
+
+doProvideExample root cwd cache environ =
+  do Just lang <- readInput "lang"
+     fun <- getCId "fun"
+     parsePGF <- readParsePGF cwd cache
+     let adjpath path = root</>makeRelative "/" (makeRelative root cwd</>path)
+     pgf <- liftIO . readCache cache . adjpath =<< getInp "grammar"
+     gen <- liftIO newStdGen
+     let Just (e,s) = E.provideExample gen environ fun parsePGF pgf lang
+         res = (showExpr [] e,s)
+     liftIO $ logError $ "proveExample ... = "++show res
+     outputJSONP res
+
+doAbstractExample cwd cache environ =
+  do example <- getInp "input"
+     Just params <- readInput "params"
+     absstr <- getInp "abstract"
+     Just abs <- return $ readExpr absstr
+     liftIO $ logError $ "abstract = "++showExpr [] abs
+     Just cat <- readInput "cat"
+     let t = mkType [] cat []
+     parsePGF <- readParsePGF cwd cache
+     let lang:_ = languages parsePGF
+     ae <- liftIO $ abstractExample parsePGF environ lang t abs example
+     outputJSONP (fmap (\(e,_)->(exprToAPI (instExpMeta params e),e)) ae)
+
+abstractExample parsePGF env lang cat abs example =
+    E.searchGoodTree env abs (parse parsePGF lang cat example)
+
+doTestFunction cwd cache environ =
+  do fun <- getCId "fun"
+     parsePGF <- readParsePGF cwd cache
+     let lang:_ = languages parsePGF
+     Just txt <- return (E.testThis environ fun parsePGF lang)
+     outputJSONP txt
+
+getCId :: String -> CGI CId
+getCId name = maybe err return =<< fmap readCId (getInp name)
+  where err = throwCGIError 400 ("Bad "++name) []
+{-
+getLimit :: CGI Int
+getLimit = maybe err return =<< readInput "limit"
+  where err = throwCGIError 400 "Missing/bad limit" []
+-}
+
+readParsePGF cwd cache =
+    do parsepgf <- getInp "parser"
+       liftIO $ readCache cache (cwd</>parsepgf)
+
+parseEnviron s = do state <- liftIO $ readIO s
+                    return $ environ state
+
+getInp name = maybe err (return . UTF8.decodeString) =<< getInput name
+  where err = throwCGIError 400 ("Missing parameter: "++name) []
+
+
+instance JSON CId where
+    showJSON = showJSON . show
+    readJSON = (readResult =<<) . readJSON
+
+instance JSON Expr where
+   showJSON = showJSON . showExpr []
+   readJSON = (m2r . readExpr =<<) . readJSON
+
+m2r = maybe (Error "read failed") Ok
+
+readResult s = case reads s of
+                 (x,r):_ | lex r==[("","")] -> Ok x
+                 _ -> Error "read failed"
+
+--------------------------------------------------------------------------------
+--            cat  lincat  fun  lin       fun  cat    cat
+environ :: ([(CId, CId)],[(CId, Expr)],[((CId, CId), [CId])]) -> E.Environ
+environ (lincats,lins0,funs) =
+    E.initial (fromList lincats) concmap fs allfs
+  where
+    concmap = fromList lins
+    allfs = map E.mkFuncWithArg funs
+    fs = [E.mkFuncWithArg f | f@((fn,_),_)<-funs, fn `elem` cns]
+    cns = map fst lins
+    lins = filter (not . E.isMeta .snd) lins0
+
+
+instExpMeta :: [CId] -> Expr -> Expr
+instExpMeta ps = fromJust . readExpr . instMeta ps . showExpr []
+
+instMeta :: [CId] -> String -> String
+instMeta ps s =
+  case break (=='?') s of
+    (s1,'?':s2) ->
+       case span isDigit s2 of
+         (s21@(_:_),s22) -> s1++show (ps!!(read s21-1))++instMeta ps s22
+         ("",s22) -> s1++'?':instMeta ps s22
+    (_,_) -> s
-- 
cgit v1.2.3