GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04: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 0137dd5511
commit bf436aebaa
43 changed files with 786 additions and 493 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/GF/CFGM/PrintCFGrammar.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : PrintCFGrammar
-- Maintainer : (Maintainer)
-- Maintainer : BB
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:08 $
-- > CVS $Date: 2005/02/24 11:46:34 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
-- > CVS $Revision: 1.7 $
--
-- Handles printing a CFGrammar in CFGM format.
-----------------------------------------------------------------------------

8
src/GF/Canon/CMacros.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:06 $
-- > CVS $Date: 2005/02/24 11:46:34 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.20 $
-- > CVS $Revision: 1.21 $
--
-- Macros for building and analysing terms in GFC concrete syntax.
--
@@ -143,6 +143,7 @@ patt2term p = case p of
anyTerm :: Term
anyTerm = LI (A.identC "_") --- should not happen
matchPatt :: [Case] -> Term -> Err Term
matchPatt cs0 (FV ts) = liftM FV $ mapM (matchPatt cs0) ts
matchPatt cs0 trm = term2patt trm >>= match cs0 where
match cs t =
@@ -199,6 +200,7 @@ allLinFields trm = case trm of
_ -> prtBad "fields can only be sought in a record not in" trm
-- | deprecated
isLinLabel :: Label -> Bool
isLinLabel l = case l of
L (A.IC ('s':cs)) | all isDigit cs -> True
-- peb (28/4-04), for MCFG grammars to work:
@@ -217,8 +219,10 @@ allLinValues trm = do
lts <- allLinFields trm
mapM (mapPairsM (return . allCaseValues)) lts
redirectIdent :: A.Ident -> CIdent -> CIdent
redirectIdent n f@(CIQ _ c) = CIQ n c
ciq :: A.Ident -> A.Ident -> CIdent
ciq n f = CIQ n f
wordsInTerm :: Term -> [String]

43
src/GF/Compile/ShellState.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:09 $
-- > CVS $Date: 2005/02/24 11:46:34 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.35 $
-- > CVS $Revision: 1.36 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
@@ -68,6 +68,7 @@ data Statistics =
--- -- etc
deriving (Eq,Ord)
emptyShellState :: ShellState
emptyShellState = ShSt {
abstract = Nothing,
concrete = Nothing,
@@ -83,10 +84,15 @@ emptyShellState = ShSt {
statistics = []
}
optInitShellState :: Options -> ShellState
optInitShellState os = addGlobalOptions os emptyShellState
type Language = Ident
language :: String -> Language
language = identC
prLanguage :: Language -> String
prLanguage = prIdent
-- | grammar for one language in a state, comprising its abs and cnc
@@ -100,6 +106,7 @@ data StateGrammar = StGr {
loptions :: Options
}
emptyStateGrammar :: StateGrammar
emptyStateGrammar = StGr {
absId = identC "#EMPTY", ---
cncId = identC "#EMPTY", ---
@@ -110,7 +117,15 @@ emptyStateGrammar = StGr {
loptions = noOptions
}
-- | analysing shell grammar into parts
-- analysing shell grammar into parts
stateGrammarST :: StateGrammar -> CanonGrammar
stateCF :: StateGrammar -> CF
statePInfo :: StateGrammar -> Cnv.PInfo
stateMorpho :: StateGrammar -> Morpho
stateOptions :: StateGrammar -> Options
stateGrammarWords :: StateGrammar -> [String]
stateGrammarST = grammar
stateCF = cf
statePInfo = pInfo
@@ -118,6 +133,7 @@ stateMorpho = morpho
stateOptions = loptions
stateGrammarWords = allMorphoWords . stateMorpho
cncModuleIdST :: StateGrammar -> CanonGrammar
cncModuleIdST = stateGrammarST
-- | form a shell state from a canonical grammar
@@ -201,6 +217,7 @@ testSameAbstract sh mcnc = do
_ -> return a'
-}
abstractName :: ShellState -> String
abstractName sh = maybe "(none)" P.prt (abstract sh)
-- | throw away those abstracts that are not needed --- could be more aggressive
@@ -278,6 +295,11 @@ stateGrammarOfLang st l = StGr {
can = M.partOfGrammar allCan
(l, maybe M.emptyModInfo id (lookup l (M.modules allCan)))
grammarOfLang :: ShellState -> Language -> CanonGrammar
cfOfLang :: ShellState -> Language -> CF
morphoOfLang :: ShellState -> Language -> Morpho
optionsOfLang :: ShellState -> Language -> Options
grammarOfLang st = stateGrammarST . stateGrammarOfLang st
cfOfLang st = stateCF . stateGrammarOfLang st
morphoOfLang st = stateMorpho . stateGrammarOfLang st
@@ -304,7 +326,17 @@ stateAbstractGrammar st = StGr {
}
-- | analysing shell state into parts
-- analysing shell state into parts
globalOptions :: ShellState -> Options
allLanguages :: ShellState -> [Language]
allCategories :: ShellState -> [G.Cat]
allStateGrammars :: ShellState -> [StateGrammar]
allStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)]
allGrammarFileNames :: ShellState -> [String]
allActiveStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)]
allActiveGrammars :: ShellState -> [StateGrammar]
globalOptions = gloptions
allLanguages = map (fst . fst) . concretes
allCategories = map fst . allCatsOf . canModules
@@ -350,6 +382,7 @@ firstAbsCat :: Options -> StateGrammar -> G.QIdent
firstAbsCat opts = cfCat2Cat . firstCatOpts opts
-- | a grammar can have start category as option startcat=foo ; default is S
stateFirstCat :: StateGrammar -> CFCat
stateFirstCat sgr =
maybe (string2CFCat a "S") (string2CFCat a) $
getOptVal (stateOptions sgr) gStartCat
@@ -369,6 +402,7 @@ hasStateAbstract = maybe False (const True) . maybeStateAbstract
abstractOfState = maybe emptyAbstractST id . maybeStateAbstract
-}
stateIsWord :: StateGrammar -> String -> Bool
stateIsWord sg = isKnownWord (stateMorpho sg)
@@ -420,6 +454,7 @@ type ShellStateOperErr = ShellState -> Err ShellState
reinitShellState :: ShellStateOper
reinitShellState = const emptyShellState
languageOn, languageOff :: Language -> ShellStateOper
languageOn = languageOnOff True
languageOff = languageOnOff False

27
src/GF/Data/Operations.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Date: 2005/02/24 11:46:35 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.15 $
-- > CVS $Revision: 1.16 $
--
-- some auxiliary GF operations. AR 19\/6\/1998 -- 6\/2\/2001
--
@@ -239,8 +239,13 @@ errAndMsg (Ok a) = return (a,[])
-- | a three-valued maybe type to express indirections
data Perhaps a b = Yes a | May b | Nope deriving (Show,Read,Eq,Ord)
yes :: a -> Perhaps a b
yes = Yes
may :: b -> Perhaps a b
may = May
nope :: Perhaps a b
nope = Nope
mapP :: (a -> c) -> Perhaps a b -> Perhaps c b
@@ -419,6 +424,7 @@ paragraphs = map unlines . chop . lines where
indent :: Int -> String -> String
indent i s = replicate i ' ' ++ s
(+++), (++-), (++++), (+++++) :: String -> String -> String
a +++ b = a ++ " " ++ b
a ++- "" = a
a ++- b = a +++ b
@@ -432,26 +438,31 @@ prUpper s = s1 ++ s2' where
c:t -> toUpper c : t
_ -> s2
prReplicate :: Int -> String -> String
prReplicate n s = concat (replicate n s)
prTList :: String -> [String] -> String
prTList t ss = case ss of
[] -> ""
[s] -> s
s:ss -> s ++ t ++ prTList t ss
prQuotedString :: String -> String
prQuotedString x = "\"" ++ restoreEscapes x ++ "\""
prParenth :: String -> String
prParenth s = if s == "" then "" else "(" ++ s ++ ")"
prCurly, prBracket :: String -> String
prCurly s = "{" ++ s ++ "}"
prBracket s = "[" ++ s ++ "]"
prArgList xx = prParenth (prTList "," xx)
prArgList, prSemicList, prCurlyList :: [String] -> String
prArgList = prParenth . prTList ","
prSemicList = prTList " ; "
prCurlyList = prCurly . prSemicList
restoreEscapes :: String -> String
restoreEscapes s =
case s of
[] -> []
@@ -476,6 +487,7 @@ prIfEmpty em _ _ [] = em
prIfEmpty em nem1 nem2 s = nem1 ++ s ++ nem2
-- | Thomas Hallgren's wrap lines
wrapLines :: Int -> String -> String
wrapLines n "" = ""
wrapLines n s@(c:cs) =
if isSpace c
@@ -491,15 +503,17 @@ wrapLines n s@(c:cs) =
--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
-- LaTeX code producing functions
dollar, mbox, ital, boldf, verbat :: String -> String
dollar s = '$' : s ++ "$"
mbox s = "\\mbox{" ++ s ++ "}"
ital s = "{\\em" +++ s ++ "}"
boldf s = "{\\bf" +++ s ++ "}"
verbat s = "\\verbat!" ++ s ++ "!"
mkLatexFile :: String -> String
mkLatexFile s = begindocument +++++ s +++++ enddocument
begindocument, enddocument :: String
begindocument =
"\\documentclass[a4paper,11pt]{article}" ++++ -- M.F. 25/01-02
"\\setlength{\\parskip}{2mm}" ++++
@@ -510,7 +524,6 @@ begindocument =
"\\setlength{\\textheight}{240mm}" ++++
"\\setlength{\\textwidth}{158mm}" ++++
"\\begin{document}\n"
enddocument =
"\n\\end{document}\n"

37
src/GF/Data/Parsers.hs
View File

@@ -5,9 +5,9 @@
-- Stability : Almost Obsolete
-- Portability : Haskell 98
--
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Date: 2005/02/24 11:46:35 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
-- > CVS $Revision: 1.5 $
--
-- some parser combinators a la Wadler and Hutton.
-- no longer used in many places in GF
@@ -142,24 +142,45 @@ lits ts = literals ts
jL :: String -> Parser Char String
jL = pJ . lits
pParenth :: Parser Char a -> Parser Char a
pParenth p = literal '(' +.. pJunk +.. p ..+ pJunk ..+ literal ')'
pCommaList p = pTList "," (pJ p) -- p,...,p
pOptCommaList p = pCommaList p ||| succeed [] -- the same or nothing
pArgList p = pParenth (pCommaList p) ||| succeed [] -- (p,...,p), poss. empty
pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:) -- min.2 args
-- | p,...,p
pCommaList :: Parser Char a -> Parser Char [a]
pCommaList p = pTList "," (pJ p)
-- | the same or nothing
pOptCommaList :: Parser Char a -> Parser Char [a]
pOptCommaList p = pCommaList p ||| succeed []
-- | (p,...,p), poss. empty
pArgList :: Parser Char a -> Parser Char [a]
pArgList p = pParenth (pCommaList p) ||| succeed []
-- | min. 2 args
pArgList2 :: Parser Char a -> Parser Char [a]
pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:)
longestOfSome :: Parser a b -> Parser a [b]
longestOfSome p = (p ... longestOfMany p) *** (\ (x,y) -> x:y)
pIdent :: Parser Char String
pIdent = pLetter ... longestOfMany pAlphaPlusChar *** uncurry (:)
where alphaPlusChar c = isAlphaNum c || c=='_' || c=='\''
pLetter, pDigit :: Parser Char Char
pLetter = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z'] ++
['À' .. 'Û'] ++ ['à' .. 'û'])) -- no such in Char
pDigit = satisfy isDigit
pLetters = longestOfSome pLetter
pDigit = satisfy isDigit
pLetters :: Parser Char String
pLetters = longestOfSome pLetter
pAlphanum, pAlphaPlusChar :: Parser Char Char
pAlphanum = pDigit ||| pLetter
pAlphaPlusChar = pAlphanum ||| satisfy (`elem` "_'")
pQuotedString :: Parser Char String
pQuotedString = literal '"' +.. pEndQuoted where
pEndQuoted =
literal '"' *** (const [])

14
src/GF/Data/Str.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:16 $
-- > CVS $Date: 2005/02/24 11:46:35 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
-- > CVS $Revision: 1.7 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
@@ -26,16 +26,16 @@ import List (isPrefixOf, isSuffixOf, intersperse)
-- | abstract token list type. AR 2001, revised and simplified 20\/4\/2003
newtype Str = Str [Tok] deriving (Read, Show, Eq, Ord)
-- | notice that having both pre and post would leave to inconsistent situations:
--
-- > pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"}
--
-- always violates a condition expressed by the one or the other
data Tok =
TK String
| TN Ss [(Ss, [String])] -- ^ variants depending on next string
--- | TP Ss [(Ss, [String])] -- variants depending on previous string
deriving (Eq, Ord, Show, Read)
-- ^ notice that having both pre and post would leave to inconsistent situations:
--
-- > pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"}
--
-- always violates a condition expressed by the one or the other
-- | a variant can itself be a token list, but for simplicity only a list of strings

8
src/GF/Data/Zipper.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:16 $
-- > CVS $Date: 2005/02/24 11:46:36 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
-- > CVS $Revision: 1.7 $
--
-- Gérard Huet's zipper (JFP 7 (1997)). AR 10\/8\/2001
-----------------------------------------------------------------------------
@@ -62,6 +62,7 @@ data Path a =
| Node ([Tr a], (Path a, a), [Tr a])
deriving Show
leaf :: a -> Tr a
leaf a = Tr (a,[])
newtype Loc a = Loc (Tr a, Path a) deriving Show
@@ -132,6 +133,7 @@ goBackN i st
-- added mappings between locations and trees
loc2tree :: Loc a -> Tr a
loc2tree (Loc (t,p)) = case p of
Top -> t
Node (left,(p',v),right) ->
@@ -143,8 +145,10 @@ loc2treeMarked (Loc (Tr (a,ts),p)) =
where
(mark, nomark) = (\a -> (a,True), \a -> (a, False))
tree2loc :: Tr a -> Loc a
tree2loc t = Loc (t,Top)
goRoot :: Loc a -> Loc a
goRoot = tree2loc . loc2tree
goLast :: Loc a -> Err (Loc a)

10
src/GF/Fudgets/CommandF.hs
View File

@@ -1,15 +1,15 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : CommandF
-- 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.4 $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-- a graphical shell for any kind of GF with Zipper editing. AR 20\/8\/2001
-----------------------------------------------------------------------------
module CommandF where

52
src/GF/Grammar/MMacros.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:12 $
-- > CVS $Date: 2005/02/24 11:46:34 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
-- > CVS $Revision: 1.7 $
--
-- some more abstractions on grammars, esp. for Edit
-----------------------------------------------------------------------------
@@ -27,19 +27,33 @@ import Macros
import Monad
nodeTree :: Tree -> TrNode
argsTree :: Tree -> [Tree]
nodeTree (Tr (n,_)) = n
argsTree (Tr (_,ts)) = ts
isFocusNode (N (_,_,_,_,b)) = b
bindsNode (N (b,_,_,_,_)) = b
atomNode (N (_,a,_,_,_)) = a
valNode (N (_,_,v,_,_)) = v
constrsNode (N (_,_,_,(c,_),_)) = c
isFocusNode :: TrNode -> Bool
bindsNode :: TrNode -> Binds
atomNode :: TrNode -> Atom
valNode :: TrNode -> Val
constrsNode :: TrNode -> Constraints
metaSubstsNode :: TrNode -> MetaSubst
isFocusNode (N (_,_,_,_,b)) = b
bindsNode (N (b,_,_,_,_)) = b
atomNode (N (_,a,_,_,_)) = a
valNode (N (_,_,v,_,_)) = v
constrsNode (N (_,_,_,(c,_),_)) = c
metaSubstsNode (N (_,_,_,(_,m),_)) = m
atomTree :: Tree -> Atom
valTree :: Tree -> Val
atomTree = atomNode . nodeTree
valTree = valNode . nodeTree
mkNode :: Binds -> Atom -> Val -> (Constraints, MetaSubst) -> TrNode
mkNode binds atom vtyp cs = N (binds,atom,vtyp,cs,False)
type Var = Ident
@@ -91,14 +105,14 @@ vClos = VClos []
uExp :: Exp
uExp = Meta meta0
mExp :: Exp
mExp = Meta meta0
mExp, mExp0 :: Exp
mExp = Meta meta0
mExp0 = mExp
meta2exp :: MetaSymb -> Exp
meta2exp = Meta
atomC :: Fun -> Atom
atomC = AtC
funAtom :: Atom -> Err Fun
@@ -114,6 +128,7 @@ atomIsMeta atom = case atom of
AtM _ -> True
_ -> False
getMetaAtom :: Atom -> Err Meta
getMetaAtom a = case a of
AtM m -> return m
_ -> Bad "the active node is not meta"
@@ -148,12 +163,17 @@ alphaConv oldvars (x,x') = substitute (x:x':oldvars) [(x,Vr x')]
alphaFresh :: [Var] -> Exp -> Err Exp
alphaFresh vs = refreshTermN $ maxVarIndex vs
-- | done in a state monad
alphaFreshAll :: [Var] -> [Exp] -> Err [Exp]
alphaFreshAll vs = mapM $ alphaFresh vs -- done in a state monad
alphaFreshAll vs = mapM $ alphaFresh vs
-- | for display
val2exp :: Val -> Err Exp
val2exp = val2expP False
val2exp = val2expP False -- for display
val2expSafe = val2expP True -- for type checking
-- | for type checking
val2expSafe :: Val -> Err Exp
val2expSafe = val2expP True
val2expP :: Bool -> Val -> Err Exp
val2expP safe v = case v of
@@ -191,6 +211,7 @@ freeVarsExp e = case e of
Prod x a b -> freeVarsExp a ++ filter (/=x) (freeVarsExp b)
_ -> [] --- thus applies to abstract syntax only
ident2string :: Ident -> String
ident2string = prIdent
tree :: (TrNode,[Tree]) -> Tree
@@ -230,7 +251,8 @@ ref2exp bounds typ ref = do
return $ mkApp ref args
-- no refreshment of metas
type Ref = Exp -- invariant: only Con or Var
-- | invariant: only 'Con' or 'Var'
type Ref = Exp
fun2wrap :: [Var] -> ((Fun,Int),Type) -> Exp -> Err Exp
fun2wrap oldvars ((fun,i),typ) exp = do
@@ -252,6 +274,7 @@ compatType v t = errVal True $ do
---
mkJustProd :: Context -> Term -> Term
mkJustProd cont typ = mkProd (cont,typ,[])
int2var :: Int -> Ident
@@ -263,6 +286,7 @@ meta0 = int2meta 0
termMeta0 :: Term
termMeta0 = Meta meta0
identVar :: Term -> Err Ident
identVar (Vr x) = return x
identVar _ = Bad "not a variable"

43
src/GF/Grammar/Macros.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:12 $
-- > CVS $Date: 2005/02/24 11:46:34 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.17 $
-- > CVS $Revision: 1.18 $
--
-- Macros for constructing and analysing source code terms.
--
@@ -52,7 +52,8 @@ qTypeForm t = case t of
qq :: QIdent -> Term
qq (m,c) = Q m c
typeForm = qTypeForm ---- no need to dist any more
typeForm :: Type -> Err (Context, Cat, [Term])
typeForm = qTypeForm ---- no need to distinguish any more
cPredef :: Ident
cPredef = identC "Predef"
@@ -160,6 +161,7 @@ stripTerm t = case t of
stripPatt p = errVal p $ term2patt $ stripTerm $ patt2term p
-}
computed :: Term -> Term
computed = Computed
termForm :: Term -> Err ([(Ident)], Term, [Term])
@@ -219,6 +221,7 @@ mkLet defs t = foldr Let t defs
mkLetUntyped :: Context -> Term -> Term
mkLetUntyped defs = mkLet [(x,(Nothing,t)) | (x,t) <- defs]
isVariable :: Term -> Bool
isVariable (Vr _ ) = True
isVariable _ = False
@@ -277,22 +280,30 @@ mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
mkRecType :: (Int -> Label) -> [Type] -> Type
mkRecType = mkRecTypeN 0
typeType, typePType, typeStr, typeTok, typeStrs :: Term
typeType = srt "Type"
typePType = srt "PType"
typeStr = srt "Str"
typeTok = srt "Tok"
typeStrs = srt "Strs"
typeString, typeInt :: Term
typeInts :: Int -> Term
typeString = constPredefRes "String"
typeInt = constPredefRes "Int"
typeInts i = App (constPredefRes "Ints") (EInt i)
isTypeInts :: Term -> Bool
isTypeInts ty = case ty of
App c _ -> c == constPredefRes "Ints"
_ -> False
constPredefRes :: String -> Term
constPredefRes s = Q (IC "Predef") (zIdent s)
isPredefConstant :: Term -> Bool
isPredefConstant t = case t of
Q (IC "Predef") _ -> True
Q (IC "PredefAbs") _ -> True
@@ -314,9 +325,11 @@ mkDecl typ = (wildIdent, typ)
eqStrIdent :: Ident -> Ident -> Bool
eqStrIdent = (==)
tupleLabel, linLabel :: Int -> Label
tupleLabel i = LIdent $ "p" ++ show i
linLabel i = LIdent $ "s" ++ show i
theLinLabel :: Label
theLinLabel = LIdent "s"
tuple2record :: [Term] -> [Assign]
@@ -354,15 +367,15 @@ plusRecord t1 t2 =
(FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
_ -> Bad ("cannot add records" +++ prt t1 +++ "and" +++ prt t2)
-- default linearization type
-- | default linearization type
defLinType :: Type
defLinType = RecType [(LIdent "s", typeStr)]
-- refreshing variables
-- | refreshing variables
varX :: Int -> Ident
varX i = identV (i,"x")
-- | refreshing variables
mkFreshVar :: [Ident] -> Ident
mkFreshVar olds = varX (maxVarIndex olds + 1)
@@ -384,6 +397,8 @@ freshAsTerm s = Vr (varX (readIntArg s))
string2term :: String -> Term
string2term = ccK
ccK :: String -> Term
ccC :: Term -> Term -> Term
ccK = K
ccC = C
@@ -398,25 +413,37 @@ string2CnTrm = Cn . zIdent
symbolOfIdent :: Ident -> String
symbolOfIdent = prIdent
symid :: Ident -> String
symid = symbolOfIdent
vr :: Ident -> Term
cn :: Ident -> Term
srt :: String -> Term
meta :: MetaSymb -> Term
cnIC :: String -> Term
vr = Vr
cn = Cn
srt = Sort
meta = Meta
cnIC = cn . IC
justIdentOf :: Term -> Maybe Ident
justIdentOf (Vr x) = Just x
justIdentOf (Cn x) = Just x
justIdentOf _ = Nothing
isMeta :: Term -> Bool
isMeta (Meta _) = True
isMeta _ = False
mkMeta :: Int -> Term
mkMeta = Meta . MetaSymb
nextMeta :: MetaSymb -> MetaSymb
nextMeta = int2meta . succ . metaSymbInt
int2meta :: Int -> MetaSymb
int2meta = MetaSymb
metaSymbInt :: MetaSymb -> Int
@@ -503,6 +530,7 @@ allLinFields trm = case unComputed trm of
_ -> prtBad "fields can only be sought in a record not in" trm
-- | deprecated
isLinLabel :: Label -> Bool
isLinLabel l = case l of
LIdent ('s':cs) | all isDigit cs -> True
_ -> False
@@ -696,6 +724,7 @@ wordsInTerm trm = filter (not . null) $ case trm of
_ -> collectOp wo trm
where wo = wordsInTerm
noExist :: Term
noExist = FV []
defaultLinType :: Type

13
src/GF/Infra/Ident.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:14 $
-- > CVS $Date: 2005/02/24 11:46:34 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
@@ -47,6 +47,11 @@ prIdent i = case i of
IAV (s,b,j) -> s ++ "_" ++ show b ++ "_" ++ show j
IW -> "_"
identC :: String -> Ident
identV :: (Int, String) -> Ident
identA :: (String, Int) -> Ident
identAV:: (String, Int, Int) -> Ident
identW :: Ident
(identC, identV, identA, identAV, identW) =
(IC, IV, IA, IAV, IW)
@@ -54,18 +59,22 @@ prIdent i = case i of
-- ident s = IC s
-- | to mark argument variables
argIdent :: Int -> Ident -> Int -> Ident
argIdent 0 (IC c) i = identA (c,i)
argIdent b (IC c) i = identAV (c,b,i)
-- | used in lin defaults
strVar :: Ident
strVar = identA ("str",0)
-- | wild card
wildIdent :: Ident
wildIdent = identW
isWildIdent :: Ident -> Bool
isWildIdent = (== wildIdent)
newIdent :: Ident
newIdent = identC "#h"
mkIdent :: String -> Int -> Ident

15
src/GF/Infra/Modules.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Date: 2005/02/24 11:46:35 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.19 $
-- > CVS $Revision: 1.20 $
--
-- Datastructures and functions for modules, common to GF and GFC.
--
@@ -149,7 +149,10 @@ data OpenQualif =
| OQIncomplete
deriving (Eq,Show)
oSimple :: i -> OpenSpec i
oSimple = OSimple OQNormal
oQualif :: i -> i -> OpenSpec i
oQualif = OQualif OQNormal
data ModuleStatus =
@@ -162,6 +165,7 @@ openedModule o = case o of
OSimple _ m -> m
OQualif _ _ m -> m
allOpens :: Module i f a -> [OpenSpec i]
allOpens m = case mtype m of
MTTransfer a b -> a : b : opens m
_ -> opens m
@@ -245,6 +249,7 @@ data IdentM i = IdentM {
}
deriving (Eq,Show)
typeOfModule :: ModInfo i f a -> ModuleType i
typeOfModule mi = case mi of
ModMod m -> mtype m
@@ -295,11 +300,13 @@ lookupInfo mo i = lookupTree show i (jments mo)
allModMod :: (Show i,Eq i) => MGrammar i f a -> [(i,Module i f a)]
allModMod gr = [(i,m) | (i, ModMod m) <- modules gr]
isModAbs :: Module i f a -> Bool
isModAbs m = case mtype m of
MTAbstract -> True
---- MTUnion t -> isModAbs t
_ -> False
isModRes :: Module i f a -> Bool
isModRes m = case mtype m of
MTResource -> True
MTReuse _ -> True
@@ -308,16 +315,19 @@ isModRes m = case mtype m of
MTInstance _ -> True
_ -> False
isModCnc :: Module i f a -> Bool
isModCnc m = case mtype m of
MTConcrete _ -> True
---- MTUnion t -> isModCnc t
_ -> False
isModTrans :: Module i f a -> Bool
isModTrans m = case mtype m of
MTTransfer _ _ -> True
---- MTUnion t -> isModTrans t
_ -> False
sameMType :: Eq i => ModuleType i -> ModuleType i -> Bool
sameMType m n = case (m,n) of
(MTConcrete _, MTConcrete _) -> True
(MTInstance _, MTInstance _) -> True
@@ -329,6 +339,7 @@ sameMType m n = case (m,n) of
_ -> m == n
-- | don't generate code for interfaces and for incomplete modules
isCompilableModule :: ModInfo i f a -> Bool
isCompilableModule m = case m of
ModMod m -> case mtype m of
MTInterface -> False

158
src/GF/Infra/Option.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:15 $
-- > CVS $Date: 2005/02/24 11:46:35 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.19 $
-- > CVS $Revision: 1.20 $
--
-- Options and flags used in GF shell commands and files.
--
@@ -18,60 +18,12 @@
-- - The constructor 'Opts' us udes in "API", "Shell" and "ShellCommands"
-----------------------------------------------------------------------------
module Option (-- * all kinds of options, should be kept abstract
Option(..), Options(..), OptFun, OptFunId,
noOptions, iOpt, aOpt, iOpts, oArg, oElem, eqOpt,
getOptVal, getOptInt, optIntOrAll, optIntOrN, optIntOrOne,
changeOptVal, addOption, addOptions, concatOptions,
removeOption, removeOptions, options, unionOptions,
-- * parsing options, with prefix pre (e.g. \"-\")
getOptions, pOption, isOption,
-- * printing options, without prefix
prOpt, prOpts,
-- * a suggestion for option names
-- ** parsing
strictParse, forgiveParse, ignoreParse, literalParse,
rawParse, firstParse, dontParse,
-- ** grammar formats
showAbstr, showXML, showOld, showLatex, showFullForm,
showEBNF, showCF, showWords, showOpts,
isCompiled, isHaskell, noCompOpers, retainOpers, defaultGrOpts,
newParser, noCF, checkCirc, noCheckCirc, lexerByNeed,
-- ** linearization
allLin, firstLin, distinctLin, dontLin, showRecord, showStruct,
xmlLin, latexLin, tableLin, defaultLinOpts, useUTF8, showLang, withMetas,
-- ** other
beVerbose, showInfo, beSilent, emitCode, getHelp, doMake, doBatch,
notEmitCode, makeMulti, beShort, wholeGrammar, makeFudget, byLines, byWords,
analMorpho, doTrace, noCPU, doCompute, optimizeCanon, optimizeValues,
stripQualif, nostripQualif, showAll, fromSource,
-- ** mainly for stand-alone
useUnicode, optCompute, optCheck, optParaphrase, forJava,
-- ** for edit session
allLangs, absView,
-- ** options that take arguments
useTokenizer, useUntokenizer, useParser, withFun, firstCat, gStartCat,
useLanguage, useResource, speechLanguage, useFont,
grammarFormat, grammarPrinter, filterString, termCommand, transferFun,
forForms, menuDisplay, sizeDisplay, typeDisplay,
noDepTypes, extractGr, pathList, uniCoding,
useName, useAbsName, useCncName, useResName, useFile, useOptimizer,
markLin, markOptXML, markOptJava, markOptStruct, markOptFocus,
-- ** refinement order
nextRefine, firstRefine, lastRefine,
-- ** Boolean flags
flagYes, flagNo, caseYesNo,
-- ** integer flags
flagDepth, flagAlts, flagLength, flagNumber, flagRawtrees
) where
module Option where
import List (partition)
import Char (isDigit)
-- all kinds of options, to be kept abstract
-- * all kinds of options, to be kept abstract
newtype Option = Opt (String,[String]) deriving (Eq,Show,Read)
newtype Options = Opts [Option] deriving (Eq,Show,Read)
@@ -79,20 +31,20 @@ newtype Options = Opts [Option] deriving (Eq,Show,Read)
noOptions :: Options
noOptions = Opts []
-- | simple option -o
iOpt :: String -> Option
iOpt o = Opt (o,[])
-- ^ simple option -o
-- | option with argument -o=a
aOpt :: String -> String -> Option
aOpt o a = Opt (o,[a])
-- ^ option with argument -o=a
iOpts :: [Option] -> Options
iOpts = Opts
-- | value of option argument
oArg :: String -> String
oArg s = s
-- ^ value of option argument
oElem :: Option -> Options -> Bool
oElem o (Opts os) = elem o os
@@ -135,6 +87,7 @@ changeOptVal os f x =
addOption :: Option -> Options -> Options
addOption o (Opts os) = iOpts (o:os)
addOptions :: Options -> Options -> Options
addOptions (Opts os) os0 = foldr addOption os0 os
concatOptions :: [Options] -> Options
@@ -143,14 +96,16 @@ concatOptions = foldr addOptions noOptions
removeOption :: Option -> Options -> Options
removeOption o (Opts os) = iOpts (filter (/=o) os)
removeOptions :: Options -> Options -> Options
removeOptions (Opts os) os0 = foldr removeOption os0 os
options :: [Option] -> Options
options = foldr addOption noOptions
unionOptions :: Options -> Options -> Options
unionOptions (Opts os) (Opts os') = Opts (os ++ os')
-- parsing options, with prefix pre (e.g. "-")
-- * parsing options, with prefix pre (e.g. \"-\")
getOptions :: String -> [String] -> (Options, [String])
getOptions pre inp = let
@@ -166,24 +121,39 @@ pOption pre s = case span (/= '=') (drop (length pre) s) of
isOption :: String -> String -> Bool
isOption pre = (==pre) . take (length pre)
-- printing options, without prefix
-- * printing options, without prefix
prOpt :: Option -> String
prOpt (Opt (s,[])) = s
prOpt (Opt (s,xs)) = s ++ "=" ++ concat xs
prOpts :: Options -> String
prOpts (Opts os) = unwords $ map prOpt os
-- a suggestion for option names
-- * a suggestion for option names
-- ** parsing
strictParse, forgiveParse, ignoreParse, literalParse, rawParse, firstParse :: Option
-- | parse as term instead of string
dontParse :: Option
-- parsing
strictParse = iOpt "strict"
forgiveParse = iOpt "n"
ignoreParse = iOpt "ign"
literalParse = iOpt "lit"
rawParse = iOpt "raw"
firstParse = iOpt "1"
dontParse = iOpt "read" -- parse as term instead of string
dontParse = iOpt "read"
-- ** grammar formats
showAbstr, showXML, showOld, showLatex, showFullForm,
showEBNF, showCF, showWords, showOpts,
isCompiled, isHaskell, noCompOpers, retainOpers,
newParser, noCF, checkCirc, noCheckCirc, lexerByNeed :: Option
defaultGrOpts :: [Option]
-- grammar formats
showAbstr = iOpt "abs"
showXML = iOpt "xml"
showOld = iOpt "old"
@@ -205,7 +175,13 @@ checkCirc = iOpt "nocirc"
noCheckCirc = iOpt "nocheckcirc"
lexerByNeed = iOpt "cflexer"
-- linearization
-- ** linearization
allLin, firstLin, distinctLin, dontLin,
showRecord, showStruct, xmlLin, latexLin,
tableLin, useUTF8, showLang, withMetas :: Option
defaultLinOpts :: [Option]
allLin = iOpt "all"
firstLin = iOpt "one"
distinctLin = iOpt "nub"
@@ -220,7 +196,14 @@ useUTF8 = iOpt "utf8"
showLang = iOpt "lang"
withMetas = iOpt "metas"
-- other
-- ** other
beVerbose, showInfo, beSilent, emitCode, getHelp,
doMake, doBatch, notEmitCode, makeMulti, beShort,
wholeGrammar, makeFudget, byLines, byWords, analMorpho,
doTrace, noCPU, doCompute, optimizeCanon, optimizeValues,
stripQualif, nostripQualif, showAll, fromSource :: Option
beVerbose = iOpt "v"
showInfo = iOpt "i"
beSilent = iOpt "s"
@@ -246,24 +229,41 @@ nostripQualif = iOpt "nostrip"
showAll = iOpt "all"
fromSource = iOpt "src"
-- mainly for stand-alone
-- ** mainly for stand-alone
useUnicode, optCompute, optCheck, optParaphrase, forJava :: Option
useUnicode = iOpt "unicode"
optCompute = iOpt "compute"
optCheck = iOpt "typecheck"
optParaphrase = iOpt "paraphrase"
forJava = iOpt "java"
-- for edit session
-- ** for edit session
allLangs, absView :: Option
allLangs = iOpt "All"
absView = iOpt "Abs"
-- options that take arguments
-- ** options that take arguments
useTokenizer, useUntokenizer, useParser, withFun,
useLanguage, useResource, speechLanguage, useFont,
grammarFormat, grammarPrinter, filterString, termCommand,
transferFun, forForms, menuDisplay, sizeDisplay, typeDisplay,
noDepTypes, extractGr, pathList, uniCoding :: String -> Option
-- | used on command line
firstCat :: String -> Option
-- | used in grammar, to avoid clash w res word
gStartCat :: String -> Option
useTokenizer = aOpt "lexer"
useUntokenizer = aOpt "unlexer"
useParser = aOpt "parser"
withFun = aOpt "fun"
firstCat = aOpt "cat" -- used on command line
gStartCat = aOpt "startcat" -- used in grammar, to avoid clash w res word
firstCat = aOpt "cat"
gStartCat = aOpt "startcat"
useLanguage = aOpt "lang"
useResource = aOpt "res"
speechLanguage = aOpt "language"
@@ -282,6 +282,9 @@ extractGr = aOpt "extract"
pathList = aOpt "path"
uniCoding = aOpt "coding"
useName, useAbsName, useCncName, useResName,
useFile, useOptimizer :: String -> Option
useName = aOpt "name"
useAbsName = aOpt "abs"
useCncName = aOpt "cnc"
@@ -289,6 +292,9 @@ useResName = aOpt "res"
useFile = aOpt "file"
useOptimizer = aOpt "optimize"
markLin :: String -> Option
markOptXML, markOptJava, markOptStruct, markOptFocus :: String
markLin = aOpt "mark"
markOptXML = oArg "xml"
markOptJava = oArg "java"
@@ -296,16 +302,26 @@ markOptStruct = oArg "struct"
markOptFocus = oArg "focus"
-- refinement order
-- ** refinement order
nextRefine :: String -> Option
firstRefine, lastRefine :: String
nextRefine = aOpt "nextrefine"
firstRefine = oArg "first"
lastRefine = oArg "last"
-- Boolean flags
-- ** Boolean flags
flagYes, flagNo :: String
flagYes = oArg "yes"
flagNo = oArg "no"
-- integer flags
-- ** integer flags
flagDepth, flagAlts, flagLength, flagNumber, flagRawtrees :: String -> Option
flagDepth = aOpt "depth"
flagAlts = aOpt "alts"
flagLength = aOpt "length"

56
src/GF/Infra/UseIO.hs
View File

@@ -5,56 +5,14 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:16 $
-- > CVS $Date: 2005/02/24 11:46:36 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.8 $
-- > CVS $Revision: 1.9 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module UseIO (prOptCPU,
putCPU,
putPoint,
putPoint',
readFileIf,
FileName,
InitPath,
FullPath,
getFilePath,
readFileIfPath,
doesFileExistPath,
extendPathEnv,
pFilePaths,
prefixPathName,
justInitPath,
nameAndSuffix,
unsuffixFile, fileBody,
fileSuffix,
justFileName,
suffixFile,
justModuleName,
getLineWell,
putStrFlush,
putStrLnFlush,
-- * a generic quiz session
QuestionsAndAnswers,
teachDialogue,
-- * IO monad with error; adapted from state monad
IOE(..),
appIOE,
ioe,
ioeIO,
ioeErr,
ioeBad,
useIOE,
foldIOE,
putStrLnE,
putStrE,
putPointE,
putPointEVerb,
readFileIOE,
readFileLibraryIOE
) where
module UseIO where
import Operations
import Arch (prCPU)
@@ -67,11 +25,13 @@ import Monad
putShow' :: Show a => (c -> a) -> c -> IO ()
putShow' f = putStrLn . show . length . show . f
putIfVerb :: Options -> String -> IO ()
putIfVerb opts msg =
if oElem beVerbose opts
then putStrLn msg
else return ()
putIfVerbW :: Options -> String -> IO ()
putIfVerbW opts msg =
if oElem beVerbose opts
then putStr (' ' : msg)
@@ -88,8 +48,10 @@ errOptIO os e m = case m of
putIfVerb os k
return e
prOptCPU :: Options -> Integer -> IO Integer
prOptCPU opts = if (oElem noCPU opts) then (const (return 0)) else prCPU
putCPU :: IO ()
putCPU = do
prCPU 0
return ()
@@ -194,7 +156,7 @@ putStrFlush s = putStr s >> hFlush stdout
putStrLnFlush :: String -> IO ()
putStrLnFlush s = putStrLn s >> hFlush stdout
-- a generic quiz session
-- * a generic quiz session
type QuestionsAndAnswers = [(String, String -> (Integer,String))]
@@ -222,7 +184,7 @@ teachDialogue qas welc = do
"You can interrupt the quiz by entering a line consisting of a dot ('.').\n"
-- IO monad with error; adapted from state monad
-- * IO monad with error; adapted from state monad
newtype IOE a = IOE (IO (Err a))

39
src/GF/Shell.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Shell
-- 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.32 $
-- > CVS $Revision: 1.33 $
--
-- GF shell command interpreter.
-----------------------------------------------------------------------------
@@ -67,20 +67,32 @@ import VisualizeGrammar (visualizeSourceGrammar)
type CommandLine = (CommandOpt, CommandArg, [CommandOpt])
type SrcTerm = G.Term -- term as returned by the command parser
-- | term as returned by the command parser
type SrcTerm = G.Term
type HState = (ShellState,([String],Integer)) -- history & CPU
-- | history & CPU
type HState = (ShellState,([String],Integer))
type ShellIO = (HState, CommandArg) -> IO (HState, CommandArg)
initHState :: ShellState -> HState
initHState st = (st,([],0))
cpuHState :: HState -> Integer
cpuHState (_,(_,i)) = i
optsHState :: HState -> Options
optsHState (st,_) = globalOptions st
putHStateCPU :: Integer -> HState -> HState
putHStateCPU cpu (st,(h,_)) = (st,(h,cpu))
updateHistory :: String -> HState -> HState
updateHistory s (st,(h,cpu)) = (st,(s:h,cpu))
earlierCommandH (_,(h,_)) = ((h ++ repeat "") !!) -- empty command if index over
-- | empty command if index over
earlierCommandH :: HState -> Int -> String
earlierCommandH (_,(h,_)) = ((h ++ repeat "") !!)
execLinesH :: String -> [CommandLine] -> HState -> IO HState
execLinesH s cs hst@(st, (h, _)) = do
@@ -91,13 +103,13 @@ execLinesH s cs hst@(st, (h, _)) = do
ifImpure :: [CommandLine] -> Maybe (ImpureCommand,Options)
ifImpure cls = foldr (const . Just) Nothing [(c,os) | ((CImpure c,os),_,_) <- cls]
-- the main function: execution of commands. put :: Bool forces immediate output
-- | the main function: execution of commands. 'put :: Bool' forces immediate output
--
-- command line with consecutive (;) commands: no value transmitted
execLines :: Bool -> [CommandLine] -> HState -> IO ([String],HState)
execLines put cs st = foldM (flip (execLine put)) ([],st) cs
-- command line with piped (|) commands: no value returned
-- | command line with piped (|) commands: no value returned
execLine :: Bool -> CommandLine -> ([String],HState) -> IO ([String],HState)
execLine put (c@(co, os), arg, cs) (outps,st) = do
(st',val) <- execC c (st, arg)
@@ -110,7 +122,7 @@ execLine put (c@(co, os), arg, cs) (outps,st) = do
execs [] arg st = return st
execs (c:cs) arg st = execLine put (c, arg, cs) st
-- individual commands possibly piped: value returned; this is not a state monad
-- | individual commands possibly piped: value returned; this is not a state monad
execC :: CommandOpt -> ShellIO
execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
@@ -315,12 +327,11 @@ justOutputArg opts f sa@(st,a) = f (utf (prCommandArg a)) >> return (st, AUnit)
justOutput :: Options -> IO () -> ShellIO
justOutput opts = justOutputArg opts . const
-- type system for command arguments; instead of plain strings...
-- | type system for command arguments; instead of plain strings...
data CommandArg =
AError String
| ATrms [Tree]
| ASTrm String -- to receive from parser
| ASTrm String -- ^ to receive from parser
| AStrs [Str]
| AString String
| AUnit

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

12
src/GF/Source/GrammarToSource.hs
View File

@@ -5,14 +5,19 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:20 $
-- > CVS $Date: 2005/02/24 11:46:38 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.16 $
-- > CVS $Revision: 1.17 $
--
-- From internal source syntax to BNFC-generated (used for printing).
-----------------------------------------------------------------------------
module GrammarToSource where
module GrammarToSource ( trGrammar,
trModule,
trAnyDef,
trLabel,
trt, tri, trp
) where
import Operations
import Grammar
@@ -205,6 +210,7 @@ tri i = case prIdent i of
trb i = if isWildIdent i then P.BWild else P.BIdent (tri i)
trLabel :: Label -> P.Label
trLabel i = case i of
LIdent s -> P.LIdent $ identC s
LVar i -> P.LVar $ toInteger i

23
src/GF/Source/SourceToGrammar.hs
View File

@@ -5,14 +5,20 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:21 $
-- > CVS $Date: 2005/02/24 11:46:38 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.20 $
-- > CVS $Revision: 1.21 $
--
-- based on the skeleton Haskell module generated by the BNF converter
-----------------------------------------------------------------------------
module SourceToGrammar where
module SourceToGrammar ( transGrammar,
transInclude,
transModDef,
transOldGrammar,
transExp,
newReservedWords
) where
import qualified Grammar as G
import qualified PrGrammar as GP
@@ -321,7 +327,7 @@ getDefsGen d = case d of
e' <- transExp e
return [(id',(nope, yes (G.Eqs [(ps',e')])))]
-- sometimes you need this special case, e.g. in linearization rules
-- | sometimes you need this special case, e.g. in linearization rules
getDefs :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))]
getDefs d = case d of
DPatt id patts e -> do
@@ -331,7 +337,7 @@ getDefs d = case d of
return [(id',(nope, yes (M.mkAbs xs e')))]
_ -> getDefsGen d
-- accepts a pattern that is either a variable or a wild card
-- | accepts a pattern that is either a variable or a wild card
tryMakeVar :: Patt -> Err Ident
tryMakeVar p = do
p' <- transPatt p
@@ -434,6 +440,7 @@ erecord2term ds = do
_ -> Bad $ "illegal record field" +++ GP.prt (fst f)
locdef2fields :: LocDef -> Err [(Ident, (Maybe G.Type, Maybe G.Type))]
locdef2fields d = case d of
LDDecl ids t -> do
labs <- mapM transIdent ids
@@ -522,9 +529,8 @@ transDDecl x = case x of
DDDec binds exp -> transDecl $ DDec binds exp
DDExp exp -> transDecl $ DExp exp
-- to deal with the old format, sort judgements in three modules, forming
-- | to deal with the old format, sort judgements in three modules, forming
-- their names from a given string, e.g. file name or overriding user-given string
transOldGrammar :: Options -> FilePath -> OldGrammar -> Err G.SourceGrammar
transOldGrammar opts name0 x = case x of
OldGr includes topdefs -> do --- includes must be collected separately
@@ -594,7 +600,8 @@ transInclude x = case x of
--- unsafe hack ; cf. GetGrammar.oldLexer
newReservedWords =
newReservedWords :: [String]
newReservedWords =
words $ "abstract concrete interface incomplete " ++
"instance out open resource reuse transfer union with where"

9
src/GF/Speech/SRG.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/22 13:35:19 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.5 $
-- > CVS $Date: 2005/02/24 11:46:38 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
--
-- Representation of, conversion to, and utilities for
-- printing of a general Speech Recognition Grammar.
@@ -41,8 +41,9 @@ data SRG = SRG { grammarName :: String -- ^ grammar name
data SRGRule = SRGRule String String [SRGAlt] -- ^ SRG category name, original category name
-- and productions
type SRGAlt = [Symbol String Token]
-- | SRG category name and original name
type CatName = (String,String)
-- ^ SRG category name and original name
type CatNames = FiniteMap String String

6
src/GF/System/Arch.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:10 $
-- > CVS $Date: 2005/02/24 11:46:34 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
-- > CVS $Revision: 1.6 $
--
-- architecture\/compiler dependent definitions for unix\/hbc
-----------------------------------------------------------------------------
@@ -35,11 +35,13 @@ myStdGen int0 = do
let int = int0 + ctSec cal + fromInteger (div (ctPicosec cal) 10000000)
return $ mkStdGen int
prCPU :: Integer -> IO Integer
prCPU cpu = do
cpu' <- getCPUTime
putStrLn (show ((cpu' - cpu) `div` 1000000000) ++ " msec")
return cpu'
welcomeArch :: String
welcomeArch = "This is the system compiled with ghc."
fetchCommand :: String -> IO (String)

67
src/GF/UseGrammar/Custom.hs
View File

@@ -1,15 +1,28 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Custom
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:21 $
-- > CVS $Date: 2005/02/24 11:46:38 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.41 $
-- > CVS $Revision: 1.42 $
--
-- A database for customizable GF shell commands.
--
-- databases for customizable commands. AR 21\/11\/2001.
-- for: grammar parsers, grammar printers, term commands, string commands.
-- idea: items added here are usable throughout GF; nothing else need be edited.
-- they are often usable through the API: hence API cannot be imported here!
--
-- Major redesign 3\/4\/2002: the first entry in each database is DEFAULT.
-- If no other value is given, the default is selected.
-- Because of this, two invariants have to be preserved:
--
-- - no databases may be empty
--
-- - additions are made to the end of the database
-----------------------------------------------------------------------------
module Custom where
@@ -104,59 +117,61 @@ import ExtraDiacritics (mkExtraDiacritics)
-- Major redesign 3/4/2002: the first entry in each database is DEFAULT.
-- If no other value is given, the default is selected.
-- Because of this, two invariants have to be preserved:
-- ** no databases may be empty
-- ** additions are made to the end of the database
-- - no databases may be empty
-- - additions are made to the end of the database
-- these are the databases; the comment gives the name of the flag
-- * these are the databases; the comment gives the name of the flag
-- grammarFormat, "-format=x" or file suffix
-- | grammarFormat, \"-format=x\" or file suffix
customGrammarParser :: CustomData (FilePath -> IOE C.CanonGrammar)
-- grammarPrinter, "-printer=x"
-- | grammarPrinter, \"-printer=x\"
customGrammarPrinter :: CustomData (StateGrammar -> String)
-- multiGrammarPrinter, "-printer=x"
-- | multiGrammarPrinter, \"-printer=x\"
customMultiGrammarPrinter :: CustomData (CanonGrammar -> String)
-- syntaxPrinter, "-printer=x"
-- | syntaxPrinter, \"-printer=x\"
customSyntaxPrinter :: CustomData (GF.Grammar -> String)
-- termPrinter, "-printer=x"
-- | termPrinter, \"-printer=x\"
customTermPrinter :: CustomData (StateGrammar -> Tree -> String)
-- termCommand, "-transform=x"
-- | termCommand, \"-transform=x\"
customTermCommand :: CustomData (StateGrammar -> Tree -> [Tree])
-- editCommand, "-edit=x"
-- | editCommand, \"-edit=x\"
customEditCommand :: CustomData (StateGrammar -> Action)
-- filterString, "-filter=x"
-- | filterString, \"-filter=x\"
customStringCommand :: CustomData (StateGrammar -> String -> String)
-- useParser, "-parser=x"
-- | useParser, \"-parser=x\"
customParser :: CustomData (StateGrammar -> CFCat -> CFParser)
-- useTokenizer, "-lexer=x"
-- | useTokenizer, \"-lexer=x\"
customTokenizer :: CustomData (StateGrammar -> String -> [CFTok])
-- useUntokenizer, "-unlexer=x" --- should be from token list to string
-- | useUntokenizer, \"-unlexer=x\" --- should be from token list to string
customUntokenizer :: CustomData (StateGrammar -> String -> String)
-- uniCoding, "-coding=x"
-- | uniCoding, \"-coding=x\"
--
-- contains conversions from different codings to the internal
-- unicode coding
customUniCoding :: CustomData (String -> String)
-- this is the way of selecting an item
-- | this is the way of selecting an item
customOrDefault :: Options -> OptFun -> CustomData a -> a
customOrDefault opts optfun db = maybe (defaultCustomVal db) id $
customAsOptVal opts optfun db
-- to produce menus of custom operations
-- | to produce menus of custom operations
customInfo :: CustomData a -> (String, [String])
customInfo c = (titleCustomData c, map (ciStr . fst) (dbCustomData c))
-------------------------------
-- * types and stuff
type CommandId = String
@@ -170,8 +185,14 @@ ciOpt :: CommandId -> Option
ciOpt = iOpt
newtype CustomData a = CustomData (String, [(CommandId,a)])
customData :: String -> [(CommandId, a)] -> CustomData a
customData title db = CustomData (title,db)
dbCustomData :: CustomData a -> [(CommandId, a)]
dbCustomData (CustomData (_,db)) = db
titleCustomData :: CustomData a -> String
titleCustomData (CustomData (t,_)) = t
lookupCustom :: CustomData a -> CommandId -> Maybe a
@@ -182,13 +203,13 @@ customAsOptVal opts optfun db = do
arg <- getOptVal opts optfun
lookupCustom db (strCI arg)
-- take the first entry from the database
-- | take the first entry from the database
defaultCustomVal :: CustomData a -> a
defaultCustomVal (CustomData (s,db)) =
ifNull (error ("empty database:" +++ s)) (snd . head) db
-------------------------------------------------------------------------
-- and here's the customizable part:
-- * and here's the customizable part:
-- grammar parsers: the ID is also used as file name suffix
customGrammarParser =

50
src/GF/UseGrammar/Editing.hs
View File

@@ -1,15 +1,16 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Editing
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:38 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.10 $
-- > CVS $Revision: 1.11 $
--
-- (Description of the module)
-- generic tree editing, with some grammar notions assumed. AR 18\/8\/2001.
-- 19\/6\/2003 for GFC
-----------------------------------------------------------------------------
module Editing where
@@ -31,7 +32,7 @@ type CGrammar = GFC.CanonGrammar
type State = Loc TrNode
-- the "empty" state
-- | the "empty" state
initState :: State
initState = tree2loc uTree
@@ -60,25 +61,26 @@ actFun s = case actAtom s of
AtC f -> return f
t -> prtBad "active atom: expected function, found" t
actExp :: State -> Exp
actExp = tree2exp . actTree
-- current local bindings
-- | current local bindings
actBinds :: State -> Binds
actBinds = bindsNode . nodeTree . actTree
-- constraints in current subtree
-- | constraints in current subtree
actConstrs :: State -> Constraints
actConstrs = allConstrsTree . actTree
-- constraints in the whole tree
-- | constraints in the whole tree
allConstrs :: State -> Constraints
allConstrs = allConstrsTree . loc2tree
-- metas in current subtree
-- | metas in current subtree
actMetas :: State -> [Meta]
actMetas = metasTree . actTree
-- metas in the whole tree
-- | metas in the whole tree
allMetas :: State -> [Meta]
allMetas = metasTree . loc2tree
@@ -100,32 +102,37 @@ allPrevVars = map fst . allPrevBinds
allVars :: State -> [Var]
allVars = map fst . allBinds
vGenIndex :: State -> Int
vGenIndex = length . allBinds
actIsMeta :: State -> Bool
actIsMeta = atomIsMeta . actAtom
actMeta :: State -> Err Meta
actMeta = getMetaAtom . actAtom
-- meta substs are not only on the actual path...
-- | meta substs are not only on the actual path...
entireMetaSubst :: State -> MetaSubst
entireMetaSubst = concatMap metaSubstsNode . scanTree . loc2tree
isCompleteTree :: Tree -> Bool
isCompleteTree = null . filter atomIsMeta . map atomNode . scanTree
isCompleteState :: State -> Bool
isCompleteState = isCompleteTree . loc2tree
initStateCat :: Context -> Cat -> Err State
initStateCat cont cat = do
return $ tree2loc (Tr (mkNode [] mAtom (cat2val cont cat) ([],[]), []))
-- this function only concerns the body of an expression...
-- | this function only concerns the body of an expression...
annotateInState :: CGrammar -> Exp -> State -> Err Tree
annotateInState gr exp state = do
let binds = allBinds state
val = actVal state
annotateIn gr binds exp (Just val)
-- ...whereas this one works with lambda abstractions
-- | ...whereas this one works with lambda abstractions
annotateExpInState :: CGrammar -> Exp -> State -> Err Tree
annotateExpInState gr exp state = do
let cont = allPrevBinds state
@@ -139,7 +146,7 @@ treeByExp trans gr exp0 state = do
exp <- trans exp0
annotateExpInState gr exp state
-- actions
-- * actions
type Action = State -> Err State
@@ -172,6 +179,7 @@ goPrevNewMeta s = goBack s >>= goPrevMeta
goNextMetaIfCan = actionIfPossible goNextMeta
actionIfPossible :: Action -> Action
actionIfPossible a s = return $ errVal s (a s)
goFirstMeta, goLastMeta :: Action
@@ -276,18 +284,16 @@ refineWithAtom der gr at state = do
exp <- ref2exp oldvars typ at
refineWithExpTC der gr exp state
-- in this command, we know that the result is well-typed, since computation
-- | in this command, we know that the result is well-typed, since computation
-- rules have been type checked and the result is equal
computeSubTree :: CGrammar -> Action
computeSubTree gr state = do
let exp = tree2exp (actTree state)
tree <- treeByExp (compute gr) gr exp state
replaceSubTree tree state
-- but here we don't, since the transfer flag isn't type checked,
-- | but here we don't, since the transfer flag isn't type checked,
-- and computing the transfer function is not checked to preserve equality
transferSubTree :: Maybe Fun -> CGrammar -> Action
transferSubTree Nothing _ s = return s
transferSubTree (Just fun) gr state = do
@@ -348,11 +354,11 @@ peelFunHead gr (f@(m,c),i) state = do
state' <- replaceSubTree tree state
reCheckState gr state' --- must be unfortunately done. 20/11/2001
-- an expensive operation
-- | an expensive operation
reCheckState :: CGrammar -> State -> Err State
reCheckState gr st = annotate gr (tree2exp (loc2tree st)) >>= return . tree2loc
-- extract metasubstitutions from constraints and solve them
-- | extract metasubstitutions from constraints and solve them
solveAll :: CGrammar -> State -> Err State
solveAll gr st = solve st >>= solve where
solve st0 = do ---- why need twice?
@@ -362,7 +368,7 @@ solveAll gr st = solve st >>= solve where
metaSubstRefinements gr ms $
mapLoc (reduceConstraintsNode gr . performMetaSubstNode ms) st
-- active refinements
-- * active refinements
refinementsState :: CGrammar -> State -> [(Term,(Val,Bool))]
refinementsState gr state =

25
src/GF/UseGrammar/Generate.hs
View File

@@ -1,24 +1,30 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Generate
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:38 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.7 $
-- > CVS $Revision: 1.8 $
--
-- (Description of the module)
-- Generate all trees of given category and depth. AR 30\/4\/2004
--
-- (c) Aarne Ranta 2004 under GNU GPL
--
-- Purpose: to generate corpora. We use simple types and don't
-- guarantee the correctness of bindings\/dependences.
-----------------------------------------------------------------------------
module Generate where
module Generate (generateTrees) where
import GFC
import LookAbs
import PrGrammar
import Macros
import Values
import Grammar (Cat)
import Operations
import Zipper
@@ -32,11 +38,8 @@ import List
-- guarantee the correctness of bindings/dependences.
-- the main function takes an abstract syntax and returns a list of trees
--- if type were shown more modules should be imported
-- generateTrees ::
-- GFCGrammar -> Bool -> Cat -> Int -> Maybe Int -> Maybe Tree -> [Exp]
-- | the main function takes an abstract syntax and returns a list of trees
generateTrees :: GFCGrammar -> Bool -> Cat -> Int -> Maybe Int -> Maybe Tree -> [Exp]
generateTrees gr ifm cat n mn mt = map str2tr $ generate gr' ifm cat' n mn mt'
where
gr' = gr2sgr gr

12
src/GF/UseGrammar/GetTree.hs
View File

@@ -1,15 +1,17 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : GetTree
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:38 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-- how to form linearizable trees from strings and from terms of different levels
--
-- 'String' --> raw 'Term' --> annot, qualif 'Term' --> 'Tree'
-----------------------------------------------------------------------------
module GetTree where

25
src/GF/UseGrammar/Information.hs
View File

@@ -1,18 +1,20 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Information
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:38 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
-- > CVS $Revision: 1.4 $
--
-- (Description of the module)
-- information on module, category, function, operation, parameter,...
-- AR 16\/9\/2003.
-- uses source grammar
-----------------------------------------------------------------------------
module Information where
module Information (showInformation) where
import Grammar
import Ident
@@ -32,20 +34,18 @@ import UseIO
-- information on module, category, function, operation, parameter,... AR 16/9/2003
-- uses source grammar
-- the top level function
-- | the top level function
showInformation :: Options -> ShellState -> Ident -> IOE ()
showInformation opts st c = do
is <- ioeErr $ getInformation opts st c
mapM_ (putStrLnE . prInformation opts c) is
-- the data type of different kinds of information
-- | the data type of different kinds of information
data Information =
IModAbs SourceAbs
| IModRes SourceRes
| IModCnc SourceCnc
| IModule SourceAbs ---- to be deprecated
| IModule SourceAbs -- ^ to be deprecated
| ICatAbs Ident Context [Ident]
| ICatCnc Ident Type [CFRule] Term
| IFunAbs Ident Type (Maybe Term)
@@ -97,8 +97,7 @@ prInformation opts c i = unlines $ prt c : case i of
"type" +++ show ty
]
-- also finds out if an identifier is defined in many places
-- | also finds out if an identifier is defined in many places
getInformation :: Options -> ShellState -> Ident -> Err [Information]
getInformation opts st c = allChecks $ [
do

56
src/GF/UseGrammar/Linear.hs
View File

@@ -1,15 +1,15 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Linear
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:38 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.13 $
-- > CVS $Revision: 1.14 $
--
-- (Description of the module)
-- Linearization for canonical GF. AR 7\/6\/2003
-----------------------------------------------------------------------------
module Linear where
@@ -37,14 +37,15 @@ import List (intersperse)
-- Linearization for canonical GF. AR 7/6/2003
-- The worker function: linearize a Tree, return
-- | The worker function: linearize a Tree, return
-- a record. Possibly mark subtrees.
--
-- NB. Constants in trees are annotated by the name of the abstract module.
-- A concrete module name must be given to find (and choose) linearization rules.
-- If no marking is wanted, noMark :: Marker.
-- For xml marking, use markXML :: Marker
--
-- - If no marking is wanted, 'noMark' :: 'Marker'.
--
-- - For xml marking, use 'markXML' :: 'Marker'
linearizeToRecord :: CanonGrammar -> Marker -> Ident -> A.Tree -> Err Term
linearizeToRecord gr mk m = lin [] where
@@ -85,14 +86,13 @@ linearizeToRecord gr mk m = lin [] where
_ -> lookCat c >>= comp [tK (prt_ t)]
-- thus the special case:
-- | thus the special case:
linearizeNoMark :: CanonGrammar -> Ident -> A.Tree -> Err Term
linearizeNoMark gr = linearizeToRecord gr noMark
-- expand tables in linearized term to full, normal-order tables
-- | expand tables in linearized term to full, normal-order tables
--
-- NB expand from inside-out so that values are not looked up in copies of branches
expandLinTables :: CanonGrammar -> Term -> Err Term
expandLinTables gr t = case t of
R rs -> liftM (R . map (uncurry Ass)) $ mapPairsM exp [(l,r) | Ass l r <- rs]
@@ -110,38 +110,36 @@ expandLinTables gr t = case t of
exp = expandLinTables gr
comp = ccompute gr []
-- from records, one can get to records of tables of strings
-- | from records, one can get to records of tables of strings
rec2strTables :: Term -> Err [[(Label,[([Patt],[Str])])]]
rec2strTables r = do
vs <- allLinValues r
mapM (mapPairsM (mapPairsM strsFromTerm)) vs
-- from these tables, one may want to extract the ones for the "s" label
-- | from these tables, one may want to extract the ones for the "s" label
strTables2sTables :: [[(Label,[([Patt],[Str])])]] -> [[([Patt],[Str])]]
strTables2sTables ts = [t | r <- ts, (l,t) <- r, l == linLab0]
linLab0 :: Label
linLab0 = L (identC "s")
-- to get lists of token lists is easy
-- | to get lists of token lists is easy
sTables2strs :: [[([Patt],[Str])]] -> [[Str]]
sTables2strs = map snd . concat
-- from this, to get a list of strings
-- | from this, to get a list of strings
strs2strings :: [[Str]] -> [String]
strs2strings = map unlex
-- this is just unwords; use an unlexer from Text to postprocess
-- | this is just unwords; use an unlexer from Text to postprocess
unlex :: [Str] -> String
unlex = concat . map sstr . take 1 ----
-- finally, a top-level function to get a string from an expression
-- | finally, a top-level function to get a string from an expression
linTree2string :: Marker -> CanonGrammar -> Ident -> A.Tree -> String
linTree2string mk gr m e = head $ linTree2strings mk gr m e -- never empty
-- you can also get many strings
-- | you can also get many strings
linTree2strings :: Marker -> CanonGrammar -> Ident -> A.Tree -> [String]
linTree2strings mk gr m e = err return id $ do
t <- linearizeToRecord gr mk m e
@@ -150,8 +148,7 @@ linTree2strings mk gr m e = err return id $ do
let ss = strs2strings $ sTables2strs $ strTables2sTables ts
ifNull (prtBad "empty linearization of" e) return ss -- thus never empty
-- argument is a Tree, value is a list of strs; needed in Parsing
-- | argument is a Tree, value is a list of strs; needed in Parsing
allLinsOfTree :: CanonGrammar -> Ident -> A.Tree -> [Str]
allLinsOfTree gr a e = err (singleton . str) id $ do
e' <- return e ---- annotateExp gr e
@@ -160,11 +157,11 @@ allLinsOfTree gr a e = err (singleton . str) id $ do
ts <- rec2strTables r'
return $ concat $ sTables2strs $ strTables2sTables ts
-- the value is a list of structures arranged as records of tables of terms
-- | the value is a list of structures arranged as records of tables of terms
allLinsAsRec :: CanonGrammar -> Ident -> A.Tree -> Err [[(Label,[([Patt],Term)])]]
allLinsAsRec gr c t = linearizeNoMark gr c t >>= expandLinTables gr >>= allLinValues
-- the value is a list of structures arranged as records of tables of strings
-- | 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 gr c t = do
@@ -207,15 +204,14 @@ linearizeToStrss gr mk e = do
return $ map strsFromTerm $ allInTable t
-}
-- the value is a list of strings, not forgetting their arguments
-- | the value is a list of strings, not forgetting their arguments
allLinsOfFun :: CanonGrammar -> CIdent -> Err [[(Label,[([Patt],Term)])]]
allLinsOfFun gr f = do
t <- lookupLin gr f
allLinValues t
-- returns printname if one exists; otherwise linearizes with metas
-- | returns printname if one exists; otherwise linearizes with metas
printOrLinearize :: CanonGrammar -> Ident -> A.Fun -> String
printOrLinearize gr c f@(m, d) = errVal (prt fq) $
case lookupPrintname gr (CIQ c d) of

21
src/GF/UseGrammar/MoreCustom.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : MoreCustom
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:39 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
@@ -17,6 +17,19 @@ module MoreCustom where
-- All these lists are supposed to be empty!
-- Items should be added to ../Custom.hs instead.
moreCustomGrammarParser,
moreCustomGrammarPrinter,
moreCustomMultiGrammarPrinter,
moreCustomSyntaxPrinter,
moreCustomTermPrinter,
moreCustomTermCommand,
moreCustomEditCommand,
moreCustomStringCommand,
moreCustomParser,
moreCustomTokenizer,
moreCustomUntokenizer,
moreCustomUniCoding :: [a]
moreCustomGrammarParser = []
moreCustomGrammarPrinter = []
moreCustomMultiGrammarPrinter = []

25
src/GF/UseGrammar/Morphology.hs
View File

@@ -1,15 +1,20 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Morphology
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:39 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
-- > CVS $Revision: 1.7 $
--
-- Morphological analyser constructed from a GF grammar.
--
-- we first found the binary search tree sorted by word forms more efficient
-- than a trie, at least for grammars with 7000 word forms
-- (18\/11\/2003) but this may change since we have to use a trie
-- for decompositions and also want to use it in the parser
-----------------------------------------------------------------------------
module Morphology where
@@ -35,11 +40,12 @@ import Trie2
-- we first found the binary search tree sorted by word forms more efficient
-- than a trie, at least for grammars with 7000 word forms
-- (18/11/2003) but this may change since we have to use a trie
-- (18\/11\/2003) but this may change since we have to use a trie
-- for decompositions and also want to use it in the parser
type Morpho = Trie Char String
emptyMorpho :: Morpho
emptyMorpho = emptyTrie
appMorpho :: Morpho -> String -> (String,[String])
@@ -96,13 +102,18 @@ prMorphoAnalysisShort (w,fs) = prBracket (w' ++ prTList "/" fs) where
tagPrt :: Print a => (a,a) -> String
tagPrt (m,c) = "+" ++ prt c --- module name
-- print all words recognized
-- | print all words recognized
allMorphoWords :: Morpho -> [String]
allMorphoWords = map fst . collapse
-- analyse running text and show results either in short form or on separate lines
-- | analyse running text and show results in short form
morphoTextShort :: Morpho -> String -> String
morphoTextShort mo = unwords . map (prMorphoAnalysisShort . appMorpho mo) . words
-- | analyse running text and show results on separate lines
morphoText :: Morpho -> String -> String
morphoText mo = unlines . map (('\n':) . prMorphoAnalysis . appMorpho mo) . words
-- format used in the Italian Verb Engine

14
src/GF/UseGrammar/Paraphrases.hs
View File

@@ -1,15 +1,19 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Paraphrases
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:39 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-- paraphrases of GF terms. AR 6\/10\/1998 -- 24\/9\/1999 -- 5\/7\/2000 -- 5\/6\/2002
--
-- Copyright (c) Aarne Ranta 1998--99, under GNU General Public License (see GPL)
--
-- thus inherited from the old GF. Incomplete and inefficient...
-----------------------------------------------------------------------------
module Paraphrases (mkParaphrases) where

10
src/GF/UseGrammar/Parsing.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Parsing
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:39 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.13 $
-- > CVS $Revision: 1.14 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
@@ -132,7 +132,7 @@ trees2trms opts sg cn as ts0 info = do
--- too much type checking in building term info? return FullTerm to save work?
-- raw parsing: so simple it is for a context-free CF grammar
-- | raw parsing: so simple it is for a context-free CF grammar
cf2trm0 :: CFTree -> C.Exp
cf2trm0 (CFTree (fun, (_, trees))) = mkAppAtom (cffun2trm fun) (map cf2trm0 trees)
where

16
src/GF/UseGrammar/Randomized.hs
View File

@@ -1,15 +1,16 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Randomized
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:39 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.6 $
-- > CVS $Revision: 1.7 $
--
-- (Description of the module)
-- random generation and refinement. AR 22\/8\/2001.
-- implemented as sequence of refinement menu selecsions, encoded as integers
-----------------------------------------------------------------------------
module Randomized where
@@ -26,16 +27,17 @@ import Random --- (mkStdGen, StdGen, randoms) --- bad import for hbc
-- random generation and refinement. AR 22/8/2001
-- implemented as sequence of refinement menu selecsions, encoded as integers
myStdGen :: Int -> StdGen
myStdGen = mkStdGen ---
-- build one random tree; use mx to prevent infinite search
-- | build one random tree; use mx to prevent infinite search
mkRandomTree :: StdGen -> Int -> CGrammar -> Either Cat Fun -> Err Tree
mkRandomTree gen mx gr cat = mkTreeFromInts (take mx (randoms gen)) gr cat
refineRandom :: StdGen -> Int -> CGrammar -> Action
refineRandom gen mx = mkStateFromInts $ take mx $ map abs (randoms gen)
-- build a tree from a list of integers
-- | build a tree from a list of integers
mkTreeFromInts :: [Int] -> CGrammar -> Either Cat Fun -> Err Tree
mkTreeFromInts ints gr catfun = do
st0 <- either (\cat -> newCat gr cat initState)

27
src/GF/UseGrammar/RealMoreCustom.hs
View File

@@ -1,15 +1,19 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : MoreCustom
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:39 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.4 $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-- databases for customizable commands. AR 21\/11\/2001
--
-- Extends "Custom".
--
-- obsolete???
-----------------------------------------------------------------------------
module MoreCustom where
@@ -53,6 +57,7 @@ import qualified TransPredCalc as PC
-- databases for customizable commands. AR 21/11/2001
-- Extends ../Custom.
moreCustomGrammarParser :: CustomData (FilePath -> IOE C.CanonGrammar)
moreCustomGrammarParser =
[
(strCIm "gfl", S.parseGrammar . extractGFLatex)
@@ -66,6 +71,7 @@ moreCustomGrammarParser =
pAsGrammar p = err Bad (\g -> return (([],noOptions),g)) . p
moreCustomGrammarPrinter :: CustomData (StateGrammar -> String)
moreCustomGrammarPrinter =
[
(strCIm "happy", cf2HappyS . stateCF)
@@ -84,8 +90,10 @@ moreCustomGrammarPrinter =
--- also include printing via grammar2syntax!
]
moreCustomMultiGrammarPrinter :: CustomData (CanonGrammar -> String)
moreCustomMultiGrammarPrinter = []
moreCustomSyntaxPrinter :: CustomData (GF.Grammar -> String)
moreCustomSyntaxPrinter =
[
(strCIm "gf", S.prSyntax) -- DEFAULT
@@ -93,28 +101,33 @@ moreCustomSyntaxPrinter =
-- add your own grammar printers here
]
moreCustomTermPrinter :: CustomData (StateGrammar -> Tree -> String)
moreCustomTermPrinter =
[
(strCIm "xml", \g t -> unlines $ prElementX $ term2elemx (stateAbstract g) t)
-- add your own term printers here
]
moreCustomTermCommand :: CustomData (StateGrammar -> Tree -> [Tree])
moreCustomTermCommand =
[
(strCIm "predcalc", \_ t -> PC.transfer t)
-- add your own term commands here
]
moreCustomEditCommand :: CustomData (StateGrammar -> Action)
moreCustomEditCommand =
[
-- add your own edit commands here
]
moreCustomStringCommand :: CustomData (StateGrammar -> String -> String)
moreCustomStringCommand =
[
-- add your own string commands here
]
moreCustomParser :: CustomData (StateGrammar -> CFCat -> CFParser)
moreCustomParser =
[
(strCIm "chart", chartParser . stateCF)
@@ -124,19 +137,23 @@ moreCustomParser =
-- add your own parsers here
]
moreCustomTokenizer :: CustomData (StateGrammar -> String -> [CFTok])
moreCustomTokenizer =
[
-- add your own tokenizers here
]
moreCustomUntokenizer :: CustomData (StateGrammar -> String -> String)
moreCustomUntokenizer =
[
-- add your own untokenizers here
]
moreCustomUniCoding :: CustomData (String -> String)
moreCustomUniCoding =
[
-- add your own codings here
]
strCIm :: String -> CommandId
strCIm = id

43
src/GF/UseGrammar/Session.hs
View File

@@ -1,13 +1,13 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Session
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:39 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.7 $
-- > CVS $Revision: 1.8 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
@@ -27,8 +27,11 @@ import Operations
-- keep these abstract
type SState = [(State,([Exp],[Clip]),SInfo)] -- exps: candidate refinements,clipboard
type SInfo = ([String],(Int,Options)) -- string is message, int is the view
-- | 'Exp'-list: candidate refinements,clipboard
type SState = [(State,([Exp],[Clip]),SInfo)]
-- | 'String' is message, 'Int' is the view
type SInfo = ([String],(Int,Options))
initSState :: SState
initSState = [(initState, ([],[]), (["Select 'New' category to start"],(0,noOptions)))]
@@ -36,8 +39,21 @@ initSState = [(initState, ([],[]), (["Select 'New' category to start"],(0,noOpti
type Clip = Tree ---- (Exp,Type)
-- | (peb): Something wrong with this definition??
-- Shouldn't the result type be 'SInfo'?
--
-- > okInfo :: Int -> SInfo == ([String], (Int, Options))
okInfo :: n -> ([s], (n, Bool))
okInfo n = ([],(n,True))
stateSState :: SState -> State
candsSState :: SState -> [Exp]
clipSState :: SState -> [Clip]
infoSState :: SState -> SInfo
msgSState :: SState -> [String]
viewSState :: SState -> Int
optsSState :: SState -> Options
stateSState ((s,_,_):_) = s
candsSState ((_,(ts,_),_):_)= ts
clipSState ((_,(_,ts),_):_)= ts
@@ -46,16 +62,17 @@ msgSState ((_,_,(m,_)):_) = m
viewSState ((_,_,(_,(v,_))):_) = v
optsSState ((_,_,(_,(_,o))):_) = o
treeSState :: SState -> Tree
treeSState = actTree . stateSState
-- from state to state
-- | from state to state
type ECommand = SState -> SState
-- elementary commands
-- * elementary commands
-- ** change state, drop cands, drop message, preserve options
-- change state, drop cands, drop message, preserve options
changeState :: State -> ECommand
changeState s ss = changeMsg [] $ (s,([],clipSState ss),infoSState ss) : ss
@@ -77,16 +94,18 @@ withMsg m c = changeMsg m . c
changeStOptions :: (Options -> Options) -> ECommand
changeStOptions f ((s,ts,(m,(v,o))):ss) = (s,ts,(m,(v, f o))) : ss
noNeedForMsg :: ECommand
noNeedForMsg = changeMsg [] -- everything's all right: no message
candInfo :: [Exp] -> [String]
candInfo ts = case length ts of
0 -> ["no acceptable alternative"]
1 -> ["just one acceptable alternative"]
n -> [show n +++ "alternatives to select"]
-- keep SState abstract from this on
-- * keep SState abstract from this on
-- editing commands
-- ** editing commands
action2command :: Action -> ECommand
action2command act state = case act (stateSState state) of

13
src/GF/UseGrammar/TeachYourself.hs
View File

@@ -1,15 +1,17 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : TeachYourself
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:22 $
-- > CVS $Date: 2005/02/24 11:46:39 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
-- > CVS $Revision: 1.4 $
--
-- (Description of the module)
-- translation and morphology quiz. AR 10\/5\/2000 -- 12\/4\/2002
--
-- outdated?? @shell\/TeachYourself@ is loaded instead of this...
-----------------------------------------------------------------------------
module TeachYourself where
@@ -75,6 +77,7 @@ 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

41
src/GF/UseGrammar/Tokenize.hs
View File

@@ -1,18 +1,28 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Tokenize
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:23 $
-- > CVS $Date: 2005/02/24 11:46:39 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.9 $
-- > CVS $Revision: 1.10 $
--
-- (Description of the module)
-- lexers = tokenizers, to prepare input for GF grammars. AR 4\/1\/2002.
-- an entry for each is included in 'Custom.customTokenizer'
-----------------------------------------------------------------------------
module Tokenize where
module Tokenize ( tokWords,
tokLits,
tokVars,
lexHaskell,
lexHaskellLiteral,
lexHaskellVar,
lexText,
lexC2M, lexC2M',
lexTextLiteral,
) where
import Operations
---- import UseGrammar (isLiteral,identC)
@@ -23,8 +33,7 @@ import Char
-- lexers = tokenizers, to prepare input for GF grammars. AR 4/1/2002
-- an entry for each is included in Custom.customTokenizer
-- just words
-- | just words
tokWords :: String -> [CFTok]
tokWords = map tS . words
@@ -61,15 +70,13 @@ mkTL :: String -> CFTok
mkTL s = if (all isDigit s) then (tI s) else (tL ("'" ++ s ++ "'"))
-- Haskell lexer, usable for much code
-- | Haskell lexer, usable for much code
lexHaskell :: String -> [CFTok]
lexHaskell ss = case lex ss of
[(w@(_:_),ws)] -> tS w : lexHaskell ws
_ -> []
-- somewhat shaky text lexer
-- | somewhat shaky text lexer
lexText :: String -> [CFTok]
lexText = uncap . lx where
@@ -87,8 +94,7 @@ lexText = uncap . lx where
uncap (TS (c:cs) : ws) = tC (c:cs) : ws
uncap s = s
-- lexer for C--, a mini variant of C
-- | lexer for C--, a mini variant of C
lexC2M :: String -> [CFTok]
lexC2M = lexC2M' False
@@ -125,7 +131,7 @@ reservedAnsiC s = case lookupTree show s ansiCtree of
Ok False -> True
_ -> False
-- for an efficient lexer: precompile this!
-- | for an efficient lexer: precompile this!
ansiCtree = buildTree $ [(s,True) | s <- reservedAnsiCSymbols] ++
[(s,False) | s <- reservedAnsiCWords]
@@ -140,8 +146,7 @@ reservedAnsiCWords = words $
"union unsigned void volatile while " ++
"main printin putchar" --- these are not ansi-C
-- turn unknown tokens into string literals; not recursively for literals 123, 'foo'
-- | turn unknown tokens into string literals; not recursively for literals 123, 'foo'
unknown2string :: (String -> Bool) -> [CFTok] -> [CFTok]
unknown2string isKnown = map mkOne where
mkOne t@(TS s)
@@ -162,6 +167,8 @@ unknown2var isKnown = map mkOne where
mkOne t@(TC s) = if isKnown s then t else tV s
mkOne t = t
lexTextLiteral, lexHaskellLiteral, lexHaskellVar :: (String -> Bool) -> String -> [CFTok]
lexTextLiteral isKnown = unknown2string (eitherUpper isKnown) . lexText
lexHaskellLiteral isKnown = unknown2string isKnown . lexHaskell

10
src/GF/UseGrammar/Transfer.hs
View File

@@ -1,15 +1,15 @@
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Module : Transfer
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/02/18 19:21:23 $
-- > CVS $Date: 2005/02/24 11:46:40 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
-- > CVS $Revision: 1.4 $
--
-- (Description of the module)
-- linearize, parse, etc, by transfer. AR 9\/10\/2003
-----------------------------------------------------------------------------
module Transfer where

38
src/haddock/haddock-check.perl
View File

@@ -21,9 +21,10 @@ $nonOperCharColon = qr/[^\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]/;
$operSym = qr/$operChar $operCharColon*/x;
$funSym = qr/[a-z] \w* \'*/x;
$funOrOper = qr/(?: $funSym | \($operSym\) )/x;
$keyword = qr/(?: type | data | module | newtype | infix[lr]? | import | instance | class )/x;
$keyOper = qr/^( ?: \.\. | \:\:? | \= | \\ | \| | \<\- | \-\> | \@ | \~ | \=\> | \. )$/x;
$keyOper = qr/^(?: \.\. | \:\:? | \= | \\ | \| | \<\- | \-\> | \@ | \~ | \=\> | \. )$/x;
sub check_headerline {
my ($title, $regexp) = @_;
@@ -101,13 +102,13 @@ for $file (@FILES) {
print " > No export list\n";
# function definitions
while (/^ (.*? $nonOperCharColon) = (?!$operCharColon)/gmx) {
while (/^ (.*? $nonOperCharColon) = (?! $operCharColon)/gmx) {
$defn = $1;
next if $defn =~ /^ $keyword \b/x;
if ($defn =~ /\` ($funSym) \`/x) {
$fn = $1;
} elsif ($defn =~ /(?<!$operCharColon) ($operSym)/x
} elsif ($defn =~ /(?<! $operCharColon) ($operSym)/x
&& $1 !~ $keyOper) {
$fn = "($1)";
} elsif ($defn =~ /^($funSym)/x) {
@@ -121,30 +122,29 @@ for $file (@FILES) {
}
}
# removing from export list...
# fixing exportlist (double spaces as separator)
$exportlist = " $exportlist ";
$exportlist =~ s/(\s | \,)+/ /gx;
# ...ordinary functions
while (/^ ($funSym) \s* ::/gmx) {
$function = $1;
$exportlist =~ s/\b $function \b//gx;
}
# ...operations
while (/^ (\( $operSym \)) \s* ::/gmx) {
$function = $1;
$exportlist =~ s/\Q$function\E//g;
# removing functions with type signatures from export list
while (/^ ($funOrOper (\s* , \s* $funOrOper)*) \s* ::/gmx) {
$functionlist = $1;
while ($functionlist =~ s/^ ($funOrOper) (\s* , \s*)?//x) {
$function = $1;
$exportlist =~ s/\s \Q$function\E \s/ /gx;
}
}
# reporting exported functions without type signatures
$reported = 0;
while ($exportlist =~ /(\b $funSym \b | \( $operSym \))/gx) {
while ($exportlist =~ /\s ($funOrOper) \s/x) {
$function = $1;
print " > No type signature for function(s):"
unless $reported;
print "\n " unless $reported++ % 500;
$exportlist =~ s/\s \Q$function\E \s/ /gx;
print " > No type signature for function(s):\n "
unless $reported++;
print " $function";
}
print "\n ($reported functions)\n"
print "\n $reported function(s)\n"
if $reported;
}