summaryrefslogtreecommitdiff
path: root/src/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF')
-rw-r--r--src/GF/API/IOGrammar.hs27
-rw-r--r--src/GF/CF/CFIdent.hs10
-rw-r--r--src/GF/CF/CFtoGrammar.hs50
-rw-r--r--src/GF/CF/PPrCF.hs23
-rw-r--r--src/GF/Compile/CheckGrammar.hs6
-rw-r--r--src/GF/Compile/GetGrammar.hs11
-rw-r--r--src/GF/Compile/Rename.hs2
-rw-r--r--src/GF/Grammar/AppPredefined.hs26
-rw-r--r--src/GF/Grammar/Macros.hs6
-rw-r--r--src/GF/Shell.hs14
-rw-r--r--src/GF/Shell/PShell.hs12
-rw-r--r--src/GF/Shell/TeachYourself.hs71
-rw-r--r--src/GF/UseGrammar/Linear.hs2
13 files changed, 233 insertions, 27 deletions
diff --git a/src/GF/API/IOGrammar.hs b/src/GF/API/IOGrammar.hs
index 483afbd86..53b056c46 100644
--- a/src/GF/API/IOGrammar.hs
+++ b/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
diff --git a/src/GF/CF/CFIdent.hs b/src/GF/CF/CFIdent.hs
index 99ab711e4..95d532e2d 100644
--- a/src/GF/CF/CFIdent.hs
+++ b/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 "*")
diff --git a/src/GF/CF/CFtoGrammar.hs b/src/GF/CF/CFtoGrammar.hs
new file mode 100644
index 000000000..440c4f7c3
--- /dev/null
+++ b/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
+
diff --git a/src/GF/CF/PPrCF.hs b/src/GF/CF/PPrCF.hs
index ff4b64e66..91ab240ea 100644
--- a/src/GF/CF/PPrCF.hs
+++ b/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
--} \ No newline at end of file
+
+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
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index 6e8abc02d..3a1b480ff 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/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)
diff --git a/src/GF/Compile/GetGrammar.hs b/src/GF/Compile/GetGrammar.hs
index 3b9acd9d6..f5698bb9c 100644
--- a/src/GF/Compile/GetGrammar.hs
+++ b/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
diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs
index 5d5bae2a9..30c2b2c71 100644
--- a/src/GF/Compile/Rename.hs
+++ b/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
diff --git a/src/GF/Grammar/AppPredefined.hs b/src/GF/Grammar/AppPredefined.hs
index 179272032..eceb749b0 100644
--- a/src/GF/Grammar/AppPredefined.hs
+++ b/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
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index 291ea7521..cc43377cb 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/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
diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
index 352f220d9..e6a0880ff 100644
--- a/src/GF/Shell.hs
+++ b/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
diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs
index 666b5b681..f890a8dcf 100644
--- a/src/GF/Shell/PShell.hs
+++ b/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
diff --git a/src/GF/Shell/TeachYourself.hs b/src/GF/Shell/TeachYourself.hs
new file mode 100644
index 000000000..623bd7b72
--- /dev/null
+++ b/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
+
diff --git a/src/GF/UseGrammar/Linear.hs b/src/GF/UseGrammar/Linear.hs
index 9459264ea..8e9deb3c5 100644
--- a/src/GF/UseGrammar/Linear.hs
+++ b/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'
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 11:53:41 +0000