Revert "remove the example-based folder. The code is still in the archive"

This reverts commit 05c2cfb628.

src/example-based/ExampleDemo.hs

@@ -0,0 +1,553 @@
+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 <path-to-pgf> "
+
+
+  
+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)   
+
+
+-}
+ 

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

src/example-based/exb-fcgi.hs

@@ -0,0 +1,15 @@
+{-# 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

src/example-based/gf-exb.cabal

@@ -0,0 +1,25 @@
+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

src/example-based/todo.txt

@@ -0,0 +1,20 @@
+
+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