diff options
| author | peb <unknown> | 2005-02-09 11:46:54 +0000 |
|---|---|---|
| committer | peb <unknown> | 2005-02-09 11:46:54 +0000 |
| commit | a0d412986305d4b45e82afde62ea48f1b06edb9d (patch) | |
| tree | bca6f55ef01469442ef55f6bd0caa511e147350f /src/GF/Canon | |
| parent | 4fd0c636f8590bf800715f2598e54ccc22c99b90 (diff) | |
"Committed_by_peb"
Diffstat (limited to 'src/GF/Canon')
| -rw-r--r-- | src/GF/Canon/CMacros.hs | 30 | ||||
| -rw-r--r-- | src/GF/Canon/CanonToGrammar.hs | 6 | ||||
| -rw-r--r-- | src/GF/Canon/GFC.hs | 6 | ||||
| -rw-r--r-- | src/GF/Canon/GetGFC.hs | 2 | ||||
| -rw-r--r-- | src/GF/Canon/Look.hs | 4 | ||||
| -rw-r--r-- | src/GF/Canon/MkGFC.hs | 5 | ||||
| -rw-r--r-- | src/GF/Canon/PrExp.hs | 8 | ||||
| -rw-r--r-- | src/GF/Canon/Share.hs | 20 | ||||
| -rw-r--r-- | src/GF/Canon/Unlex.hs | 8 |
9 files changed, 43 insertions, 46 deletions
diff --git a/src/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs index 8c655179a..667fc0e16 100644 --- a/src/GF/Canon/CMacros.hs +++ b/src/GF/Canon/CMacros.hs @@ -29,10 +29,10 @@ import Monad -- macros for concrete syntax in GFC that do not need lookup in a grammar --- how to mark subtrees, dep. on node, position, whether focus +-- | how to mark subtrees, dep. on node, position, whether focus type JustMarker = V.TrNode -> [Int] -> Bool -> (String, String) --- also to process the text (needed for escapes e.g. in XML) +-- | also to process the text (needed for escapes e.g. in XML) type Marker = (JustMarker, Maybe (String -> String)) defTMarker :: JustMarker -> Marker @@ -44,22 +44,22 @@ markSubtree (mk,esc) n is = markSubterm esc . mk n is escapeMkString :: Marker -> Maybe (String -> String) escapeMkString = snd --- if no marking is wanted, use the following +-- | if no marking is wanted, use the following noMark :: Marker noMark = defTMarker mk where mk _ _ _ = ("","") --- for vanilla brackets, focus, and position, use +-- | for vanilla brackets, focus, and position, use markBracket :: Marker markBracket = defTMarker mk where mk n p b = if b then ("[*" ++ show p,"*]") else ("[" ++ show p,"]") --- for focus only +-- | for focus only markFocus :: Marker markFocus = defTMarker mk where mk n p b = if b then ("[*","*]") else ("","") --- for XML, use +-- | for XML, use markJustXML :: JustMarker markJustXML n i b = if b @@ -84,7 +84,7 @@ markXML = (markJustXML, Just esc) where c :cs -> c :esc cs _ -> s --- for XML in JGF 1, use +-- | for XML in JGF 1, use markXMLjgf :: Marker markXMLjgf = defTMarker mk where mk n p b = @@ -94,7 +94,7 @@ markXMLjgf = defTMarker mk where where c = "type=" ++ prt (M.valNode n) --- the marking engine +-- | the marking engine markSubterm :: Maybe (String -> String) -> (String,String) -> Term -> Term markSubterm esc (beg, end) t = case t of R rs -> R $ map markField rs @@ -181,13 +181,13 @@ strsFromTerm t = case t of _ -> return [str ("BUG[" ++ prt t ++ "]")] ---- debug ---- _ -> prtBad "cannot get Str from term " t --- recursively collect all branches in a table +-- | recursively collect all branches in a table allInTable :: Term -> [Term] allInTable t = case t of T _ ts -> concatMap (\ (Cas _ v) -> allInTable v) ts --- expand ? _ -> [t] --- to gather s-fields; assumes term in normal form, preserves label +-- | to gather s-fields; assumes term in normal form, preserves label allLinFields :: Term -> Err [[(Label,Term)]] allLinFields trm = case trm of ---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good @@ -197,20 +197,20 @@ allLinFields trm = case trm of return $ concat lts _ -> prtBad "fields can only be sought in a record not in" trm ----- deprecated +-- | deprecated isLinLabel l = case l of L (A.IC ('s':cs)) | all isDigit cs -> True -- peb (28/4-04), for MCFG grammars to work: L (A.IC cs) | null cs || head cs `elem` ".!" -> True _ -> False --- to gather ultimate cases in a table; preserves pattern list +-- | to gather ultimate cases in a table; preserves pattern list allCaseValues :: Term -> [([Patt],Term)] allCaseValues trm = case trm of T _ cs -> [(p:ps, t) | Cas pp t0 <- cs, p <- pp, (ps,t) <- allCaseValues t0] _ -> [([],trm)] --- to gather all linearizations; assumes normal form, preserves label and args +-- | to gather all linearizations; assumes normal form, preserves label and args allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]] allLinValues trm = do lts <- allLinFields trm @@ -241,8 +241,7 @@ onTokens f t = case t of _ -> composSafeOp (onTokens f) t --- to define compositional term functions - +-- | to define compositional term functions composSafeOp :: (Term -> Term) -> Term -> Term composSafeOp op trm = case composOp (mkMonadic op) trm of Ok t -> t @@ -250,6 +249,7 @@ composSafeOp op trm = case composOp (mkMonadic op) trm of where mkMonadic f = return . f +-- | to define compositional term functions composOp :: Monad m => (Term -> m Term) -> Term -> m Term composOp co trm = case trm of diff --git a/src/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs index 16c2ae1f0..697ad2a8c 100644 --- a/src/GF/Canon/CanonToGrammar.hs +++ b/src/GF/Canon/CanonToGrammar.hs @@ -9,10 +9,10 @@ -- > CVS $Author $ -- > CVS $Revision $ -- --- (Description of the module) +-- a decompiler. AR 12/6/2003 -- 19/4/2004 ----------------------------------------------------------------------------- -module CanonToGrammar where +module CanonToGrammar (canon2sourceGrammar, canon2sourceModule, redFlag) where import AbsGFC import GFC @@ -28,8 +28,6 @@ import Operations import Monad --- a decompiler. AR 12/6/2003 -- 19/4/2004 - canon2sourceGrammar :: CanonGrammar -> Err G.SourceGrammar canon2sourceGrammar gr = do ms' <- mapM canon2sourceModule $ M.modules gr diff --git a/src/GF/Canon/GFC.hs b/src/GF/Canon/GFC.hs index 5c6d8b6b6..81a9abc78 100644 --- a/src/GF/Canon/GFC.hs +++ b/src/GF/Canon/GFC.hs @@ -9,7 +9,7 @@ -- > CVS $Author $ -- > CVS $Revision $ -- --- (Description of the module) +-- canonical GF. AR 10\/9\/2002 -- 9\/5\/2003 -- 21\/9 ----------------------------------------------------------------------------- module GFC where @@ -26,8 +26,6 @@ import qualified Modules as M import Char --- canonical GF. AR 10/9/2002 -- 9/5/2003 -- 21/9 - type Context = [(Ident,Exp)] type CanonGrammar = M.MGrammar Ident Flag Info @@ -44,7 +42,7 @@ data Info = | AbsTrans A.Term | ResPar [ParDef] - | ResOper CType Term -- global constant + | ResOper CType Term -- ^ global constant | CncCat CType Term Printname | CncFun CIdent [ArgVar] Term Printname | AnyInd Bool Ident diff --git a/src/GF/Canon/GetGFC.hs b/src/GF/Canon/GetGFC.hs index cac3b98b3..e38c44a76 100644 --- a/src/GF/Canon/GetGFC.hs +++ b/src/GF/Canon/GetGFC.hs @@ -12,7 +12,7 @@ -- (Description of the module) ----------------------------------------------------------------------------- -module GetGFC where +module GetGFC (getCanonModule, getCanonGrammar) where import Operations import ParGFC diff --git a/src/GF/Canon/Look.hs b/src/GF/Canon/Look.hs index 43ea7a132..8c0056438 100644 --- a/src/GF/Canon/Look.hs +++ b/src/GF/Canon/Look.hs @@ -9,7 +9,7 @@ -- > CVS $Author $ -- > CVS $Revision $ -- --- (Description of the module) +-- lookup in GFC. AR 2003 ----------------------------------------------------------------------------- module Look where @@ -29,8 +29,6 @@ import Option import Monad import List --- lookup in GFC. AR 2003 - -- linearization lookup lookupCncInfo :: CanonGrammar -> CIdent -> Err Info diff --git a/src/GF/Canon/MkGFC.hs b/src/GF/Canon/MkGFC.hs index 62bb4d184..a1dfdbe2f 100644 --- a/src/GF/Canon/MkGFC.hs +++ b/src/GF/Canon/MkGFC.hs @@ -12,7 +12,10 @@ -- (Description of the module) ----------------------------------------------------------------------------- -module MkGFC where +module MkGFC (prCanonModInfo, prCanon, prCanonMGr, + canon2grammar, grammar2canon, + info2mod, + trExp, rtExp, rtQIdent) where import GFC import AbsGFC diff --git a/src/GF/Canon/PrExp.hs b/src/GF/Canon/PrExp.hs index a689fb81a..dbd2bdc95 100644 --- a/src/GF/Canon/PrExp.hs +++ b/src/GF/Canon/PrExp.hs @@ -9,20 +9,16 @@ -- > CVS $Author $ -- > CVS $Revision $ -- --- (Description of the module) +-- print trees without qualifications ----------------------------------------------------------------------------- -module PrExp where +module PrExp (prExp) where import AbsGFC import GFC import Operations --- some printing - --- print trees without qualifications - prExp :: Exp -> String prExp e = case e of EApp f a -> pr1 f +++ pr2 a diff --git a/src/GF/Canon/Share.hs b/src/GF/Canon/Share.hs index a5a5f5349..89323eb2f 100644 --- a/src/GF/Canon/Share.hs +++ b/src/GF/Canon/Share.hs @@ -27,11 +27,20 @@ import qualified Modules as M -- following advice of Josef Svenningsson type OptSpec = [Integer] --- + doOptFactor opt = elem 2 opt doOptValues opt = elem 3 opt + +shareOpt :: OptSpec shareOpt = [] + +paramOpt :: OptSpec paramOpt = [2] + +valOpt :: OptSpec valOpt = [3] + +allOpt :: OptSpec allOpt = [2,3] shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo) @@ -44,7 +53,7 @@ shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOptim opt c t) m) shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOptim opt c t) m) shareInfo _ i = i --- the function putting together optimizations +-- | the function putting together optimizations shareOptim :: OptSpec -> Ident -> Term -> Term shareOptim opt c | doOptFactor opt && doOptValues opt = values . factor c 0 @@ -52,9 +61,8 @@ shareOptim opt c | doOptValues opt = values | otherwise = share --- we need no counter to create new variable names, since variables are +-- | we need no counter to create new variable names, since variables are -- local to tables - share :: Term -> Term share t = case t of T ty cs -> shareT ty [(p, share v) | Cas ps v <- cs, p <- ps] -- only substant. @@ -79,8 +87,7 @@ share t = case t of finalize ty css = T ty [Cas (map fst ps) t | ps@((_,t):_) <- css] --- do even more: factor parametric branches - +-- | do even more: factor parametric branches factor :: Ident -> Int -> Term -> Term factor c i t = case t of T _ [_] -> t @@ -111,8 +118,7 @@ factor c i t = case t of pIdent c i = identC ("p_" ++ prt c ++ "__" ++ show i) --- we need to replace subterms - +-- | we need to replace subterms replace :: Term -> Term -> Term -> Term replace old new trm = case trm of T ty cs -> T ty [Cas p (repl v) | Cas p v <- cs] diff --git a/src/GF/Canon/Unlex.hs b/src/GF/Canon/Unlex.hs index 09f330e30..934fe3c43 100644 --- a/src/GF/Canon/Unlex.hs +++ b/src/GF/Canon/Unlex.hs @@ -9,10 +9,10 @@ -- > CVS $Author $ -- > CVS $Revision $ -- --- (Description of the module) +-- elementary text postprocessing. AR 21/11/2001 ----------------------------------------------------------------------------- -module Unlex where +module Unlex (formatAsText, unlex, performBinds) where import Operations import Str @@ -20,8 +20,6 @@ import Str import Char import List (isPrefixOf) --- elementary text postprocessing. AR 21/11/2001 - formatAsText :: String -> String formatAsText = unwords . format . cap . words where format ws = case ws of @@ -40,7 +38,7 @@ formatAsText = unwords . format . cap . words where unlex :: [Str] -> String unlex = formatAsText . performBinds . concat . map sstr . take 1 ---- --- modified from GF/src/Text by adding hyphen +-- | modified from GF/src/Text by adding hyphen performBinds :: String -> String performBinds = unwords . format . words where format ws = case ws of |
