summaryrefslogtreecommitdiff
path: root/src/compiler/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF')
-rw-r--r--src/compiler/GF/Command/Commands.hs2
-rw-r--r--src/compiler/GF/Compile/Abstract/TC.hs2
-rw-r--r--src/compiler/GF/Compile/ExampleBased.hs2
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs94
-rw-r--r--src/compiler/GF/Compile/Rename.hs4
-rw-r--r--src/compiler/GF/Data/TrieMap.hs10
-rw-r--r--src/compiler/GF/Grammar/Lookup.hs6
-rw-r--r--src/compiler/GF/Grammar/Predef.hs6
-rw-r--r--src/compiler/GF/Grammar/Values.hs2
-rw-r--r--src/compiler/GF/Infra/Option.hs14
-rw-r--r--src/compiler/GF/Speech/VoiceXML.hs3
11 files changed, 81 insertions, 64 deletions
diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index 2ea3e169c..6f3700032 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -1012,7 +1012,7 @@ allCommands env@(pgf, mos) = Map.fromList [
_ -> fromExprs ts
where
(prs,bss) = unzip parses
- ts = [t | ParseResult ts <- prs, t <- ts]
+ ts = [t | ParseOk ts <- prs, t <- ts]
returnFromExprs es = return $ case es of
[] -> ([], "no trees found")
diff --git a/src/compiler/GF/Compile/Abstract/TC.hs b/src/compiler/GF/Compile/Abstract/TC.hs
index 9c28d88e9..68b1691ec 100644
--- a/src/compiler/GF/Compile/Abstract/TC.hs
+++ b/src/compiler/GF/Compile/Abstract/TC.hs
@@ -161,7 +161,7 @@ checkInferExp th tenv@(k,_,_) e typ = do
inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)])
inferExp th tenv@(k,rho,gamma) e = case e of
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
- Q (m,c) | m == cPredefAbs && isLiteralCat c
+ Q (m,c) | m == cPredefAbs && isPredefCat c
-> return (ACn (m,c) vType, vType, [])
| otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
QC c -> mkAnnot (ACn c) $ noConstr $ lookupConst th c ----
diff --git a/src/compiler/GF/Compile/ExampleBased.hs b/src/compiler/GF/Compile/ExampleBased.hs
index 5c56c0ce5..199d1e375 100644
--- a/src/compiler/GF/Compile/ExampleBased.hs
+++ b/src/compiler/GF/Compile/ExampleBased.hs
@@ -51,7 +51,7 @@ convertFile conf src file = do
return ws
TypeError _ _ ->
return []
- ParseResult ts ->
+ ParseOk ts ->
case rank ts of
(t:tt) -> appv ("WARNING: ambiguous example " ++ ex) >>
appn t >> mapM_ (appn . (" --- " ++)) tt >> return []
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index aeed3947a..c245c3595 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -43,7 +43,7 @@ import Control.Exception
convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr
-convertConcrete opts gr am cm = do
+convertConcrete opts0 gr am cm = do
let env0 = emptyGrammarEnv gr cm
when (flag optProf opts) $ do
profileGrammar cm env0 pfrules
@@ -52,6 +52,8 @@ convertConcrete opts gr am cm = do
return $ getConcr flags printnames env2
where
(m,mo) = cm
+
+ opts = addOptions (M.flags (snd am)) opts0
pfrules = [
(PFRule id args (0,res) (map (\(_,_,ty) -> ty) cont) val term) |
@@ -119,7 +121,7 @@ convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do
let pres = protoFCat grammarEnv res
pargs = map (protoFCat grammarEnv) args
- b = runCnvMonad gr (unfactor term >>= convertTerm CNil ctype) (pargs,[])
+ b = runCnvMonad gr (unfactor term >>= convertTerm opts CNil ctype) (pargs,[])
(grammarEnv1,b1) = addSequencesB grammarEnv b
grammarEnv2 = brk (\grammarEnv -> foldBM addRule
grammarEnv
@@ -293,43 +295,43 @@ reversePath path = rev CNil path
type Value a = Schema Branch a Term
-convertTerm :: Path -> Type -> Term -> CnvMonad (Value [Symbol])
-convertTerm sel ctype (Vr x) = convertArg ctype (getVarIndex x) (reversePath sel)
-convertTerm sel ctype (Abs _ _ t) = convertTerm sel ctype t -- there are only top-level abstractions and we ignore them !!!
-convertTerm sel ctype (R record) = convertRec sel ctype record
-convertTerm sel ctype (P term l) = convertTerm (CProj l sel) ctype term
-convertTerm sel ctype (V pt ts) = convertTbl sel ctype pt ts
-convertTerm sel ctype (S term p) = do v <- evalTerm CNil p
- convertTerm (CSel v sel) ctype term
-convertTerm sel ctype (FV vars) = do term <- variants vars
- convertTerm sel ctype term
-convertTerm sel ctype (C t1 t2) = do v1 <- convertTerm sel ctype t1
- v2 <- convertTerm sel ctype t2
- return (CStr (concat [s | CStr s <- [v1,v2]]))
-convertTerm sel ctype (K t) = return (CStr [SymKS [t]])
-convertTerm sel ctype Empty = return (CStr [])
-convertTerm sel ctype (Alts s alts)
- = return (CStr [SymKP (strings s) [Alt (strings u) (strings v) | (u,v) <- alts]])
- where
- strings (K s) = [s]
- strings (C u v) = strings u ++ strings v
- strings (Strs ss) = concatMap strings ss
-convertTerm CNil ctype t = do v <- evalTerm CNil t
- return (CPar v)
-convertTerm _ _ t = error (render (text "convertTerm" <+> parens (ppTerm Unqualified 0 t)))
-
-convertArg :: Term -> Int -> Path -> CnvMonad (Value [Symbol])
-convertArg (RecType rs) nr path =
- mkRecord (map (\(lbl,ctype) -> (lbl,convertArg ctype nr (CProj lbl path))) rs)
-convertArg (Table pt vt) nr path = do
+convertTerm :: Options -> Path -> Type -> Term -> CnvMonad (Value [Symbol])
+convertTerm opts sel ctype (Vr x) = convertArg opts ctype (getVarIndex x) (reversePath sel)
+convertTerm opts sel ctype (Abs _ _ t) = convertTerm opts sel ctype t -- there are only top-level abstractions and we ignore them !!!
+convertTerm opts sel ctype (R record) = convertRec opts sel ctype record
+convertTerm opts sel ctype (P term l) = convertTerm opts (CProj l sel) ctype term
+convertTerm opts sel ctype (V pt ts) = convertTbl opts sel ctype pt ts
+convertTerm opts sel ctype (S term p) = do v <- evalTerm CNil p
+ convertTerm opts (CSel v sel) ctype term
+convertTerm opts sel ctype (FV vars) = do term <- variants vars
+ convertTerm opts sel ctype term
+convertTerm opts sel ctype (C t1 t2) = do v1 <- convertTerm opts sel ctype t1
+ v2 <- convertTerm opts sel ctype t2
+ return (CStr (concat [s | CStr s <- [v1,v2]]))
+convertTerm opts sel ctype (K t) = return (CStr [SymKS [t]])
+convertTerm opts sel ctype Empty = return (CStr [])
+convertTerm opts sel ctype (Alts s alts)
+ = return (CStr [SymKP (strings s) [Alt (strings u) (strings v) | (u,v) <- alts]])
+ where
+ strings (K s) = [s]
+ strings (C u v) = strings u ++ strings v
+ strings (Strs ss) = concatMap strings ss
+convertTerm opts CNil ctype t = do v <- evalTerm CNil t
+ return (CPar v)
+convertTerm _ _ _ t = error (render (text "convertTerm" <+> parens (ppTerm Unqualified 0 t)))
+
+convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol])
+convertArg opts (RecType rs) nr path =
+ mkRecord (map (\(lbl,ctype) -> (lbl,convertArg opts ctype nr (CProj lbl path))) rs)
+convertArg opts (Table pt vt) nr path = do
vs <- getAllParamValues pt
- mkTable pt (map (\v -> (v,convertArg vt nr (CSel v path))) vs)
-convertArg (Sort _) nr path = do
+ mkTable pt (map (\v -> (v,convertArg opts vt nr (CSel v path))) vs)
+convertArg opts (Sort _) nr path = do
(args,_) <- get
let PFCat _ cat schema = args !! nr
l = index (reversePath path) schema
- sym | isLiteralCat cat = SymLit nr l
- | otherwise = SymCat nr l
+ sym | isLiteralCat opts cat = SymLit nr l
+ | otherwise = SymCat nr l
return (CStr [sym])
where
index (CProj lbl path) (CRec rs) = case lookup lbl rs of
@@ -337,26 +339,26 @@ convertArg (Sort _) nr path = do
index (CSel trm path) (CTbl _ rs) = case lookup trm rs of
Just (Identity t) -> index path t
index CNil (CStr idx) = idx
-convertArg ty nr path = do
+convertArg opts ty nr path = do
value <- choices nr (reversePath path)
return (CPar value)
-convertRec CNil (RecType rs) record =
- mkRecord (map (\(lbl,ctype) -> (lbl,convertTerm CNil ctype (projectRec lbl record))) rs)
-convertRec (CProj lbl path) ctype record =
- convertTerm path ctype (projectRec lbl record)
-convertRec _ ctype _ = error ("convertRec: "++show ctype)
+convertRec opts CNil (RecType rs) record =
+ mkRecord (map (\(lbl,ctype) -> (lbl,convertTerm opts CNil ctype (projectRec lbl record))) rs)
+convertRec opts (CProj lbl path) ctype record =
+ convertTerm opts path ctype (projectRec lbl record)
+convertRec opts _ ctype _ = error ("convertRec: "++show ctype)
-convertTbl CNil (Table _ vt) pt ts = do
+convertTbl opts CNil (Table _ vt) pt ts = do
vs <- getAllParamValues pt
- mkTable pt (zipWith (\v t -> (v,convertTerm CNil vt t)) vs ts)
-convertTbl (CSel v sub_sel) ctype pt ts = do
+ mkTable pt (zipWith (\v t -> (v,convertTerm opts CNil vt t)) vs ts)
+convertTbl opts (CSel v sub_sel) ctype pt ts = do
vs <- getAllParamValues pt
case lookup v (zip vs ts) of
- Just t -> convertTerm sub_sel ctype t
+ Just t -> convertTerm opts sub_sel ctype t
Nothing -> error (render (text "convertTbl:" <+> (text "missing value" <+> ppTerm Unqualified 0 v $$
text "among" <+> vcat (map (ppTerm Unqualified 0) vs))))
-convertTbl _ ctype _ _ = error ("convertTbl: "++show ctype)
+convertTbl opts _ ctype _ _ = error ("convertTbl: "++show ctype)
goB :: Branch (Value SeqId) -> Path -> [SeqId] -> BacktrackM Env [SeqId]
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index a5645c26e..a0ccdae12 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -87,8 +87,8 @@ renameIdentTerm env@(act,imps) t =
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
predefAbs c s
- | isLiteralCat c = return $ Q (cPredefAbs,c)
- | otherwise = checkError s
+ | isPredefCat c = return $ Q (cPredefAbs,c)
+ | otherwise = checkError s
ident alt c = case lookupTree showIdent c act of
Ok f -> return $ f c
diff --git a/src/compiler/GF/Data/TrieMap.hs b/src/compiler/GF/Data/TrieMap.hs
index a6749d641..a15c780ab 100644
--- a/src/compiler/GF/Data/TrieMap.hs
+++ b/src/compiler/GF/Data/TrieMap.hs
@@ -11,8 +11,8 @@ module GF.Data.TrieMap
, insertWith
- , unionWith
- , unionsWith
+ , union, unionWith
+ , unions, unionsWith
, elems
) where
@@ -47,6 +47,9 @@ insertWith f (k:ks) v0 (Tr mb_v m) = case Map.lookup k m of
Nothing -> Tr mb_v (Map.insert k (singleton ks v0) m)
Just tr -> Tr mb_v (Map.insert k (insertWith f ks v0 tr) m)
+union :: Ord k => TrieMap k v -> TrieMap k v -> TrieMap k v
+union = unionWith (\a b -> a)
+
unionWith :: Ord k => (v -> v -> v) -> TrieMap k v -> TrieMap k v -> TrieMap k v
unionWith f (Tr mb_v1 m1) (Tr mb_v2 m2) =
let mb_v = case (mb_v1,mb_v2) of
@@ -57,6 +60,9 @@ unionWith f (Tr mb_v1 m1) (Tr mb_v2 m2) =
m = Map.unionWith (unionWith f) m1 m2
in Tr mb_v m
+unions :: Ord k => [TrieMap k v] -> TrieMap k v
+unions = foldl union empty
+
unionsWith :: Ord k => (v -> v -> v) -> [TrieMap k v] -> TrieMap k v
unionsWith f = foldl (unionWith f) empty
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index f942bdcaf..d1473bbcd 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -60,8 +60,8 @@ lookupIdentInfo mo i = lookupIdent i (jments mo)
lookupResDef :: SourceGrammar -> QIdent -> Err Term
lookupResDef gr (m,c)
- | isLiteralCat c = lock c defLinType
- | otherwise = look m c
+ | isPredefCat c = lock c defLinType
+ | otherwise = look m c
where
look m c = do
mo <- lookupModule gr m
@@ -161,7 +161,7 @@ lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c))
_ -> return (Nothing,Nothing)
lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
-lookupLincat gr m c | isLiteralCat c = return defLinType --- ad hoc; not needed?
+lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
lookupLincat gr m c = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
diff --git a/src/compiler/GF/Grammar/Predef.hs b/src/compiler/GF/Grammar/Predef.hs
index f16765433..f9c2c5d18 100644
--- a/src/compiler/GF/Grammar/Predef.hs
+++ b/src/compiler/GF/Grammar/Predef.hs
@@ -25,7 +25,7 @@ module GF.Grammar.Predef
, cErrorType
, cOverload
, cUndefinedType
- , isLiteralCat
+ , isPredefCat
, cPTrue, cPFalse
@@ -92,8 +92,8 @@ cOverload = identC (BS.pack "overload")
cUndefinedType :: Ident
cUndefinedType = identC (BS.pack "UndefinedType")
-isLiteralCat :: Ident -> Bool
-isLiteralCat c = elem c [cInt,cString,cFloat,cVar]
+isPredefCat :: Ident -> Bool
+isPredefCat c = elem c [cInt,cString,cFloat]
cPTrue :: Ident
cPTrue = identC (BS.pack "PTrue")
diff --git a/src/compiler/GF/Grammar/Values.hs b/src/compiler/GF/Grammar/Values.hs
index c5646f5b4..1a68ddc89 100644
--- a/src/compiler/GF/Grammar/Values.hs
+++ b/src/compiler/GF/Grammar/Values.hs
@@ -19,7 +19,7 @@ module GF.Grammar.Values (-- * values used in TC type checking
Binds, Constraints, MetaSubst,
-- * for TC
valAbsInt, valAbsFloat, valAbsString, vType,
- isLiteralCat,
+ isPredefCat,
eType,
--Z tree2exp, loc2treeFocus
) where
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 6c00336de..d76302827 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -17,7 +17,7 @@ module GF.Infra.Option
helpMessage,
-- * Checking specific options
flag, cfgTransform, haskellOption, readOutputFormat,
- isLexicalCat, renameEncoding,
+ isLexicalCat, isLiteralCat, renameEncoding,
-- * Setting specific options
setOptimization, setCFGTransform,
-- * Convenience methods for checking options
@@ -28,7 +28,9 @@ import Control.Monad
import Data.Char (toLower, isDigit)
import Data.List
import Data.Maybe
+import GF.Infra.Ident
import GF.Infra.GetOpt
+import GF.Grammar.Predef
--import System.Console.GetOpt
import System.FilePath
import System.IO
@@ -37,7 +39,7 @@ import GF.Data.ErrM
import Data.Set (Set)
import qualified Data.Set as Set
-
+import qualified Data.ByteString.Char8 as BS
@@ -146,6 +148,7 @@ data Flags = Flags {
optSISR :: Maybe SISRFormat,
optHaskellOptions :: Set HaskellOption,
optLexicalCats :: Set String,
+ optLiteralCats :: Set Ident,
optGFODir :: Maybe FilePath,
optOutputFile :: Maybe FilePath,
optOutputDir :: Maybe FilePath,
@@ -244,6 +247,7 @@ defaultFlags = Flags {
optOutputFormats = [],
optSISR = Nothing,
optHaskellOptions = Set.empty,
+ optLiteralCats = Set.fromList [cString,cInt,cFloat],
optLexicalCats = Set.empty,
optGFODir = Nothing,
optOutputFile = Nothing,
@@ -308,6 +312,8 @@ optDescr =
++ concat (intersperse " | " (map fst haskellOptionNames))),
Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
"Treat CAT as a lexical category.",
+ Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
+ "Treat CAT as a literal category.",
Option ['o'] ["output-file"] (ReqArg outFile "FILE")
"Save output in FILE (default is out.X, where X depends on output format.",
Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
@@ -386,6 +392,7 @@ optDescr =
Just p -> set $ \o -> o { optHaskellOptions = Set.insert p (optHaskellOptions o) }
Nothing -> fail $ "Unknown Haskell option: " ++ x
++ " Known: " ++ show (map fst haskellOptionNames)
+ literalCat x = set $ \o -> o { optLiteralCats = foldr Set.insert (optLiteralCats o) ((map (identC . BS.pack) . splitBy (==',')) x) }
lexicalCat x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
outFile x = set $ \o -> o { optOutputFile = Just x }
outDir x = set $ \o -> o { optOutputDir = Just x }
@@ -536,6 +543,9 @@ cfgTransform opts t = Set.member t (flag optCFGTransforms opts)
haskellOption :: Options -> HaskellOption -> Bool
haskellOption opts o = Set.member o (flag optHaskellOptions opts)
+isLiteralCat :: Options -> Ident -> Bool
+isLiteralCat opts c = Set.member c (flag optLiteralCats opts)
+
isLexicalCat :: Options -> String -> Bool
isLexicalCat opts c = Set.member c (flag optLexicalCats opts)
diff --git a/src/compiler/GF/Speech/VoiceXML.hs b/src/compiler/GF/Speech/VoiceXML.hs
index 9511dde23..f3f05d3d7 100644
--- a/src/compiler/GF/Speech/VoiceXML.hs
+++ b/src/compiler/GF/Speech/VoiceXML.hs
@@ -40,8 +40,7 @@ type Skeleton = [(CId, [(CId, [CId])])]
pgfSkeleton :: PGF -> Skeleton
pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType pgf f))) | f <- fs])
- | (c,(_,fs)) <- Map.toList (cats (abstract pgf)),
- not (isLiteralCat c)]
+ | (c,(_,fs)) <- Map.toList (cats (abstract pgf))]
--
-- * Questions to ask
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:10:02 +0000