Restoring old functionality

src/GF/API/IOGrammar.hs

@@ -6,6 +6,7 @@ import PGrammar
 import TypeCheck
 import Compile
 import ShellState
+import GetGrammar
 
 import Modules
 import Option
@@ -36,13 +37,19 @@ string2annotTree gr m = annotate gr . string2absTerm (prt m) ---- prt
 ---string2paramList st = map (renameTrm (lookupConcrete st) . patt2term) . pPattList
 
 shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState
-shellStateFromFiles opts st file | fileSuffix file == "gfcm" = do
-  (_,_,cgr) <- compileOne opts (compileEnvShSt st []) file
-  ioeErr $ updateShellState opts st (cgr,(emptyMGrammar,[]))  
-shellStateFromFiles opts st file = do
-  let osb = if oElem showOld opts 
-               then addOptions (options [beVerbose]) opts -- for old, no emit
-               else addOptions (options [beVerbose, emitCode]) opts -- for new, do
-  grts <- compileModule osb st file
-  ioeErr $ updateShellState opts st grts
-  --- liftM (changeModTimes rts) $ grammar2shellState opts gr
+shellStateFromFiles opts st file = case fileSuffix file of
+  "cf" -> do
+     let opts' = addOptions (options [beVerbose]) opts
+     sgr <- getCFGrammar opts' file
+     ioeIO $ print sgr -----
+     return st
+  "gfcm" -> do
+     (_,_,cgr) <- compileOne opts (compileEnvShSt st []) file
+     ioeErr $ updateShellState opts st (cgr,(emptyMGrammar,[]))  
+  _ -> do
+     let osb = if oElem showOld opts 
+                 then addOptions (options [beVerbose]) opts -- for old, no emit
+                 else addOptions (options [beVerbose, emitCode]) opts -- for new,do
+     grts <- compileModule osb st file
+     ioeErr $ updateShellState opts st grts
+     --- liftM (changeModTimes rts) $ grammar2shellState opts gr

src/GF/CF/CFIdent.hs

@@ -68,6 +68,10 @@ varCFFun = mkCFFun . AV
 consCFFun :: CIdent -> CFFun
 consCFFun = mkCFFun . AC
 
+-- standard way of making cf fun
+string2CFFun :: String -> String -> CFFun
+string2CFFun m c = consCFFun $ mkCIdent m c
+
 stringCFFun :: String -> CFFun 
 stringCFFun = mkCFFun . AS
 
@@ -80,6 +84,9 @@ dummyCFFun = varCFFun $ identC "_" --- used in lexer-by-need rules
 cfFun2String :: CFFun -> String
 cfFun2String (CFFun (f,_)) = prt f
 
+cfFun2Ident :: CFFun -> Ident
+cfFun2Ident (CFFun (f,_)) = identC $ prt_ f ---
+
 cfFun2Profile :: CFFun -> Profile
 cfFun2Profile (CFFun (_,p)) = p
 
@@ -131,6 +138,9 @@ moduleOfCFCat (CFCat (CIQ m _, _)) = m
 cfCat2Cat :: CFCat -> (Ident,Ident)
 cfCat2Cat (CFCat (CIQ m c,_)) = (m,c)
 
+cfCat2Ident :: CFCat -> Ident
+cfCat2Ident = snd . cfCat2Cat
+
 lexCFCat :: CFCat -> CFCat
 lexCFCat cat = ident2CFCat (uncurry CIQ (cfCat2Cat cat)) (identC "*")
 

src/GF/CF/CFtoGrammar.hs

@@ -0,0 +1,50 @@
+module CFtoGrammar where
+
+import Ident
+import Grammar
+import qualified AbsGF as A
+import qualified GrammarToSource as S
+import Macros
+
+import CF
+import CFIdent
+import PPrCF
+
+import Operations
+
+import List (nub)
+import Char (isSpace)
+
+-- 26/1/2000 -- 18/4 -- 24/3/2004
+
+cf2grammar :: CF -> [A.TopDef]
+cf2grammar cf = concatMap S.trAnyDef (abs ++ conc) where
+  rules = rulesOfCF cf
+  abs   = cats ++ funs
+  conc  = lintypes ++ lins
+  cats  = [(cat, AbsCat (yes []) (yes [])) | 
+             cat <- nub (concat (map cf2cat rules))] ----notPredef cat
+  lintypes = [] ----[(cat, CncCat (yes) nope Nothing) | (cat,AbsCat _ _) <- cats]
+  (funs,lins) = unzip (map cf2rule rules)
+
+cf2cat :: CFRule -> [Ident]
+cf2cat (_,(cat, items)) = map cfCat2Ident $ cat : [c | CFNonterm c <- items]
+
+cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
+cf2rule (fun, (cat, items)) = (def,ldef) where
+ f     = cfFun2Ident fun
+ def   = (f, AbsFun (yes (mkProd (args', Cn (cfCat2Ident cat), []))) nope)
+ args0 = zip (map (mkIdent "x") [0..]) items
+ args  = [(v, Cn (cfCat2Ident c)) | (v, CFNonterm c) <- args0]
+ args' = [(zIdent "_", Cn (cfCat2Ident c)) | (_, CFNonterm c) <- args0]
+ ldef  = (f, CncFun 
+               Nothing 
+               (yes (mkAbs (map fst args) 
+                      (mkRecord linLabel [foldconcat (map mkIt args0)])))
+               nope)
+ mkIt (v, CFNonterm _) = P (Vr v) (linLabel 0)
+ mkIt (_, CFTerm (RegAlts [a])) = K a
+ mkIt _ = K "" --- regexp not recognized in input CF ; use EBNF for this
+ foldconcat [] = K ""
+ foldconcat tt = foldr1 C tt
+

src/GF/CF/PPrCF.hs

@@ -6,6 +6,8 @@ import CFIdent
 import AbsGFC
 import PrGrammar
 
+import Char
+
 -- printing and parsing CF grammars, rules, and trees AR 26/1/2000 -- 9/6/2003
 ---- use the Print class instead!
 
@@ -42,18 +44,25 @@ prRegExp (RegAlts tt) = case tt of
   [t] -> prQuotedString t
   _ -> prParenth (prTList " | " (map prQuotedString tt))
 
-{- ----
 -- rules have an amazingly easy parser, if we use the format
 -- fun. C -> item1 item2 ... where unquoted items are treated as cats
 -- Actually would be nice to add profiles to this.
 
-getCFRule :: String -> Maybe CFRule
-getCFRule s = getcf (wrds s) where
+getCFRule :: String -> String -> Err CFRule
+getCFRule mo s = getcf (wrds s) where
   getcf ww | length ww > 2 && ww !! 2 `elem` ["->", "::="] = 
-            Just (string2CFFun (init fun), (string2CFCat cat, map mkIt its)) where
+       Ok (string2CFFun mo (init fun), (string2CFCat mo cat, map mkIt its)) where
     fun : cat : _ : its = words s
     mkIt ('"':w@(_:_)) = atomCFTerm (string2CFTok (init w))
-    mkIt w = CFNonterm (string2CFCat w)
-  getcf _ = Nothing
+    mkIt w = CFNonterm (string2CFCat mo w)
+  getcf _ = Bad "invalid rule"
   wrds = takeWhile (/= ";") . words -- to permit semicolon in the end
--}
+
+pCF :: String -> String -> Err CF
+pCF mo s = do
+  rules <- mapM (getCFRule mo) $ filter isRule $ lines s
+  return $ rules2CF rules
+ where
+   isRule line = case line of
+     '-':'-':_ -> False
+     _ -> not $ all isSpace line

src/GF/Compile/CheckGrammar.hs

@@ -13,6 +13,7 @@ import LookAbs
 import Macros
 import ReservedWords ----
 import PatternMatch
+import AppPredefined
 
 import Operations
 import CheckM
@@ -207,6 +208,8 @@ computeLType gr t = do
  where
   comp ty = case ty of
 
+    Q m _ | m == cPredef -> return ty
+
     Q m ident -> do
       ty' <- checkErr (lookupResDef gr m ident) 
       if ty' == ty then return ty else comp ty' --- is this necessary to test?
@@ -256,6 +259,8 @@ checkReservedId x = let c = prt x in
 inferLType :: SourceGrammar -> Term -> Check (Term, Type)
 inferLType gr trm = case trm of
 
+   Q m ident | m==cPredef -> termWith trm $ checkErr (typPredefined ident)
+
    Q m ident -> checks [
      termWith trm $ checkErr (lookupResType gr m ident)
      ,
@@ -616,6 +621,7 @@ checkEqLType env t u trm = do
      ---- this should be made in Rename
      (Q  m a, Q  n b) | a == b -> elem m (allExtendsPlus env n) 
                                || elem n (allExtendsPlus env m)
+                               || m == n --- for Predef
      (QC m a, QC n b) | a == b -> elem m (allExtendsPlus env n) 
                                || elem n (allExtendsPlus env m)
      (QC m a, Q  n b) | a == b -> elem m (allExtendsPlus env n) 

src/GF/Compile/GetGrammar.hs

@@ -16,6 +16,9 @@ import Option
 import ParGF
 import qualified LexGF as L
 
+import PPrCF
+import CFtoGrammar
+
 import ReadFiles ----
 
 import List (nub)
@@ -81,3 +84,11 @@ oldLexer = map change . L.tokens where
   new = words $ "abstract concrete interface incomplete " ++ 
                 "instance out open resource reuse transfer union with where"
 
+getCFGrammar :: Options -> FilePath -> IOE SourceGrammar
+getCFGrammar opts file = do
+  let mo = takeWhile (/='-') file
+  s    <- ioeIO $ readFileIf file
+  cf   <- ioeErr $ pCF mo file
+  defs <- return $ cf2grammar cf
+  let g = A.OldGr A.NoIncl defs
+  ioeErr $ transOldGrammar opts file g

src/GF/Compile/Rename.hs

@@ -6,6 +6,7 @@ import Modules
 import Ident
 import Macros
 import PrGrammar
+import AppPredefined
 import Lookup
 import Extend
 import Operations
@@ -56,6 +57,7 @@ renameIdentTerm env@(act,imps) t =
   Cn c -> do
     f <- lookupTreeMany prt opens c
     return $ f c
+  Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
   Q m' c -> do
     m <- lookupErr m' qualifs
     f <- lookupTree prt c m

src/GF/Grammar/AppPredefined.hs

@@ -3,12 +3,34 @@ module AppPredefined where
 import Operations
 import Grammar
 import Ident
-import PrGrammar (prt)
+import Macros
+import PrGrammar (prt,prtBad)
 ---- import PGrammar (pTrm)
 
 -- predefined function type signatures and definitions. AR 12/3/2003.
 
----- typPredefined :: Term -> Err Type
+isInPredefined :: Ident -> Bool
+isInPredefined = err (const True) (const False) . typPredefined
+
+typPredefined :: Ident -> Err Type
+typPredefined c@(IC f) = case f of
+  "Int"    -> return typePType
+  "PBool"  -> return typePType
+---  "PFalse" -> -- hidden
+---  "PTrue"  ->
+  "dp"     -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
+  "drop"   -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
+  "eqInt"  -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
+  "eqStr"  -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
+  "length" -> return $ mkFunType [typeTok] (cnPredef "Int")
+  "occur"  -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
+  "plus"   -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PInt")
+----  "read"   -> (P : Type) -> Tok -> P
+----  "show"   -> (P : Type) -> P -> Tok
+  "take"   -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
+  "tk"     -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
+  _        -> prtBad "unknown in Predef:" c
+typPredefined c = prtBad "unknown in Predef:" c
 
 appPredefined :: Term -> Term
 appPredefined t = case t of

src/GF/Grammar/Macros.hs

@@ -40,6 +40,12 @@ qq (m,c) = Q m c
 
 typeForm = qTypeForm ---- no need to dist any more
 
+cPredef :: Ident
+cPredef = identC "Predef"
+
+cnPredef :: String -> Term
+cnPredef f = Q cPredef (identC f)
+
 typeFormCnc :: Type -> Err (Context, Type)
 typeFormCnc t = case t of
   Prod x a b  -> do

src/GF/Shell.hs

@@ -13,7 +13,7 @@ import API
 import IOGrammar
 import Compile
 ---- import GFTex
----- import TeachYourself -- also a subshell
+import TeachYourself -- also a subshell
 
 import ShellState
 import Option
@@ -180,7 +180,6 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
     justOutput (putStrLn (err id prt (
                 string2srcTerm src m t >>= Co.computeConcrete src))) sa
 
-{- ----
   CTranslationQuiz il ol -> justOutput (teachTranslation opts (sgr il) (sgr ol)) sa
   CTranslationList il ol n -> do 
     qs <- transTrainList opts (sgr il) (sgr ol) (toInteger n)
@@ -190,14 +189,14 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
   CMorphoList n -> do 
     qs <- useIOE [] $ morphoTrainList opts gro (toInteger n)
     returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa
--}
+
   CReadFile file   -> returnArgIO   (readFileIf file >>= return . AString) sa
   CWriteFile file  -> justOutputArg (writeFile file) sa
   CAppendFile file -> justOutputArg (appendFile file) sa
   CSpeakAloud      -> justOutputArg (speechGenerate opts) sa
   CSystemCommand s -> justOutput    (system s >> return ()) sa
------  CPutString       -> changeArg     (opSS2CommandArg (optStringCommand opts gro)) sa
------  CShowTerm        -> changeArg     (opTS2CommandArg (optPrintTerm opts gro) . s2t) sa
+  CPutString       -> changeArg    (opSS2CommandArg (optStringCommand opts gro)) sa
+-----  CShowTerm        -> changeArg  (opTS2CommandArg (optPrintTerm opts gro) . s2t) sa
 
   CSetFlag           -> changeState (addGlobalOptions opts0) sa
 ---- deprec!  CSetLocalFlag lang -> changeState (addLocalOptions lang opts0) sa
@@ -211,7 +210,10 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
   CPrintInformation c -> justOutput (useIOE () $ showInformation opts st c) sa
   CPrintLanguages     -> justOutput 
                          (putStrLn $ unwords $ map prLanguage $ allLanguages st) sa
-  CPrintMultiGrammar  -> returnArg (AString (prCanonGrammar (canModules st))) sa
+  CPrintMultiGrammar  -> do
+    sa' <- changeState purgeShellState sa
+    returnArg (AString (prCanonGrammar (canModules st))) sa'
+
 ----  CPrintGramlet       -> returnArg (AString (Gr.prGramlet st)) sa
 ----  CPrintCanonXML      -> returnArg (AString (Canon.prCanonXML st False)) sa
 ----  CPrintCanonXMLStruct -> returnArg (AString (Canon.prCanonXML st True)) sa

src/GF/Shell/PShell.hs

@@ -35,7 +35,7 @@ pCommandLine s = pFirst (chks s) where
 pCommandOpt :: [String] -> (Command, Options, [CommandArg])
 pCommandOpt (w:ws) = let 
   (os, co)     = getOptions "-" ws
-  (comm, args) = pCommand (w:co)
+  (comm, args) = pCommand (abbrevCommand w:co)
   in
   (comm, os, args)
 pCommandOpt s = (CVoid, noOptions, [AError "no parse"])
@@ -45,6 +45,15 @@ pInputString s = case s of
   ('"':_:_) -> [AString (init (tail s))]
   _         -> [AError "illegal string"]
 
+-- command rl can be written remove_language etc.
+
+abbrevCommand :: String -> String
+abbrevCommand = hds . words . map u2sp where
+  u2sp c = if c=='_' then ' ' else c
+  hds s = case s of
+    [w@[_,_]] -> w
+    _ -> map head s
+
 pCommand :: [String] -> (Command, [CommandArg])
 pCommand ws = case ws of
 
@@ -81,6 +90,7 @@ pCommand ws = case ws of
   "ps" : s      -> aString CPutString s
   "st" : s      -> aTerm   CShowTerm s
   "!"  : s      -> aUnit   (CSystemCommand (unwords s))
+  "sc" : s      -> aUnit   (CSystemCommand (unwords s))
   
   "sf" : l : [] -> aUnit (CSetLocalFlag (language l))
   "sf" : []     -> aUnit CSetFlag

src/GF/Shell/TeachYourself.hs

@@ -0,0 +1,71 @@
+module TeachYourself where
+
+import ShellState
+import API
+import Linear
+import PrGrammar
+
+import Option
+import Arch (myStdGen)
+import Operations
+import UseIO
+
+import Random --- (randoms)  --- bad import for hbc
+import System
+
+-- translation and morphology quiz. AR 10/5/2000 -- 12/4/2002
+
+teachTranslation :: Options -> GFGrammar -> GFGrammar -> IO ()
+teachTranslation opts ig og = do
+  tts <- transTrainList opts ig og infinity
+  let qas = [ (q, mkAnswer as) | (q,as) <- tts]
+  teachDialogue qas "Welcome to GF Translation Quiz."
+
+transTrainList :: 
+  Options -> GFGrammar -> GFGrammar -> Integer -> IO [(String,[String])]
+transTrainList opts ig og number = do
+  ts <- randomTreesIO opts ig (fromInteger number)
+  return $ map mkOne $ ts
+ where
+   cat = firstCatOpts opts ig
+   mkOne t = (norml (linearize ig t),map (norml . linearize og) (homonyms ig cat t))
+
+
+teachMorpho :: Options -> GFGrammar -> IO ()
+teachMorpho opts ig = useIOE () $ do
+  tts <- morphoTrainList opts ig infinity
+  let qas = [ (q, mkAnswer as) | (q,as) <- tts]
+  ioeIO $ teachDialogue qas "Welcome to GF Morphology Quiz."
+
+morphoTrainList :: Options -> GFGrammar -> Integer -> IOE [(String,[String])]
+morphoTrainList opts ig number = do
+  ts   <- ioeIO $ randomTreesIO opts ig (fromInteger number)
+  gen  <- ioeIO $ myStdGen (fromInteger number)
+  mkOnes gen ts
+ where
+   mkOnes gen (t:ts) = do
+     psss    <- ioeErr $ allLinTables gr cnc t
+     let pss = concat $ map snd $ concat psss
+     let (i,gen') = randomR (0, length pss - 1) gen
+     (ps,ss) <- ioeErr $ pss !? i
+     (_,ss0) <- ioeErr $ pss !? 0
+     let bas = concat $ take 1 ss0
+     more <- mkOnes gen' ts
+     return $ (bas +++ ":" +++ unwords (map prt_ ps), return (concat ss)) : more
+   mkOnes gen [] = return []
+ 
+   gr = grammar ig
+   cnc = cncId ig
+
+-- compare answer to the list of right answers, increase score and give feedback 
+mkAnswer :: [String] -> String -> (Integer, String) 
+mkAnswer as s = if (elem (norml s) as) 
+                   then (1,"Yes.") 
+                   else (0,"No, not" +++ s ++ ", but" ++++ unlines as)
+
+norml = unwords . words
+
+--- the maximal number of precompiled quiz problems
+infinity :: Integer
+infinity = 123 
+

src/GF/UseGrammar/Linear.hs

@@ -148,7 +148,7 @@ allLinsAsRec gr c t = linearizeNoMark gr c t >>= expandLinTables gr >>= allLinVa
 
 -- the value is a list of structures arranged as records of tables of strings
 -- only taking into account string fields
-allLinTables :: CanonGrammar ->Ident ->A.Tree -> Err [[(Label,[([Patt],[String])])]]
+allLinTables :: CanonGrammar ->Ident ->A.Tree ->Err [[(Label,[([Patt],[String])])]]
 allLinTables gr c t = do
   r' <- allLinsAsRec gr c t
   mapM (mapM getS) r'