GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-11 13:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

"Committed_by_peb"

Browse Source
This commit is contained in:
peb
2005-02-24 10:46:37 +00:00
parent d669e538d6
commit 59b378a4e5
43 changed files with 786 additions and 493 deletions
Download Patch File Download Diff File Expand all files Collapse all files

25
src/GF/Shell/CommandL.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : CommandL
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Date: 2005/02/24 11:46:36 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.13 $
-- > CVS $Revision: 1.14 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
@@ -32,8 +32,7 @@ import Monad (foldM)
import UTF8
-- a line-based shell
-- | a line-based shell
initEditLoop :: CEnv -> IO () -> IO ()
initEditLoop env resume = do
let env' = startEditEnv env
@@ -55,8 +54,7 @@ editLoop env state resume = do
editLoop env' state' resume
-- execute a command script and return a tree
-- | execute a command script and return a tree
execCommandHistory :: CEnv -> String -> IO (CEnv,Tree)
execCommandHistory env s = do
let env' = startEditEnv env
@@ -77,14 +75,14 @@ getCommand = do
s <- getLine
return $ pCommand s
-- decodes UTF8 if u==False, i.e. if the grammar does not use UTF8;
-- | decodes UTF8 if u==False, i.e. if the grammar does not use UTF8;
-- used in the Java GUI, which always uses UTF8
getCommandUTF :: Bool -> IO Command
getCommandUTF u = do
s <- getLine
return $ pCommand $ if u then s else decodeUTF8 s
pCommand :: String -> Command
pCommand = pCommandWords . words where
pCommandWords s = case s of
"n" : cat : _ -> CNewCat cat
@@ -147,7 +145,8 @@ pCommand = pCommandWords . words where
[] -> CVoid
_ -> CError
-- well, this lists the commands of the line-based editor
-- | well, this lists the commands of the line-based editor
initEditMsg :: CEnv -> String
initEditMsg env = unlines $
"State-dependent editing commands are given in the menu:" :
" n [Cat] = new, r [Fun] = refine, w [Fun] [Int] = wrap,":
@@ -166,17 +165,19 @@ initEditMsg env = unlines $
---- (" f [" ++ unwords (intersperse "|" allStringCommands) ++ "] = modify output") :
[]
initEditMsgEmpty :: CEnv -> String
initEditMsgEmpty env = initEditMsg env +++++ unlines (
"Start editing by n Cat selecting category\n\n" :
"-------------\n" :
["n" +++ cat | (_,cat) <- newCatMenu env]
)
showCurrentState :: CEnv -> SState -> String
showCurrentState env' state' =
unlines (tr ++ ["",""] ++ msg ++ ["",""] ++ map fst menu)
where (tr,msg,menu) = displaySStateIn env' state'
-- to read position; borrowed from Prelude; should be elsewhere
-- | to read position; borrowed from Prelude; should be elsewhere
readIntList :: String -> [Int]
readIntList s = case [x | (x,t) <- reads s, ("","") <- lex t] of
[x] -> x

108
src/GF/Shell/Commands.hs
View File

@@ -1,15 +1,19 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Commands
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Date: 2005/02/24 11:46:36 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.34 $
-- > CVS $Revision: 1.35 $
--
-- (Description of the module)
-- temporary hacks for GF 2.0
--
-- Abstract command language for syntax editing. AR 22\/8\/2001.
-- Most arguments are strings, to make it easier to receive them from e.g. Java.
-- See "CommandsL" for a parser of a command language.
-----------------------------------------------------------------------------
module Commands where
@@ -52,7 +56,7 @@ import Option
import Str (sstr) ----
import UTF8 ----
import Random (mkStdGen, newStdGen)
import Random (StdGen, mkStdGen, newStdGen)
import Monad (liftM2, foldM)
import List (intersperse)
@@ -91,41 +95,46 @@ data Command =
| CView
| CMenu
| CQuit
| CHelp (CEnv -> String) -- help message depends on grammar and interface
| CError -- syntax error in command
| CVoid -- empty command, e.g. just <enter>
| CHelp (CEnv -> String) -- ^ help message depends on grammar and interface
| CError -- ^ syntax error in command
| CVoid -- ^ empty command, e.g. just \<enter\>
-- commands affecting CEnv
| CCEnvImport String
| CCEnvEmptyAndImport String
| CCEnvOpenTerm String
| CCEnvOpenString String
| CCEnvEmpty
| CCEnvImport String -- ^ |-- commands affecting 'CEnv'
| CCEnvEmptyAndImport String -- ^ |
| CCEnvOpenTerm String -- ^ |
| CCEnvOpenString String -- ^ |
| CCEnvEmpty -- ^ |
| CCEnvOn String
| CCEnvOff String
| CCEnvOn String -- ^ |
| CCEnvOff String -- ^ |
| CCEnvGFShell String
| CCEnvGFShell String -- ^ |==========
-- other commands using IO
| CCEnvRefineWithTree String
| CCEnvRefineParse String
| CCEnvSave String FilePath
| CCEnvRefineWithTree String -- ^ |-- other commands using 'IO'
| CCEnvRefineParse String -- ^ |
| CCEnvSave String FilePath -- ^ |==========
isQuit :: Command -> Bool
isQuit CQuit = True
isQuit _ = False
-- an abstract environment type
-- | an abstract environment type
type CEnv = ShellState
grammarCEnv :: CEnv -> StateGrammar
grammarCEnv = firstStateGrammar
canCEnv :: CEnv -> CanonGrammar
canCEnv = canModules
concreteCEnv, abstractCEnv :: StateGrammar -> I.Ident
concreteCEnv = cncId
abstractCEnv = absId
stdGenCEnv :: CEnv -> SState -> StdGen
stdGenCEnv env s = mkStdGen (length (displayJustStateIn env s) * 31 +11) ---
initSStateEnv :: CEnv -> SState
initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of
Just cat -> action2commandNext (newCat gr (abs, I.identC cat)) initSState
_ -> initSState
@@ -134,8 +143,7 @@ initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of
abs = absId sgr
gr = stateGrammarST sgr
-- the main function
-- | the main function
execCommand :: CEnv -> Command -> SState -> IO (CEnv,SState)
execCommand env c s = case c of
@@ -301,14 +309,14 @@ string2varPair s = case words s of
_ -> Bad "expected format 'x y'"
startEditEnv :: CEnv -> CEnv
startEditEnv env = addGlobalOptions (options [sizeDisplay "short"]) env
-- seen on display
-- | seen on display
cMenuDisplay :: String -> Command
cMenuDisplay s = CAddOption (menuDisplay s)
newCatMenu :: CEnv -> [(Command, String)]
newCatMenu env = [(CNewCat (prQIdent c), printname env initSState c) |
(c,[]) <- allCatsOf (canCEnv env)]
@@ -378,16 +386,19 @@ mkRefineMenuAll env sstate =
-- there are three orthogonal parameters: Abs/[conc], short/long, typed/untyped
-- the default is Abs, long, untyped; the Menus menu changes the parameter
emptyMenuItem :: (Command, (String, String))
emptyMenuItem = (CVoid,("",""))
---- allStringCommands = snd $ customInfo customStringCommand
termCommandMenu, stringCommandMenu :: [(Command,String)]
termCommandMenu :: [(Command,String)]
termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands]
allTermCommands :: [String]
allTermCommands = snd $ customInfo customEditCommand
stringCommandMenu :: [(Command,String)]
stringCommandMenu = []
displayCommandMenu :: CEnv -> [(Command,String)]
@@ -413,7 +424,7 @@ changeMenuLanguage s = CAddOption (menuDisplay s)
changeMenuSize s = CAddOption (sizeDisplay s)
changeMenuTyped s = CAddOption (typeDisplay s)
menuState :: CEnv -> SState -> [String]
menuState env = map snd . mkRefineMenu env
prState :: State -> [String]
@@ -437,7 +448,7 @@ displaySStateIn env state = (tree',msg,menu) where
linAll = map lin grs
separ = singleton . map unlines . intersperse [replicate 72 '*']
---- the Boolean is a temporary hack to have two parallel GUIs
-- | the Boolean is a temporary hack to have two parallel GUIs
displaySStateJavaX :: Bool -> CEnv -> SState -> String
displaySStateJavaX isNew env state = encodeUTF8 $ mkUnicode $
unlines $ tagXML "gfedit" $ concat [
@@ -467,8 +478,9 @@ displaySStateJavaX isNew env state = encodeUTF8 $ mkUnicode $
Just lang -> optDecodeUTF8 (stateGrammarOfLang env (language lang))
_ -> id
-- the env is UTF8 if the display language is
--- should be independent
-- | the env is UTF8 if the display language is
--
-- should be independent
isCEnvUTF8 :: CEnv -> SState -> Bool
isCEnvUTF8 env st = maybe False id $ do
lang <- getOptVal opts menuDisplay
@@ -477,6 +489,7 @@ isCEnvUTF8 env st = maybe False id $ do
where
opts = addOptions (optsSState st) (globalOptions env)
langAbstract, langXML :: I.Ident
langAbstract = language "Abstract"
langXML = language "XML"
@@ -517,13 +530,26 @@ printname env state f = case getOptVal opts menuDisplay of
gr = grammar sgr
mf = ciq (cncId sgr) (snd f)
--- XML printing; does not belong here!
-- * XML printing; does not belong here!
tagsXML :: String -> [[String]] -> [String]
tagsXML t = concatMap (tagXML t)
tagAttrXML t av ss = mkTagAttrXML t av : map (indent 2) ss ++ [mkEndTagXML t]
tagXML t ss = mkTagXML t : map (indent 2) ss ++ [mkEndTagXML t]
mkTagXML t = '<':t ++ ">"
mkEndTagXML t = mkTagXML ('/':t)
mkTagAttrsXML t avs = '<':t +++ unwords [a++"="++v | (a,v) <- avs] ++">"
mkTagAttrXML t av = mkTagAttrsXML t [av]
tagAttrXML :: String -> (String, String) -> [String] -> [String]
tagAttrXML t av ss = mkTagAttrXML t av : map (indent 2) ss ++ [mkEndTagXML t]
tagXML :: String -> [String] -> [String]
tagXML t ss = mkTagXML t : map (indent 2) ss ++ [mkEndTagXML t]
mkTagXML :: String -> String
mkTagXML t = '<':t ++ ">"
mkEndTagXML :: String -> String
mkEndTagXML t = mkTagXML ('/':t)
mkTagAttrsXML :: String -> [(String, String)] -> String
mkTagAttrsXML t avs = '<':t +++ unwords [a++"="++v | (a,v) <- avs] ++">"
mkTagAttrXML :: String -> (String, String) -> String
mkTagAttrXML t av = mkTagAttrsXML t [av]

22
src/GF/Shell/JGF.hs
View File

@@ -1,15 +1,15 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : JGF
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Date: 2005/02/24 11:46:37 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.9 $
-- > CVS $Revision: 1.10 $
--
-- (Description of the module)
-- GF editing session controlled by e.g. a Java program. AR 16\/11\/2001
-----------------------------------------------------------------------------
module JGF where
@@ -31,16 +31,16 @@ import UTF8
-- GF editing session controlled by e.g. a Java program. AR 16/11/2001
---- the Boolean is a temporary hack to have two parallel GUIs
-- | the Boolean is a temporary hack to have two parallel GUIs
sessionLineJ :: Bool -> ShellState -> IO ()
sessionLineJ isNew env = do
putStrLnFlush $ initEditMsgJavaX env
let env' = addGlobalOptions (options [sizeDisplay "short",beSilent]) env
editLoopJnewX isNew env' (initSState)
-- this is the real version, with XML
---- the Boolean is a temporary hack to have two parallel GUIs
-- | this is the real version, with XML
--
-- the Boolean is a temporary hack to have two parallel GUIs
editLoopJnewX :: Bool -> CEnv -> SState -> IO ()
editLoopJnewX isNew env state = do
c <- getCommandUTF (isCEnvUTF8 env state) ----
@@ -60,10 +60,12 @@ editLoopJnewX isNew env state = do
putStrLnFlush package
editLoopJnewX isNew env' state'
welcome :: String
welcome =
"An experimental GF Editor for Java." ++
"(c) Kristofer Johannisson, Janna Khegai, and Aarne Ranta 2002 under CNU GPL."
initEditMsgJavaX :: CEnv -> String
initEditMsgJavaX env = encodeUTF8 $ mkUnicode $ unlines $ tagXML "gfinit" $
tagsXML "newcat" [["n" +++ cat] | (_,cat) <- newCatMenu env] ++
tagXML "topic" [abstractName env] ++
@@ -71,5 +73,7 @@ initEditMsgJavaX env = encodeUTF8 $ mkUnicode $ unlines $ tagXML "gfinit" $
concat [tagAttrXML "language" ("file",file) [prLanguage lang] |
(file,lang) <- zip (allGrammarFileNames env) (allLanguages env)]
initAndEditMsgJavaX :: Bool -> CEnv -> SState -> String
initAndEditMsgJavaX isNew env state =
initEditMsgJavaX env ++++ displaySStateJavaX isNew env state

16
src/GF/Shell/PShell.hs
View File

@@ -1,15 +1,15 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : PShell
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Date: 2005/02/24 11:46:37 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.17 $
-- > CVS $Revision: 1.18 $
--
-- (Description of the module)
-- parsing GF shell commands. AR 11\/11\/2001
-----------------------------------------------------------------------------
module PShell where
@@ -29,8 +29,7 @@ import IO
-- parsing GF shell commands. AR 11/11/2001
-- getting a sequence of command lines as input
-- | getting a sequence of command lines as input
getCommandLines :: IO (String,[CommandLine])
getCommandLines = do
s <- fetchCommand "> "
@@ -67,8 +66,7 @@ pInputString s = case s of
('"':_:_) -> [AString (init (tail s))]
_ -> [AError "illegal string"]
-- command rl can be written remove_language etc.
-- | command @rl@ can be written @remove_language@ etc.
abbrevCommand :: String -> String
abbrevCommand = hds . words . map u2sp where
u2sp c = if c=='_' then ' ' else c

8
src/GF/Shell/ShellCommands.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : ShellCommands
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Date: 2005/02/24 11:46:37 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.22 $
-- > CVS $Revision: 1.23 $
--
-- The datatype of shell commands and the list of their options.
-----------------------------------------------------------------------------

12
src/GF/Shell/SubShell.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : SubShell
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Date: 2005/02/24 11:46:37 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
-- > CVS $Revision: 1.7 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
@@ -35,7 +35,10 @@ editSession opts st
st' = addGlobalOptions opts st
font = maybe myUniFont mkOptFont $ getOptVal opts useFont
myUniFont :: String
myUniFont = "-mutt-clearlyu-medium-r-normal--0-0-100-100-p-0-iso10646-1"
mkOptFont :: String -> String
mkOptFont = id
translateSession :: Options -> ShellState -> IO ()
@@ -49,6 +52,7 @@ translateSession opts st = do
else translateBetweenAll grs cat s
translateLoop opts trans
translateLoop :: Options -> (String -> String) -> IO ()
translateLoop opts trans = do
let fud = oElem makeFudget opts
font = maybe myUniFont mkOptFont $ getOptVal opts useFont

16
src/GF/Shell/TeachYourself.hs
View File

@@ -1,15 +1,15 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : TeachYourself
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Date: 2005/02/24 11:46:37 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-- translation and morphology quiz. AR 10\/5\/2000 -- 12\/4\/2002
-----------------------------------------------------------------------------
module TeachYourself where
@@ -71,15 +71,17 @@ morphoTrainList opts ig number = do
gr = grammar ig
cnc = cncId ig
-- compare answer to the list of right answers, increase score and give feedback
-- | 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 :: String -> String
norml = unwords . words
--- the maximal number of precompiled quiz problems
-- | the maximal number of precompiled quiz problems
infinity :: Integer
infinity = 123