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

redesign the open-literals API

Browse Source
This commit is contained in:
krasimir
2010-07-01 08:51:59 +00:00
parent 706b215fce
commit 5ae7be358d
15 changed files with 198 additions and 176 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

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

2
src/compiler/GF/Compile/Abstract/TC.hs
View File

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

2
src/compiler/GF/Compile/ExampleBased.hs
View File

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

92
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

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

4
src/compiler/GF/Compile/Rename.hs
View File

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

10
src/compiler/GF/Data/TrieMap.hs
View File

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

6
src/compiler/GF/Grammar/Lookup.hs
View File

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

6
src/compiler/GF/Grammar/Predef.hs
View File

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

2
src/compiler/GF/Grammar/Values.hs
View File

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

14
src/compiler/GF/Infra/Option.hs
View File

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

3
src/compiler/GF/Speech/VoiceXML.hs
View File

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

2
src/compiler/GFI.hs
View File

@@ -314,7 +314,7 @@ wordCompletion gfenv (left,right) = do
Nothing -> error ("Can't parse '"++str++"' as type")
loop ps [] = Just ps
loop ps (t:ts) = case nextState ps t of
loop ps (t:ts) = case nextState ps (simpleParseInput t) of
Left es -> Nothing
Right ps -> loop ps ts