summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler/GF/Command/Importing.hs2
-rw-r--r--src/compiler/GF/Compile.hs16
-rw-r--r--src/compiler/GF/Compiler.hs15
-rw-r--r--src/compiler/GF/Data/Operations.hs41
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs13
-rw-r--r--src/compiler/GF/Grammar/Macros.hs150
-rw-r--r--src/compiler/GF/Infra/Ident.hs26
-rw-r--r--src/compiler/GF/Infra/UseIO.hs2
8 files changed, 143 insertions, 122 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)])
-
--- | Create a @.pgf@ file from the output of 'parallelBatchCompile'.
+ batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts fs
+ return (t,[cnc_gr])
+
+-- | 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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:59:04 +0000