Various small changes for improved documentation

src/compiler/GF/Command/Importing.hs

@@ -48,7 +48,7 @@ importSource :: SourceGrammar -> Options -> [FilePath] -> IO SourceGrammar
 importSource src0 opts files = do
   src <- appIOE $ batchCompile opts files
   case src of
-    Ok (_,_,gr) -> return gr
+    Ok (_,(_,gr)) -> return gr
     Bad msg -> do 
       putStrLn msg
       return src0

src/compiler/GF/Compile.hs

@@ -1,4 +1,4 @@
-module GF.Compile (batchCompile, link, srcAbsName, compileToPGF) where
+module GF.Compile (compileToPGF, link, batchCompile, srcAbsName) where
 
 import GF.Compile.GrammarToPGF(mkCanon2pgf)
 import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles,
@@ -26,14 +26,14 @@ import PGF.Internal(optimizePGF)
 import PGF(PGF,defaultProbabilities,setProbabilities,readProbabilitiesFromFile)
 
 -- | Compiles a number of source files and builds a 'PGF' structure for them.
--- This is a composition of 'batchCompile' and 'link'.
+-- This is a composition of 'link' and 'batchCompile'.
 compileToPGF :: Options -> [FilePath] -> IOE PGF
-compileToPGF opts fs = link opts =<< batchCompile opts fs
+compileToPGF opts fs = link opts . snd =<< batchCompile opts fs
 
 -- | Link a grammar into a 'PGF' that can be used to 'PGF.linearize' and
 -- 'PGF.parse' with the "PGF" run-time system.
-link :: Options -> (ModuleName,t,Grammar) -> IOE PGF
+link :: Options -> (ModuleName,Grammar) -> IOE PGF
-link opts (cnc,_,gr) =
+link opts (cnc,gr) =
   putPointE Normal opts "linking ... " $ do
     let abs = srcAbsName gr cnc
     pgf <- mkCanon2pgf opts gr abs
@@ -45,13 +45,13 @@ link opts (cnc,_,gr) =
 -- | Returns the name of the abstract syntax corresponding to the named concrete syntax
 srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
 
--- | Compile the given grammar files and everything they depend on
+-- | Compile the given grammar files and everything they depend on.
-batchCompile :: Options -> [FilePath] -> IOE (ModuleName,UTCTime,Grammar)
+batchCompile :: Options -> [FilePath] -> IOE (UTCTime,(ModuleName,Grammar))
 batchCompile opts files = do
   (gr,menv) <- foldM (compileModule opts) emptyCompileEnv files
   let cnc = moduleNameS (justModuleName (last files))
       t = maximum . map fst $ Map.elems menv
-  return (cnc,t,gr)
+  return (t,(cnc,gr))
 {-
 -- to compile a set of modules, e.g. an old GF or a .cf file
 compileSourceGrammar :: Options -> Grammar -> IOE Grammar

src/compiler/GF/Compiler.hs

@@ -49,10 +49,14 @@ compileSourceFiles opts fs =
            linkGrammars opts output
   where
     batchCompile = maybe batchCompile' parallelBatchCompile (flag optJobs opts)
-    batchCompile' opts fs = do (cnc,t,gr) <- S.batchCompile opts fs
+    batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts fs
-                               return (t,[(cnc,gr)])
+                               return (t,[cnc_gr])
 
--- | Create a @.pgf@ file from the output of 'parallelBatchCompile'.
+-- | Create a @.pgf@ file (and possibly files in other formats, if specified
+-- in the 'Options') from the output of 'parallelBatchCompile'.
+-- If a @.pgf@ file by the same name already exists and it is newer than the
+-- source grammar files (as indicated by the 'UTCTime' argument), it is not
+-- recreated.
 linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
     do let abs = render (srcAbsName gr cnc)
            pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
@@ -61,8 +65,7 @@ linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
                 else return Nothing
        if t_pgf >= Just t_src
          then putIfVerb opts $ pgfFile ++ " is up-to-date."
-         else do pgfs <- mapM (link opts)
+         else do pgfs <- mapM (link opts) cnc_grs
-                              [(cnc,t_src,gr)|(cnc,gr)<-cnc_grs]
                  let pgf = foldl1 unionPGF pgfs
                  writePGF opts pgf
                  writeOutputs opts pgf

src/compiler/GF/Data/Operations.hs

@@ -14,19 +14,21 @@
 -- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL)
 -----------------------------------------------------------------------------
 
-module GF.Data.Operations (-- ** Misc functions
+module GF.Data.Operations (
-		   ifNull,
-
 		   -- ** The Error monad
 		   Err(..), err, maybeErr, testErr, fromErr, errIn, 
 		   lookupErr,
 
-                   --- ** Monadic operations on lists and pairs
+		   -- ** Error monad class
-		   mapPairListM, mapPairsM, pairM,
+		   ErrorMonad(..), checks, doUntil, --allChecks, checkAgain,
+                   liftErr,
 		   
 		   -- ** Checking
 		   checkUnique, unifyMaybeBy, unifyMaybe,
 
+                   -- ** Monadic operations on lists and pairs
+		   mapPairListM, mapPairsM, pairM,
+
 		   -- ** Binary search trees; now with FiniteMap
 		   BinTree, emptyBinTree, isInBinTree, --justLookupTree,
 		   lookupTree, --lookupTreeMany,
@@ -35,31 +37,23 @@ module GF.Data.Operations (-- ** Misc functions
                    mapTree, --mapMTree,
                    tree2list,
  
-
 		   -- ** Printing
 		   indent, (+++), (++-), (++++), (+++++),
 		   prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, 
 		   prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
 		   numberedParagraphs, prConjList, prIfEmpty, wrapLines,
 
-		   -- ** Extra
+		   -- ** Topological sorting
-		   combinations, done, readIntArg, --singleton,
-
-		   -- ** Topological sorting with test of cyclicity
 		   topoTest, topoTest2,
 
-		   -- ** The generic fix point iterator
+		   -- ** Misc
-		   iterFix,
+		   ifNull,
-
+		   combinations, done, readIntArg, --singleton,
-		   -- ** Chop into separator-separated parts
+		   iterFix,  chunks,
-		   chunks,
 {-
 		   -- ** State monad with error; from Agda 6\/11\/2001
 		   STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM,
 -}
-		   -- ** Error monad class
-		   ErrorMonad(..), checks, allChecks, doUntil, --checkAgain,
-                   liftErr
                 
 		  ) where
 
@@ -257,11 +251,11 @@ singleton :: a -> [a]
 singleton = (:[])
 -}
 
--- | topological sorting with test of cyclicity
+-- | Topological sorting with test of cyclicity
 topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
 topoTest = topologicalSort . mkRel'
 
--- | topological sorting with test of cyclicity, new version /TH 2012-06-26
+-- | Topological sorting with test of cyclicity, new version /TH 2012-06-26
 topoTest2 :: Ord a => [(a,[a])] -> Either [[a]] [[a]]
 topoTest2 g0 = maybe (Right cycles) Left (tsort g)
   where
@@ -277,7 +271,7 @@ topoTest2 g0 = maybe (Right cycles) Left (tsort g)
 	  where leaves = map fst ns
 
 
--- | the generic fix point iterator
+-- | Fix point iterator (for computing e.g. transitive closures or reachability)
 iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
 iterFix more start = iter start start 
   where
@@ -332,6 +326,7 @@ updateSTM f = stmr (\s -> ((),f s))
 writeSTM :: s -> STM s ()
 writeSTM s = stmr (const ((),s))
 -}
+-- | @return ()@
 done :: Monad m => m ()
 done = return ()
 
@@ -363,12 +358,12 @@ checkAgain c1 c2 = handle_ c1 c2
 checks :: ErrorMonad m => [m a] -> m a
 checks [] = raise "no chance to pass"
 checks cs = foldr1 checkAgain cs
-
+{-
 allChecks :: ErrorMonad m => [m a] -> m [a]
 allChecks ms = case ms of
   (m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs
   _ -> return []
-
+-}
 doUntil :: ErrorMonad m => (a -> Bool) -> [m a] -> m a
 doUntil cond ms = case ms of
   a:as -> do

src/compiler/GF/Grammar/Grammar.hs

@@ -23,9 +23,8 @@ module GF.Grammar.Grammar (
 
         MInclude (..), OpenSpec(..),
         extends, isInherited, inheritAll,
-        openedModule, depPathModule, allDepsModule, partOfGrammar,
+        openedModule, allDepsModule, partOfGrammar, depPathModule,
-        allExtends, allExtendsPlus,
+        allExtends, allExtendsPlus, --searchPathModule,
-        searchPathModule,
         
         lookupModule,
         isModAbs, isModRes, isModCnc,
@@ -36,15 +35,15 @@ module GF.Grammar.Grammar (
 
         ModuleStatus(..),
 
-        -- ** Judgements and terms
+        -- ** Judgements
         Info(..),
-        Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
+        -- ** Terms
+        Term(..),
         Type,
         Cat,
         Fun,
         QIdent,
         BindType(..),
-        Term(..),
         Patt(..),
         TInfo(..),
         Label(..),
@@ -61,6 +60,8 @@ module GF.Grammar.Grammar (
         Substitution,
         varLabel, tupleLabel, linLabel, theLinLabel,
         ident2label, label2ident,
+        -- ** Source locations
+        Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
 
         -- ** PMCFG        
         PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence

src/compiler/GF/Grammar/Macros.hs

@@ -33,7 +33,7 @@ import Control.Monad (liftM, liftM2, liftM3)
 import Data.List (sortBy,nub)
 import GF.Text.Pretty
 
--- ** Macros for constructing and analysing source code terms.
+-- ** Functions for constructing and analysing source code terms.
 
 typeForm :: Type -> (Context, Cat, [Term])
 typeForm t =
@@ -151,12 +151,14 @@ isVariable :: Term -> Bool
 isVariable (Vr _ ) = True
 isVariable _ = False
 
-eqIdent :: Ident -> Ident -> Bool
+--eqIdent :: Ident -> Ident -> Bool
-eqIdent = (==)
+--eqIdent = (==)
 
 uType :: Type
 uType = Cn cUndefinedType
 
+-- *** Assignment
+
 assign :: Label -> Term -> Assign
 assign l t = (l,(Nothing,t))
 
@@ -182,6 +184,8 @@ mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
 mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
   where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
 
+-- *** Records
+
 mkRecordN :: Int -> (Int -> Label) -> [Term] -> Term
 mkRecordN int lab typs = R [ assign (lab i) t | (i,t) <- zip [int..] typs]
 
@@ -199,7 +203,10 @@ record2subst t = case t of
   R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
   _    -> Bad (render ("record expected, found" <+> ppTerm Unqualified 0 t))
 
-typeType, typePType, typeStr, typeTok, typeStrs :: Term
+
+-- *** Types
+
+typeType, typePType, typeStr, typeTok, typeStrs :: Type
 
 typeType  = Sort cType
 typePType = Sort cPType
@@ -207,10 +214,10 @@ typeStr   = Sort cStr
 typeTok   = Sort cTok
 typeStrs  = Sort cStrs
 
-typeString, typeFloat, typeInt :: Term
+typeString, typeFloat, typeInt :: Type
-typeInts :: Int -> Term
+typeInts :: Int -> Type
-typePBool :: Term
+typePBool :: Type
-typeError :: Term
+typeError :: Type
 
 typeString = cnPredef cString
 typeInt = cnPredef cInt
@@ -219,10 +226,12 @@ typeInts i = App (cnPredef cInts) (EInt i)
 typePBool = cnPredef cPBool
 typeError = cnPredef cErrorType
 
-isTypeInts :: Term -> Maybe Int
+isTypeInts :: Type -> Maybe Int
 isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
 isTypeInts _                                      = Nothing
 
+-- *** Terms
+
 isPredefConstant :: Term -> Bool
 isPredefConstant t = case t of
   Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True
@@ -341,6 +350,8 @@ linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str}
 linAsStr :: String -> Term
 linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}
 
+-- *** Term and pattern conversion
+
 term2patt :: Term -> Err Patt
 term2patt trm = case termForm trm of
   Ok ([], Vr x, []) | x == identW -> return PW
@@ -416,49 +427,7 @@ patt2term pt = case pt of
   PNeg a    -> appCons cNeg   [(patt2term a)]                --- an encoding
 
 
-redirectTerm :: ModuleName -> Term -> Term
+-- *** Almost compositional
-redirectTerm n t = case t of
-  QC (_,f) -> QC (n,f)
-  Q  (_,f) -> Q  (n,f)
-  _ -> composSafeOp (redirectTerm n) t
-
--- | to gather ultimate cases in a table; preserves pattern list
-allCaseValues :: Term -> [([Patt],Term)]
-allCaseValues trm = case trm of
-  T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0]
-  _      -> [([],trm)]
-
--- | to get a string from a term that represents a sequence of terminals
-strsFromTerm :: Term -> Err [Str]
-strsFromTerm t = case t of
-  K s   -> return [str s]
-  Empty -> return [str []]
-  C s t -> do
-    s' <- strsFromTerm s
-    t' <- strsFromTerm t
-    return [plusStr x y | x <- s', y <- t']
-  Glue s t -> do
-    s' <- strsFromTerm s
-    t' <- strsFromTerm t
-    return [glueStr x y | x <- s', y <- t']
-  Alts d vs -> do
-    d0 <- strsFromTerm d
-    v0 <- mapM (strsFromTerm . fst) vs
-    c0 <- mapM (strsFromTerm . snd) vs
-    let vs' = zip v0 c0
-    return [strTok (str2strings def) vars | 
-              def  <- d0,
-              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
-                                                          vv <- combinations v0]
-           ]
-  FV ts -> mapM strsFromTerm ts >>= return . concat
-  Strs ts -> mapM strsFromTerm ts >>= return . concat  
-  _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
-
--- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
-stringFromTerm :: Term -> String
-stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm
-
 
 -- | to define compositional term functions
 composSafeOp :: (Term -> Term) -> Term -> Term
@@ -510,20 +479,6 @@ composPattOp op patt =
     PRep p          -> liftM  PRep (op p)
     _               -> return patt -- covers cases without subpatterns
 
-getTableType :: TInfo -> Err Type
-getTableType i = case i of
-  TTyped ty -> return ty
-  TComp ty  -> return ty
-  TWild ty  -> return ty
-  _ -> Bad "the table is untyped"
-
-changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo
-changeTableType co i = case i of
-    TTyped ty -> co ty >>= return . TTyped
-    TComp ty  -> co ty >>= return . TComp
-    TWild ty  -> co ty >>= return . TWild
-    _ -> return i
-
 collectOp :: (Term -> [a]) -> Term -> [a]
 collectOp co trm = case trm of
   App c a      -> co c ++ co a 
@@ -561,6 +516,67 @@ collectPattOp op patt =
     PRep p          -> op p
     _               -> []     -- covers cases without subpatterns
 
+
+-- *** Misc
+
+redirectTerm :: ModuleName -> Term -> Term
+redirectTerm n t = case t of
+  QC (_,f) -> QC (n,f)
+  Q  (_,f) -> Q  (n,f)
+  _ -> composSafeOp (redirectTerm n) t
+
+-- | to gather ultimate cases in a table; preserves pattern list
+allCaseValues :: Term -> [([Patt],Term)]
+allCaseValues trm = case trm of
+  T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0]
+  _      -> [([],trm)]
+
+-- | to get a string from a term that represents a sequence of terminals
+strsFromTerm :: Term -> Err [Str]
+strsFromTerm t = case t of
+  K s   -> return [str s]
+  Empty -> return [str []]
+  C s t -> do
+    s' <- strsFromTerm s
+    t' <- strsFromTerm t
+    return [plusStr x y | x <- s', y <- t']
+  Glue s t -> do
+    s' <- strsFromTerm s
+    t' <- strsFromTerm t
+    return [glueStr x y | x <- s', y <- t']
+  Alts d vs -> do
+    d0 <- strsFromTerm d
+    v0 <- mapM (strsFromTerm . fst) vs
+    c0 <- mapM (strsFromTerm . snd) vs
+    let vs' = zip v0 c0
+    return [strTok (str2strings def) vars | 
+              def  <- d0,
+              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
+                                                          vv <- combinations v0]
+           ]
+  FV ts -> mapM strsFromTerm ts >>= return . concat
+  Strs ts -> mapM strsFromTerm ts >>= return . concat  
+  _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
+
+-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
+stringFromTerm :: Term -> String
+stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm
+
+
+getTableType :: TInfo -> Err Type
+getTableType i = case i of
+  TTyped ty -> return ty
+  TComp ty  -> return ty
+  TWild ty  -> return ty
+  _ -> Bad "the table is untyped"
+
+changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo
+changeTableType co i = case i of
+    TTyped ty -> co ty >>= return . TTyped
+    TComp ty  -> co ty >>= return . TComp
+    TWild ty  -> co ty >>= return . TWild
+    _ -> return i
+
 -- | to find the word items in a term
 wordsInTerm :: Term -> [String]
 wordsInTerm trm = filter (not . null) $ case trm of
@@ -586,6 +602,8 @@ sortRec = sortBy ordLabel where
       (_,"s") -> GT
       (s1,s2) -> compare s1 s2
 
+-- *** Dependencies
+
 -- | dependency check, detecting circularities and returning topo-sorted list
 
 allDependencies :: (ModuleName -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])]

src/compiler/GF/Infra/Ident.hs

@@ -15,15 +15,15 @@
 module GF.Infra.Ident (-- ** Identifiers
               ModuleName(..), moduleNameS,
 	      Ident, ident2utf8, showIdent, prefixIdent,
-	      identS, identC, identV, identA, identAV, identW,
+              -- *** Normal identifiers (returned by the parser)
+	      identS, identC, identW,
+              -- *** Special identifiers for internal use
+              identV, identA, identAV,
 	      argIdent, isArgIdent, getArgIndex,
               varStr, varX, isWildIdent, varIndex,
-              -- ** Raw Identifiers
+              -- *** Raw identifiers
               RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
-              isPrefixOf, showRawIdent{-,
+              isPrefixOf, showRawIdent
-	      -- ** Refreshing identifiers
-	      IdState, initIdStateN, initIdState,
-	      lookVar, refVar, refVarPlus-}
 	     ) where
 
 import qualified Data.ByteString.UTF8 as UTF8
@@ -58,6 +58,8 @@ data Ident =
   deriving (Eq, Ord, Show, Read)
 
 -- | Identifiers are stored as UTF-8-encoded bytestrings.
+-- (It is also possible to use regular Haskell 'String's, with somewhat
+-- reduced performance and increased memory use.)
 newtype RawIdent = Id { rawId2utf8 :: UTF8.ByteString }
   deriving (Eq, Ord, Show, Read)
 
@@ -97,12 +99,7 @@ identS :: String -> Ident
 identS = identC . rawIdentS
 
 identC :: RawIdent -> Ident
-identV :: RawIdent -> Int -> Ident
-identA :: RawIdent -> Int -> Ident
-identAV:: RawIdent -> Int -> Int -> Ident
 identW :: Ident
-(identC, identV, identA, identAV, identW) = 
-    (IC,     IV,     IA,     IAV,     IW)
 
 
 prefixIdent :: String -> Ident -> Ident
@@ -111,6 +108,13 @@ prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8
 -- normal identifier
 -- ident s = IC s
 
+identV :: RawIdent -> Int -> Ident
+identA :: RawIdent -> Int -> Ident
+identAV:: RawIdent -> Int -> Int -> Ident
+
+(identC, identV, identA, identAV, identW) = 
+    (IC,     IV,     IA,     IAV,     IW)
+
 -- | to mark argument variables
 argIdent :: Int -> Ident -> Int -> Ident
 argIdent 0 (IC c) i = identA  c i

src/compiler/GF/Infra/UseIO.hs

@@ -210,7 +210,7 @@ putPointE v opts msg act = do
   return a
 
 -- | Because GHC adds the confusing text "user error" for failures caused by
--- calls to fail.
+-- calls to 'fail'.
 ioErrorText e = if isUserError e
                 then ioeGetErrorString e
                 else show e