summaryrefslogtreecommitdiff
path: root/src/GF/Canon
diff options
context:
space:
mode:
authorpeb <unknown>2005-02-09 11:46:54 +0000
committerpeb <unknown>2005-02-09 11:46:54 +0000
commita0d412986305d4b45e82afde62ea48f1b06edb9d (patch)
treebca6f55ef01469442ef55f6bd0caa511e147350f /src/GF/Canon
parent4fd0c636f8590bf800715f2598e54ccc22c99b90 (diff)
"Committed_by_peb"
Diffstat (limited to 'src/GF/Canon')
-rw-r--r--src/GF/Canon/CMacros.hs30
-rw-r--r--src/GF/Canon/CanonToGrammar.hs6
-rw-r--r--src/GF/Canon/GFC.hs6
-rw-r--r--src/GF/Canon/GetGFC.hs2
-rw-r--r--src/GF/Canon/Look.hs4
-rw-r--r--src/GF/Canon/MkGFC.hs5
-rw-r--r--src/GF/Canon/PrExp.hs8
-rw-r--r--src/GF/Canon/Share.hs20
-rw-r--r--src/GF/Canon/Unlex.hs8
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