msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Various small changes for improved documentation

Browse Source
This commit is contained in:
hallgren
2014-10-22 15:45:52 +00:00
parent 3a95d733dd
commit 11ec4bc655
8 changed files with 142 additions and 121 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/compiler/GF/Command/Importing.hs
View File

@@ -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

16
src/compiler/GF/Compile.hs
View File

@@ -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

13
src/compiler/GF/Compiler.hs
View File

@@ -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

41
src/compiler/GF/Data/Operations.hs
View File

@@ -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

13
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -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

150
src/compiler/GF/Grammar/Macros.hs
View File

@@ -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])]

26
src/compiler/GF/Infra/Ident.hs
View File

@@ -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

2
src/compiler/GF/Infra/UseIO.hs
View File

@@ -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