From 05c2cfb628147f7d6fa0a6c2f38eb9d67b2eb007 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Wed, 28 Nov 2018 14:34:15 +0100 Subject: [PATCH] remove the example-based folder. The code is still in the archive --- src/example-based/ExampleDemo.hs | 553 ---------------------------- src/example-based/ExampleService.hs | 128 ------- src/example-based/exb-fcgi.hs | 15 - src/example-based/gf-exb.cabal | 25 -- src/example-based/todo.txt | 20 - 5 files changed, 741 deletions(-) delete mode 100644 src/example-based/ExampleDemo.hs delete mode 100644 src/example-based/ExampleService.hs delete mode 100644 src/example-based/exb-fcgi.hs delete mode 100644 src/example-based/gf-exb.cabal delete mode 100644 src/example-based/todo.txt diff --git a/src/example-based/ExampleDemo.hs b/src/example-based/ExampleDemo.hs deleted file mode 100644 index fe4eb501d..000000000 --- a/src/example-based/ExampleDemo.hs +++ /dev/null @@ -1,553 +0,0 @@ -module ExampleDemo (Environ,initial,getNext, provideExample, testThis,mkFuncWithArg,searchGoodTree,isMeta) - where - -import PGF ---import System.IO -import Data.List ---import Control.Monad -import qualified Data.Map as Map ---import qualified Data.IntMap as IntMap -import qualified Data.Set as Set -import Data.Maybe ---import System.Environment (getArgs) -import System.Random (RandomGen) --newStdGen - - -type MyType = CId -- name of the categories from the program -type ConcType = CId -- categories from the resource grammar, that we parse on -type MyFunc = CId -- functions that we need to implement ---type FuncWithArg = ((MyFunc, MyType), Expr) -- function with arguments -type InterInstr = [String] -- lincats that were generated but not written to the file - - - -data FuncWithArg = FuncWithArg - {getName :: MyFunc, -- name of the function to generate - getType :: MyType, -- return type of the function - getTypeArgs :: [MyType] -- types of arguments - } - deriving (Show,Eq,Ord) - --- we assume that it's for English for the moment - - -type TypeMap = Map.Map MyType ConcType -- mapping found from a file - -type ConcMap = Map.Map MyFunc Expr -- concrete expression after parsing - -data Environ = Env {getTypeMap :: TypeMap, -- mapping between a category in the grammar and a concrete type from RGL - getConcMap :: ConcMap, -- concrete expression after parsing - getSigs :: Map.Map MyType [FuncWithArg], -- functions for which we have the concrete syntax already with args - getAll :: [FuncWithArg] -- all the functions with arguments - } - - -getNext :: Environ -> Environ -> ([MyFunc],[MyFunc]) -getNext env example_env = - let sgs = getSigs env - allfuncs = getAll env - names = Set.fromList $ map getName $ concat $ Map.elems sgs - exampleable = filter (\x -> (isJust $ getNameExpr x env) - && - (not $ Set.member x names) -- maybe drop this if you want to also rewrite from examples... - ) $ map getName allfuncs - testeable = filter (\x -> (isJust $ getNameExpr x env ) - && - (Set.member x names) - ) $ map getName allfuncs - - in (exampleable,testeable) - - -provideExample :: RandomGen gen => gen -> Environ -> MyFunc -> PGF -> PGF -> Language -> Maybe (Expr,String) -provideExample gen env myfunc parsePGF pgfFile lang = - fmap giveExample $ getNameExpr myfunc env - where - giveExample e_ = - let newexpr = head $ generateRandomFromDepth gen pgfFile e_ (Just 5) -- change here with the new random generator - ty = getType $ head $ filter (\x -> getName x == myfunc) $ getAll env - embeddedExpr = maybe "" (\x -> ", as in: " ++ q (linearize pgfFile lang x)) (embedInStart (getAll env) (Map.fromList [(ty,e_)])) - lexpr = linearize pgfFile lang newexpr - q s = sq++s++sq - sq = "\"" - in (newexpr,q lexpr ++ embeddedExpr) --- question, you need the IO monad for the random generator, how to do otherwise ?? --- question can you make the expression bold/italic - somehow distinguishable from the rest ? - - - -testThis :: Environ -> MyFunc -> PGF -> Language -> Maybe String -testThis env myfunc parsePGF lang = - fmap (linearize parsePGF lang . mapToResource env . llin env) $ - getNameExpr myfunc env - - --- we assume that even the functions linearized by the user will still be in getSigs along with their linearization - - --- fill in the blancs of an expression that we want to linearize for testing purposes ---------------------------------------------------------------------------- - -llin :: Environ -> Expr -> Expr -llin env expr = - let - (id,args) = fromJust $ unApp expr - --cexpr = fromJust $ Map.lookup id (getConcMap env) - in - if any isMeta args - then let - sigs = concat $ Map.elems $ getSigs env - tys = findExprWhich sigs id - in replaceConcArg 1 tys expr env - else mkApp id $ map (llin env) args - - --- argument of the meta variable to replace, list of arguments left, expression to replace, environment, current replace expression -replaceConcArg :: Int -> [MyType] -> Expr -> Environ -> Expr -replaceConcArg i [] expr env = expr -replaceConcArg i (t:ts) expr env = -- TO DO : insert randomness here !! - let ss = fromJust $ Map.lookup t $ getSigs env - args = filter (null . getTypeArgs) ss - finArg = if null args then let l = last ss in llin env (mkApp (getName l) [mkMeta j | j <- [1..(length $ getTypeArgs l)]]) - else mkApp (getName $ last args) [] - in - let newe = replaceOne i finArg expr - in replaceConcArg (i+1) ts newe env - --- replace a certain metavariable with a certain expression in another expression - return updated expression -replaceOne :: Int -> Expr -> Expr -> Expr -replaceOne i erep expr = - if isMeta expr && ((fromJust $ unMeta expr) == i) - then erep - else if isMeta expr then expr - else let (id,args) = fromJust $ unApp expr - in - mkApp id $ map (replaceOne i erep) args - - -findExprWhich :: [FuncWithArg] -> MyFunc -> [MyType] -findExprWhich lst f = getTypeArgs $ head $ filter (\x -> getName x == f) lst - - -mapToResource :: Environ -> Expr -> Expr -mapToResource env expr = - let (id,args) = maybe (error $ "tried to unwrap " ++ showExpr [] expr) (\x -> x) (unApp expr) - cmap = getConcMap env - cexp = maybe (error $ "didn't find " ++ showCId id ++ " in "++ show cmap) (\x -> x) (Map.lookup id cmap) - in - if null args then cexp - else let newargs = map (mapToResource env) args - in replaceAllArgs cexp 1 newargs - where - replaceAllArgs expr i [] = expr - replaceAllArgs expr i (x:xs) = replaceAllArgs (replaceOne i x expr) (i+1) xs - - - ------------------------------------------------ - --- embed expression in another one from the start category - -embedInStart :: [FuncWithArg] -> Map.Map MyType Expr -> Maybe Expr -embedInStart fss cs = - let currset = Map.toList cs - nextset = Map.fromList $ concat [ if elem myt (getTypeArgs farg) - then connectWithArg (myt,exp) farg else [] - | (myt,exp) <- currset, farg <- fss] - nextmap = Map.union cs nextset - maybeExpr = Map.lookup startCateg nextset - in if isNothing maybeExpr then - if Map.size nextmap == Map.size cs then Nothing --error $ "could't build " ++ show startCateg ++ "with " ++ show fss - else embedInStart fss nextmap - else return $ fromJust maybeExpr - where - connectWithArg (myt,exp) farg = - let ind = head $ elemIndices myt (getTypeArgs farg) - in [(getType farg, mkApp (getName farg) $ [mkMeta i | i <- [1..ind]] ++ [exp] ++ [mkMeta i | i <- [(ind + 1)..((length $ getTypeArgs farg) - 1)]])] - - - - - ------------------------------------------------ -{- -updateConcMap :: Environ -> MyFunc -> Expr -> Environ -updateConcMap env myf expr = - Env (getTypeMap env) (Map.insert myf expr (getConcMap env)) (getSigs env) (getAll env) - - -updateInterInstr :: Environ -> MyType -> FuncWithArg -> Environ -updateInterInstr env myt myf = - let ii = getSigs env - newInterInstr = - maybe (Map.insert myt [myf] ii) (\x -> Map.insert myt (myf:x) ii) $ Map.lookup myt ii - in Env (getTypeMap env) (getConcMap env) newInterInstr (getAll env) - - -putSignatures :: Environ -> [FuncWithArg] -> Environ -putSignatures env fss = - Env (getTypeMap env) (getConcMap env) (mkSigs fss) (getAll env) - - -updateEnv :: Environ -> FuncWithArg -> MyType -> Expr -> Environ -updateEnv env myf myt expr = - let ii = getSigs env - nn = getName myf - newInterInstr = - maybe (Map.insert myt [myf] ii) (\x -> Map.insert myt (myf:x) ii) $ Map.lookup myt ii - in Env (getTypeMap env) (Map.insert nn expr (getConcMap env)) newInterInstr (getAll env) --} - -mkSigs :: [FuncWithArg] -> Map.Map MyType [FuncWithArg] -mkSigs fss = Map.fromListWith (++) $ zip (map getType fss) (map (\x -> [x]) fss) - - - -{------------------------------------ -lang :: String -lang = "Eng" - - -parseLang :: Language -parseLang = fromJust $ readLanguage "ParseEng" - - -parsePGFfile :: String -parsePGFfile = "ParseEngAbs.pgf" -------------------------------------} - - - - - -searchGoodTree :: Environ -> Expr -> [Expr] -> IO (Maybe (Expr,Expr)) -searchGoodTree env expr [] = return Nothing -searchGoodTree env expr (e:es) = - do val <- debugReplaceArgs expr e env - maybe (searchGoodTree env expr es) (\x -> return $ Just (x,e)) val - - - -getNameExpr :: MyFunc -> Environ -> Maybe Expr -getNameExpr myfunc env = - let allfunc = filter (\x -> getName x == myfunc) $ getAll env - in - if null allfunc then Nothing - else getExpr (head allfunc) env - --- find an expression to generate where we have all the other elements available -getExpr :: FuncWithArg -> Environ -> Maybe Expr -getExpr farg env = - let tys = getTypeArgs farg - ctx = getSigs env - lst = getConcTypes ctx tys 1 - in if (all isJust lst) then Just $ mkApp (getName farg) (map fromJust lst) - else Nothing - where getConcTypes context [] i = [] - getConcTypes context (ty:types) i = - let pos = Map.lookup ty context - in - if isNothing pos || (null $ fromJust pos) then [Nothing] - else - let mm = last $ fromJust pos - mmargs = getTypeArgs mm - newi = i + length mmargs - 1 - lst = getConcTypes (Map.insert ty (init $ (fromJust pos)) context) types (newi+1) - in - if (all isJust lst) then -- i..newi - (Just $ mkApp (getName mm) [mkMeta j | j <- [1..(length mmargs)]]) : lst - else [Nothing] - - - - - --- only covers simple expressions with meta variables, not the rest... -isGeneralizationOf :: Expr -> Expr -> Bool -isGeneralizationOf genExpr testExpr = - if isMeta genExpr then True - else if isMeta testExpr then False - else let genUnwrap = unApp genExpr - testUnwrap = unApp testExpr - in if isNothing genUnwrap || isNothing testUnwrap then False -- see if you can generalize here - else let (gencid, genargs) = fromJust genUnwrap - (testcid, testargs) = fromJust testUnwrap - in - (gencid == testcid) && (length genargs == length testargs) - && (and [isGeneralizationOf g t | (g,t) <- (zip genargs testargs)]) - -{-do lst <- getConcTypes context types (i+1) - return $ mkMeta i : lst -} - -debugReplaceArgs :: Expr -> Expr -> Environ -> IO (Maybe Expr) -debugReplaceArgs aexpr cexpr env = - if isNothing $ unApp aexpr then return Nothing - else if any isNothing $ map unApp $ snd $ fromJust $ unApp aexpr then return Nothing - else - let args = map (fst.fromJust.unApp) $ snd $ fromJust $ unApp aexpr - concExprs = map (\x -> fromJust $ Map.lookup x $ getConcMap env) args - in startReplace 1 cexpr concExprs - where - startReplace i cex [] = return $ Just cex - startReplace i cex (a:as) = do val <- debugReplaceConc cex i a - maybe ( --do putStrLn $ "didn't find "++ showExpr [] a ++ " in " ++showExpr [] cexpr - return Nothing) - (\x -> --do putStrLn $ "found it, the current expression is "++ showExpr [] x - startReplace (i+1) x as) - val - -debugReplaceConc :: Expr -> Int -> Expr -> IO (Maybe Expr) -debugReplaceConc expr i e = - let (newe,isThere) = searchArg expr - in if isThere then return $ Just newe else return $ Nothing - where - searchArg e_ = - if isGeneralizationOf e e_ then (mkMeta i, True) - else maybe (e_,False) (\(cid,args) -> let repargs = map searchArg args - in (mkApp cid (map fst repargs), or $ map snd repargs)) $ unApp e_ - - -{- --- replaceArgs : Original expression to parse (from abstract syntax) -> Concrete expression (parsed) -replaceArgs :: Expr -> Expr -> Environ -> Maybe Expr -replaceArgs aexpr cexpr env = - if isNothing $ unApp aexpr then error $ "could't unwrap this "++ show aexpr - else if any isNothing $ map unApp $ snd $ fromJust $ unApp aexpr then error $ "couldn't unwrap more this : "++ show aexpr - else - let args = map (fst.fromJust.unApp) $ snd $ fromJust $ unApp aexpr - concExprs = map (\x -> fromJust $ Map.lookup x $ getConcMap env) args - in startReplace 1 cexpr concExprs - where - startReplace i cex [] = return cex - startReplace i cex (a:as) = maybe Nothing (\x -> startReplace (i+1) x as) $ replaceConc cex i a - - - -replaceConc :: Expr -> Int -> Expr -> Maybe Expr -replaceConc expr i e = - let (newe,isThere) = searchArg expr - in if isThere then return newe else Nothing - where - searchArg e_ = - if isGeneralizationOf e e_ then (mkMeta i, True) - else maybe (e_,False) (\(cid,args) -> let repargs = map searchArg args - in (mkApp cid (map fst repargs), or $ map snd repargs)) $ unApp e_ - - - -writeResults :: Environ -> String -> IO () -writeResults env fileName = - let cmap = getConcMap env - lincats = unlines $ map (\(x,y) -> "lincat " ++ showCId x ++ " = " ++ showCId y ++ " ; " ) $ Map.toList $ getTypeMap env - sigs = unlines $ map - (\x -> let n = getName x - no = length $ getTypeArgs x - oargs = unwords $ ("lin " ++ showCId n) : ["o"++show i | i <- [1..no]] - in (oargs ++ " = " ++ (simpleReplace $ showExpr [] $ fromJust $ Map.lookup n cmap) ++ " ; ")) $ concat $ Map.elems $ getSigs env - in - writeFile fileName ("\n" ++ lincats ++ "\n\n" ++ sigs) - - -simpleReplace :: String -> String -simpleReplace [] = [] -simpleReplace ('?':xs) = 'o' : simpleReplace xs -simpleReplace (x:xs) = x : simpleReplace xs --} - -isMeta :: Expr -> Bool -isMeta = isJust.unMeta - --- works with utf-8 characters also, as it seems - - -mkFuncWithArg :: ((CId,CId),[CId]) -> FuncWithArg -mkFuncWithArg ((c1,c2),cids) = FuncWithArg c1 c2 cids - - ---------------------------------------------------------------------------------- - -initial :: TypeMap -> ConcMap -> [FuncWithArg] -> [FuncWithArg] -> Environ -initial tm cm fss allfs = Env tm cm (mkSigs fss) allfs -{- -testInit :: [FuncWithArg] -> Environ -testInit allfs = initial lTypes Map.empty [] allfs - -lTypes = Map.fromList [(mkCId "Comment", mkCId "S"),(mkCId "Item", mkCId "NP"), (mkCId "Kind", mkCId "CN"), (mkCId "Quality", mkCId "AP")] --} -startCateg = mkCId "Comment" --- question about either to give the startcat or not ... - - - - - ----------------------------------------------------------------------------------------------------------- -{- -main = - do args <- getArgs - case args of - [pgfFile] -> - do pgf <- readPGF pgfFile - parsePGF <- readPGF parsePGFfile - fsWithArg <- forExample pgf - let funcsWithArg = map (map mkFuncWithArg) fsWithArg - let morpho = buildMorpho parsePGF parseLang - let fss = concat funcsWithArg - let fileName = takeWhile (/='.') pgfFile ++ lang ++ ".gf" - env <- start parsePGF pgf morpho (testInit fss) fss - putStrLn $ "Should I write the results to a file ? yes/no" - ans <-getLine - if ans == "yes" then do writeResults env fileName - putStrLn $ "Wrote file " ++ fileName - else return () - _ -> fail "usage : Testing " - - - -start :: PGF -> PGF -> Morpho -> Environ -> [FuncWithArg] -> IO Environ -start parsePGF pgfFile morpho env lst = - do putStrLn "Do you want examples from another language ? (no/concrete syntax name otherwise)" - ans1 <- getLine - putStrLn "Do you want testing mode ? (yes/no)" - ans2 <- getLine - case (ans1,ans2) of - ("no","no") -> do putStrLn "no extra language, just the abstract syntax tree" - interact env lst False Nothing - (_,"no") -> interact env lst False (readLanguage ans1) - ("no","yes") -> do putStrLn "no extra language, just the abstract syntax tree" - interact env lst True Nothing - (_,"yes") -> interact env lst True (readLanguage ans1) - ("no",_) -> do putStrLn "no extra language, just the abstract syntax tree" - putStrLn $ "I assume you don't want the testing mode ... " - interact env lst False Nothing - (_,_) -> do putStrLn $ "I assume you don't want the testing mode ... " - interact env lst False (readLanguage ans1) - where - - interact environ [] func _ = return environ - interact environ (farg:fargs) boo otherLang = - do - maybeEnv <- basicInter farg otherLang environ boo - if isNothing maybeEnv then return environ - else interact (fromJust maybeEnv) fargs boo otherLang - - basicInter farg js environ False = - let e_ = getExpr farg environ in - if isNothing e_ then return $ Just environ - else parseAndBuild farg js environ (getType farg) e_ Nothing - basicInter farg js environ True = - let (e_,e_test) = get2Expr farg environ in - if isNothing e_ then return $ Just environ - else if isNothing e_test then do putStrLn $ "not enough arguments "++ (showCId $ getName farg) - parseAndBuild farg js environ (getType farg) e_ Nothing - else parseAndBuild farg js environ (getType farg) e_ e_test - --- . head . generateRandomFrom gen2 pgfFile - parseAndBuild farg js environ ty e_ e_test = - do let expr = fromJust e_ - gen1 <- newStdGen - gen2 <- newStdGen - let newexpr = head $ generateRandomFrom gen1 pgfFile expr - let embeddedExpr = maybe "***" (showExpr [] ) (embedInStart (getAll environ) (Map.fromList [(ty,expr)])) - let lexpr = if isNothing js then "" else "\n-- " ++ linearize pgfFile (fromJust js) newexpr ++ " --" - putStrLn $ "Give an example for " ++ (showExpr [] expr) - ++ lexpr ++ "and now" - ++ "\n\nas in " ++ embeddedExpr ++ "\n\n" - -- - ex <- getLine - if (ex == ":q") then return Nothing - else - let ctype = fromJust $ Map.lookup (getType farg) (getTypeMap environ) in - do env' <- decypher farg ex expr environ (fromJust $ readType $ showCId ctype) e_test - return (Just env') - - decypher farg ex expr environ ty e_test = - --do putStrLn $ "We need to parse " ++ ex ++ " as " ++ show ctype - let pTrees = parse parsePGF (fromJust $ readLanguage "ParseEng") ty ex in - pickTree farg expr environ ex e_test pTrees - - -- putStrLn $ "And now for testing, \n is this also correct yes/no \n ## " ++ (linearize parsePGF parseLang $ mapToResource newenv $ llin newenv e_test) ++ " ##" - - -- select the right tree among the options given by the parser - pickTree farg expr environ ex e_test [] = - let miswords = morphoMissing morpho (words ex) - in - if null miswords then do putStrLn $ "all words known, but some syntactic construction is not covered by the grammar..." - return environ - else do putStrLn $ "the following words are unknown, please add them to the lexicon: " ++ show miswords - return environ - pickTree farg expr environ ex e_test [tree] = - do val <- searchGoodTree environ expr [tree] -- maybe order here after the probabilities for better precision - maybe (do putStrLn $ "none of the trees is consistent with the rest of the grammar, please check arguments " - return environ) - (\(x,newtree) -> let newenv = updateEnv environ farg (getType farg) x in - do putStrLn $ "the result is "++showExpr [] x - newtestenv <- testTest newenv e_test -- question ? should it belong there - there is just one possibility of a tree... - return newenv) val - pickTree farg expr environ ex e_test parseTrees = - do putStrLn $ "There is more than one possibility, do you want to choose the right tree yourself ? yes/no " - putStr " >" - ans <- getLine - if ans == "yes" then do pTree <- chooseRightTree parseTrees - processTree farg environ expr pTree e_test - else processTree farg environ expr parseTrees e_test - - -- introduce testing function, if it doesn't work, then reparse, take that tree - testTree envv e_test = return envv -- TO DO - add testing here - - testTest envv Nothing = return envv - testTest envv (Just exxpr) = testTree envv exxpr - - - -- allows the user to pick his own tree - chooseRightTree trees = return trees -- TO DO - add something clever here - - -- selects the tree from where one can abstract over the original arguments - processTree farg environ expr lsTrees e_test = - let trmes = if length lsTrees == 1 then "the tree is not consistent " else "none of the trees is consistent " in - do val <- searchGoodTree environ expr lsTrees - maybe (do putStrLn $ trmes ++ "with the rest of the grammar, please check arguments! " - return environ) - (\(x,newtree) -> let newenv = updateEnv environ farg (getType farg) x in - do putStrLn $ "the result is "++showExpr [] x - newtestenv <- testTest newenv e_test - return newenv) val - - - -------------------------------- - -get2Expr :: FuncWithArg -> Environ -> (Maybe Expr, Maybe Expr) -get2Expr farg env = - let tys = getTypeArgs farg - ctx = getSigs env - (lst1,lst2) = getConcTypes2 ctx tys 1 - arg1 = if (all isJust lst1) then Just $ mkApp (getName farg) (map fromJust lst1) else Nothing - arg2 = if (all isJust lst2) then Just $ mkApp (getName farg) (map fromJust lst2) else Nothing - in if arg1 == arg2 then (arg1, Nothing) - else (arg1,arg2) - where - getConcTypes2 context [] i = ([],[]) - getConcTypes2 context (ty:types) i = - let pos = Map.lookup ty context - in - if isNothing pos || (null $ fromJust pos) then ([Nothing],[Nothing]) - else - let (mm,tt) = (last $ fromJust pos, head $ fromJust pos) - mmargs = getTypeArgs mm - newi = i + length mmargs - 1 - (lst1,lst2) = getConcTypes2 (Map.insert ty (init (fromJust pos)) context) types (newi+1) - ttargs = getTypeArgs tt - newtti = i + length ttargs - 1 - fstArg = if (all isJust lst1) then -- i..newi - (Just $ mkApp (getName mm) [mkMeta j | j <- [1..(length mmargs)]]) : lst1 - else [Nothing] - sndArg = if (all isJust lst2) then - (Just $ mkApp (getName tt) [mkMeta j | j <- [1..(length ttargs)]]) : lst2 - else [Nothing] - in - (fstArg,sndArg) - - --} - \ No newline at end of file diff --git a/src/example-based/ExampleService.hs b/src/example-based/ExampleService.hs deleted file mode 100644 index e6312bf96..000000000 --- a/src/example-based/ExampleService.hs +++ /dev/null @@ -1,128 +0,0 @@ -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 = rootmakeRelative "/" (makeRelative root cwdpath) - 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 (cwdparsepgf) - -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 diff --git a/src/example-based/exb-fcgi.hs b/src/example-based/exb-fcgi.hs deleted file mode 100644 index 54f1872d0..000000000 --- a/src/example-based/exb-fcgi.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE CPP #-} -import Control.Concurrent(forkIO) -import Network.FastCGI(runFastCGI,runFastCGIConcurrent') -import ExampleService(cgiMain,newPGFCache) - -main = do --stderrToFile logFile - fcgiMain =<< newPGFCache - - -fcgiMain cache = -#ifndef mingw32_HOST_OS - runFastCGIConcurrent' forkIO 100 (cgiMain cache) -#else - runFastCGI (cgiMain cache) -#endif diff --git a/src/example-based/gf-exb.cabal b/src/example-based/gf-exb.cabal deleted file mode 100644 index 1366e75da..000000000 --- a/src/example-based/gf-exb.cabal +++ /dev/null @@ -1,25 +0,0 @@ -Name: gf-exb -Version: 1.0 -Cabal-version: >= 1.8 -Build-type: Simple -License: GPL -Synopsis: Example-based grammar writing for the Grammatical Framework - -executable exb.fcgi - main-is: exb-fcgi.hs - Hs-source-dirs: . ../server ../compiler ../runtime/haskell - other-modules: ExampleService ExampleDemo - FastCGIUtils Cache GF.Compile.ToAPI - -- and a lot more... - ghc-options: -threaded - if impl(ghc>=7.0) - ghc-options: -rtsopts - - build-depends: base >=4.2 && <5, json, cgi, fastcgi, random, - containers, old-time, directory, bytestring, utf8-string, - pretty, array, mtl, fst, filepath - - if os(windows) - ghc-options: -optl-mwindows - else - build-depends: unix diff --git a/src/example-based/todo.txt b/src/example-based/todo.txt deleted file mode 100644 index 196dbc097..000000000 --- a/src/example-based/todo.txt +++ /dev/null @@ -1,20 +0,0 @@ - -Editor improvements for example-based grammar writing: -+ Remove the same language from the example language menu -+ Send the other language environment to getNext -- Compile a new .pgf automatically when needed -- Update buttons automatically when functions are added or removed -- Switch over to using AbsParadigmsEng.pgf instead of the old exprToAPI function - -Editor support for guided construction of linearization functions -- enter api expressions by parsing them with AbsParadigmsEng.pgf in minibar -- replace simpleParseInput with one that accepts quoted string literals -- use lexcode/unlexcode in minibar -- better support for literals in minibar (completion info from the PGF - library should indicate if literals are acceptable) - -Server support for example-based grammar writing: -- Change getNext to use info from the example language -- Random generator restricted to defined functions - -- More testing