diff options
Diffstat (limited to 'src')
43 files changed, 781 insertions, 488 deletions
diff --git a/src/GF/CFGM/PrintCFGrammar.hs b/src/GF/CFGM/PrintCFGrammar.hs index 89e0be1a1..a80fa1930 100644 --- a/src/GF/CFGM/PrintCFGrammar.hs +++ b/src/GF/CFGM/PrintCFGrammar.hs @@ -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. ----------------------------------------------------------------------------- diff --git a/src/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs index 83d3aa54c..1f2d3762a 100644 --- a/src/GF/Canon/CMacros.hs +++ b/src/GF/Canon/CMacros.hs @@ -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] diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs index 1586674ca..1f9c71edd 100644 --- a/src/GF/Compile/ShellState.hs +++ b/src/GF/Compile/ShellState.hs @@ -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 diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs index ca75de352..d1a6562c8 100644 --- a/src/GF/Data/Operations.hs +++ b/src/GF/Data/Operations.hs @@ -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" diff --git a/src/GF/Data/Parsers.hs b/src/GF/Data/Parsers.hs index 8804c55f3..6dbe9611a 100644 --- a/src/GF/Data/Parsers.hs +++ b/src/GF/Data/Parsers.hs @@ -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 []) diff --git a/src/GF/Data/Str.hs b/src/GF/Data/Str.hs index bf92c83ed..c0a545106 100644 --- a/src/GF/Data/Str.hs +++ b/src/GF/Data/Str.hs @@ -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 diff --git a/src/GF/Data/Zipper.hs b/src/GF/Data/Zipper.hs index c56552104..11643b765 100644 --- a/src/GF/Data/Zipper.hs +++ b/src/GF/Data/Zipper.hs @@ -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) diff --git a/src/GF/Fudgets/CommandF.hs b/src/GF/Fudgets/CommandF.hs index 568e82856..00621499a 100644 --- a/src/GF/Fudgets/CommandF.hs +++ b/src/GF/Fudgets/CommandF.hs @@ -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 diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs index acffa5298..b97c211d7 100644 --- a/src/GF/Grammar/MMacros.hs +++ b/src/GF/Grammar/MMacros.hs @@ -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" diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs index ace3faf79..4cd39f6e6 100644 --- a/src/GF/Grammar/Macros.hs +++ b/src/GF/Grammar/Macros.hs @@ -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 diff --git a/src/GF/Infra/Ident.hs b/src/GF/Infra/Ident.hs index b805e551f..2589357ef 100644 --- a/src/GF/Infra/Ident.hs +++ b/src/GF/Infra/Ident.hs @@ -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 diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index cabba0c3b..ac903e8ec 100644 --- a/src/GF/Infra/Modules.hs +++ b/src/GF/Infra/Modules.hs @@ -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 diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs index af2f53735..bac3aac6d 100644 --- a/src/GF/Infra/Option.hs +++ b/src/GF/Infra/Option.hs @@ -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" diff --git a/src/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs index 5d4c147e0..51dfc71e8 100644 --- a/src/GF/Infra/UseIO.hs +++ b/src/GF/Infra/UseIO.hs @@ -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)) diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs index 775494362..252ad0249 100644 --- a/src/GF/Shell.hs +++ b/src/GF/Shell.hs @@ -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 diff --git a/src/GF/Shell/CommandL.hs b/src/GF/Shell/CommandL.hs index e7b78c222..8419038b6 100644 --- a/src/GF/Shell/CommandL.hs +++ b/src/GF/Shell/CommandL.hs @@ -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 diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs index a8162c48b..7dc93a4fe 100644 --- a/src/GF/Shell/Commands.hs +++ b/src/GF/Shell/Commands.hs @@ -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 :: 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 t av = mkTagAttrsXML t [av] + +mkTagAttrXML :: String -> (String, String) -> String +mkTagAttrXML t av = mkTagAttrsXML t [av] diff --git a/src/GF/Shell/JGF.hs b/src/GF/Shell/JGF.hs index 17bd563e9..9404ababc 100644 --- a/src/GF/Shell/JGF.hs +++ b/src/GF/Shell/JGF.hs @@ -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 diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs index cc5731ff2..bb375d00d 100644 --- a/src/GF/Shell/PShell.hs +++ b/src/GF/Shell/PShell.hs @@ -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 diff --git a/src/GF/Shell/ShellCommands.hs b/src/GF/Shell/ShellCommands.hs index b7e678e4c..a2ef91eab 100644 --- a/src/GF/Shell/ShellCommands.hs +++ b/src/GF/Shell/ShellCommands.hs @@ -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. ----------------------------------------------------------------------------- diff --git a/src/GF/Shell/SubShell.hs b/src/GF/Shell/SubShell.hs index cad79fce0..66d7f5253 100644 --- a/src/GF/Shell/SubShell.hs +++ b/src/GF/Shell/SubShell.hs @@ -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 diff --git a/src/GF/Shell/TeachYourself.hs b/src/GF/Shell/TeachYourself.hs index 0a006c4ac..7cb3594f7 100644 --- a/src/GF/Shell/TeachYourself.hs +++ b/src/GF/Shell/TeachYourself.hs @@ -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 diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs index cea8fb517..2a2e3e2d5 100644 --- a/src/GF/Source/GrammarToSource.hs +++ b/src/GF/Source/GrammarToSource.hs @@ -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 diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index fd25fe2fd..259e4f9fe 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -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" diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs index 5b8f196da..40240651e 100644 --- a/src/GF/Speech/SRG.hs +++ b/src/GF/Speech/SRG.hs @@ -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 diff --git a/src/GF/System/Arch.hs b/src/GF/System/Arch.hs index d18b12332..df3f171aa 100644 --- a/src/GF/System/Arch.hs +++ b/src/GF/System/Arch.hs @@ -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) diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index 47c3edb6c..4b12dba1a 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -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 = diff --git a/src/GF/UseGrammar/Editing.hs b/src/GF/UseGrammar/Editing.hs index 155c26ba7..3e6ed0018 100644 --- a/src/GF/UseGrammar/Editing.hs +++ b/src/GF/UseGrammar/Editing.hs @@ -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 = diff --git a/src/GF/UseGrammar/Generate.hs b/src/GF/UseGrammar/Generate.hs index 3a816b7c6..7242bb595 100644 --- a/src/GF/UseGrammar/Generate.hs +++ b/src/GF/UseGrammar/Generate.hs @@ -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 diff --git a/src/GF/UseGrammar/GetTree.hs b/src/GF/UseGrammar/GetTree.hs index 1b47c3148..b755ec7f3 100644 --- a/src/GF/UseGrammar/GetTree.hs +++ b/src/GF/UseGrammar/GetTree.hs @@ -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 diff --git a/src/GF/UseGrammar/Information.hs b/src/GF/UseGrammar/Information.hs index 9c1b29eb1..ea94d1270 100644 --- a/src/GF/UseGrammar/Information.hs +++ b/src/GF/UseGrammar/Information.hs @@ -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 diff --git a/src/GF/UseGrammar/Linear.hs b/src/GF/UseGrammar/Linear.hs index a4835cc8c..4b2a4d9bb 100644 --- a/src/GF/UseGrammar/Linear.hs +++ b/src/GF/UseGrammar/Linear.hs @@ -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 diff --git a/src/GF/UseGrammar/MoreCustom.hs b/src/GF/UseGrammar/MoreCustom.hs index 872f888cd..27dffcace 100644 --- a/src/GF/UseGrammar/MoreCustom.hs +++ b/src/GF/UseGrammar/MoreCustom.hs @@ -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 = [] diff --git a/src/GF/UseGrammar/Morphology.hs b/src/GF/UseGrammar/Morphology.hs index 135546680..62aeb7725 100644 --- a/src/GF/UseGrammar/Morphology.hs +++ b/src/GF/UseGrammar/Morphology.hs @@ -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 diff --git a/src/GF/UseGrammar/Paraphrases.hs b/src/GF/UseGrammar/Paraphrases.hs index b4132c607..2946c3625 100644 --- a/src/GF/UseGrammar/Paraphrases.hs +++ b/src/GF/UseGrammar/Paraphrases.hs @@ -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 diff --git a/src/GF/UseGrammar/Parsing.hs b/src/GF/UseGrammar/Parsing.hs index 72b65b7df..4ed16b7d4 100644 --- a/src/GF/UseGrammar/Parsing.hs +++ b/src/GF/UseGrammar/Parsing.hs @@ -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 diff --git a/src/GF/UseGrammar/Randomized.hs b/src/GF/UseGrammar/Randomized.hs index 26ef5d032..d893e663b 100644 --- a/src/GF/UseGrammar/Randomized.hs +++ b/src/GF/UseGrammar/Randomized.hs @@ -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) diff --git a/src/GF/UseGrammar/RealMoreCustom.hs b/src/GF/UseGrammar/RealMoreCustom.hs index f0e4a9a1e..86cb2623d 100644 --- a/src/GF/UseGrammar/RealMoreCustom.hs +++ b/src/GF/UseGrammar/RealMoreCustom.hs @@ -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 diff --git a/src/GF/UseGrammar/Session.hs b/src/GF/UseGrammar/Session.hs index b2414bdf8..6e27d4971 100644 --- a/src/GF/UseGrammar/Session.hs +++ b/src/GF/UseGrammar/Session.hs @@ -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 diff --git a/src/GF/UseGrammar/TeachYourself.hs b/src/GF/UseGrammar/TeachYourself.hs index d09c33514..d27f92c14 100644 --- a/src/GF/UseGrammar/TeachYourself.hs +++ b/src/GF/UseGrammar/TeachYourself.hs @@ -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 diff --git a/src/GF/UseGrammar/Tokenize.hs b/src/GF/UseGrammar/Tokenize.hs index 97cce8546..cfbf8c8df 100644 --- a/src/GF/UseGrammar/Tokenize.hs +++ b/src/GF/UseGrammar/Tokenize.hs @@ -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 diff --git a/src/GF/UseGrammar/Transfer.hs b/src/GF/UseGrammar/Transfer.hs index d9823df58..d0ac42688 100644 --- a/src/GF/UseGrammar/Transfer.hs +++ b/src/GF/UseGrammar/Transfer.hs @@ -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 diff --git a/src/haddock/haddock-check.perl b/src/haddock/haddock-check.perl index 913f1c7ba..5ff9e1a10 100644 --- a/src/haddock/haddock-check.perl +++ b/src/haddock/haddock-check.perl @@ -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; } |