From 11ec4bc655a38724ef1c8926c914556318d79bef Mon Sep 17 00:00:00 2001 From: hallgren Date: Wed, 22 Oct 2014 15:45:52 +0000 Subject: [PATCH] Various small changes for improved documentation --- src/compiler/GF/Command/Importing.hs | 2 +- src/compiler/GF/Compile.hs | 16 +-- src/compiler/GF/Compiler.hs | 13 ++- src/compiler/GF/Data/Operations.hs | 41 ++++---- src/compiler/GF/Grammar/Grammar.hs | 13 +-- src/compiler/GF/Grammar/Macros.hs | 150 +++++++++++++++------------ src/compiler/GF/Infra/Ident.hs | 26 +++-- src/compiler/GF/Infra/UseIO.hs | 2 +- 8 files changed, 142 insertions(+), 121 deletions(-) diff --git a/src/compiler/GF/Command/Importing.hs b/src/compiler/GF/Command/Importing.hs index 4c5d796c5..e2284aa58 100644 --- a/src/compiler/GF/Command/Importing.hs +++ b/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 diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index 2aee8e519..719cb756c 100644 --- a/src/compiler/GF/Compile.hs +++ b/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 opts (cnc,_,gr) = +link :: Options -> (ModuleName,Grammar) -> IOE PGF +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 -batchCompile :: Options -> [FilePath] -> IOE (ModuleName,UTCTime,Grammar) +-- | Compile the given grammar files and everything they depend on. +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 diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs index d8692c681..d92ed387c 100644 --- a/src/compiler/GF/Compiler.hs +++ b/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 - return (t,[(cnc,gr)]) + batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts fs + 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) - [(cnc,t_src,gr)|(cnc,gr)<-cnc_grs] + else do pgfs <- mapM (link opts) cnc_grs let pgf = foldl1 unionPGF pgfs writePGF opts pgf writeOutputs opts pgf diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs index 6d93fec92..044dc06df 100644 --- a/src/compiler/GF/Data/Operations.hs +++ b/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 - ifNull, - +module GF.Data.Operations ( -- ** The Error monad Err(..), err, maybeErr, testErr, fromErr, errIn, lookupErr, - --- ** Monadic operations on lists and pairs - mapPairListM, mapPairsM, pairM, + -- ** Error monad class + 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 - combinations, done, readIntArg, --singleton, - - -- ** Topological sorting with test of cyclicity + -- ** Topological sorting topoTest, topoTest2, - -- ** The generic fix point iterator - iterFix, - - -- ** Chop into separator-separated parts - chunks, + -- ** Misc + ifNull, + combinations, done, readIntArg, --singleton, + iterFix, 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 diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 5ea6e7704..34b8a1bdf 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -23,9 +23,8 @@ module GF.Grammar.Grammar ( MInclude (..), OpenSpec(..), extends, isInherited, inheritAll, - openedModule, depPathModule, allDepsModule, partOfGrammar, - allExtends, allExtendsPlus, - searchPathModule, + openedModule, allDepsModule, partOfGrammar, depPathModule, + allExtends, allExtendsPlus, --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 diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index 95181cfbd..53c134396 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/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 = (==) +--eqIdent :: Ident -> Ident -> Bool +--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 -typeInts :: Int -> Term -typePBool :: Term -typeError :: Term +typeString, typeFloat, typeInt :: Type +typeInts :: Int -> Type +typePBool :: Type +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 -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 - +-- *** Almost compositional -- | 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])] diff --git a/src/compiler/GF/Infra/Ident.hs b/src/compiler/GF/Infra/Ident.hs index 7d0bed804..b856d3995 100644 --- a/src/compiler/GF/Infra/Ident.hs +++ b/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{-, - -- ** Refreshing identifiers - IdState, initIdStateN, initIdState, - lookVar, refVar, refVarPlus-} + isPrefixOf, showRawIdent ) 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 diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs index 80677658a..b9ff9c2e5 100644 --- a/src/compiler/GF/Infra/UseIO.hs +++ b/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