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 3a5f193fd7
commit e92151caf8
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 _ -> fromExprs ts
where where
(prs,bss) = unzip parses (prs,bss) = unzip parses
ts = [t | ParseResult ts <- prs, t <- ts] ts = [t | ParseOk ts <- prs, t <- ts]
returnFromExprs es = return $ case es of returnFromExprs es = return $ case es of
[] -> ([], "no trees found") [] -> ([], "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 :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)])
inferExp th tenv@(k,rho,gamma) e = case e of inferExp th tenv@(k,rho,gamma) e = case e of
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x 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, []) -> return (ACn (m,c) vType, vType, [])
| otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) | otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
QC c -> mkAnnot (ACn c) $ noConstr $ lookupConst th 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 return ws
TypeError _ _ -> TypeError _ _ ->
return [] return []
ParseResult ts -> ParseOk ts ->
case rank ts of case rank ts of
(t:tt) -> appv ("WARNING: ambiguous example " ++ ex) >> (t:tt) -> appv ("WARNING: ambiguous example " ++ ex) >>
appn t >> mapM_ (appn . (" --- " ++)) tt >> return [] appn t >> mapM_ (appn . (" --- " ++)) tt >> return []

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

@@ -43,7 +43,7 @@ import Control.Exception
convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr convertConcrete :: Options -> SourceGrammar -> SourceModule -> SourceModule -> IO Concr
convertConcrete opts gr am cm = do convertConcrete opts0 gr am cm = do
let env0 = emptyGrammarEnv gr cm let env0 = emptyGrammarEnv gr cm
when (flag optProf opts) $ do when (flag optProf opts) $ do
profileGrammar cm env0 pfrules profileGrammar cm env0 pfrules
@@ -53,6 +53,8 @@ convertConcrete opts gr am cm = do
where where
(m,mo) = cm (m,mo) = cm
opts = addOptions (M.flags (snd am)) opts0
pfrules = [ pfrules = [
(PFRule id args (0,res) (map (\(_,_,ty) -> ty) cont) val term) | (PFRule id args (0,res) (map (\(_,_,ty) -> ty) cont) val term) |
(id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (M.jments mo), (id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (M.jments mo),
@@ -119,7 +121,7 @@ convertRule gr opts grammarEnv (PFRule fun args res ctypes ctype term) = do
let pres = protoFCat grammarEnv res let pres = protoFCat grammarEnv res
pargs = map (protoFCat grammarEnv) args 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 (grammarEnv1,b1) = addSequencesB grammarEnv b
grammarEnv2 = brk (\grammarEnv -> foldBM addRule grammarEnv2 = brk (\grammarEnv -> foldBM addRule
grammarEnv grammarEnv
@@ -293,42 +295,42 @@ reversePath path = rev CNil path
type Value a = Schema Branch a Term type Value a = Schema Branch a Term
convertTerm :: Path -> Type -> Term -> CnvMonad (Value [Symbol]) convertTerm :: Options -> Path -> Type -> Term -> CnvMonad (Value [Symbol])
convertTerm sel ctype (Vr x) = convertArg ctype (getVarIndex x) (reversePath sel) convertTerm opts sel ctype (Vr x) = convertArg opts 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 opts sel ctype (Abs _ _ t) = convertTerm opts sel ctype t -- there are only top-level abstractions and we ignore them !!!
convertTerm sel ctype (R record) = convertRec sel ctype record convertTerm opts sel ctype (R record) = convertRec opts sel ctype record
convertTerm sel ctype (P term l) = convertTerm (CProj l sel) ctype term convertTerm opts sel ctype (P term l) = convertTerm opts (CProj l sel) ctype term
convertTerm sel ctype (V pt ts) = convertTbl sel ctype pt ts convertTerm opts sel ctype (V pt ts) = convertTbl opts sel ctype pt ts
convertTerm sel ctype (S term p) = do v <- evalTerm CNil p convertTerm opts sel ctype (S term p) = do v <- evalTerm CNil p
convertTerm (CSel v sel) ctype term convertTerm opts (CSel v sel) ctype term
convertTerm sel ctype (FV vars) = do term <- variants vars convertTerm opts sel ctype (FV vars) = do term <- variants vars
convertTerm sel ctype term convertTerm opts sel ctype term
convertTerm sel ctype (C t1 t2) = do v1 <- convertTerm sel ctype t1 convertTerm opts sel ctype (C t1 t2) = do v1 <- convertTerm opts sel ctype t1
v2 <- convertTerm sel ctype t2 v2 <- convertTerm opts sel ctype t2
return (CStr (concat [s | CStr s <- [v1,v2]])) return (CStr (concat [s | CStr s <- [v1,v2]]))
convertTerm sel ctype (K t) = return (CStr [SymKS [t]]) convertTerm opts sel ctype (K t) = return (CStr [SymKS [t]])
convertTerm sel ctype Empty = return (CStr []) convertTerm opts sel ctype Empty = return (CStr [])
convertTerm sel ctype (Alts s alts) convertTerm opts sel ctype (Alts s alts)
= return (CStr [SymKP (strings s) [Alt (strings u) (strings v) | (u,v) <- alts]]) = return (CStr [SymKP (strings s) [Alt (strings u) (strings v) | (u,v) <- alts]])
where where
strings (K s) = [s] strings (K s) = [s]
strings (C u v) = strings u ++ strings v strings (C u v) = strings u ++ strings v
strings (Strs ss) = concatMap strings ss strings (Strs ss) = concatMap strings ss
convertTerm CNil ctype t = do v <- evalTerm CNil t convertTerm opts CNil ctype t = do v <- evalTerm CNil t
return (CPar v) return (CPar v)
convertTerm _ _ t = error (render (text "convertTerm" <+> parens (ppTerm Unqualified 0 t))) convertTerm _ _ _ t = error (render (text "convertTerm" <+> parens (ppTerm Unqualified 0 t)))
convertArg :: Term -> Int -> Path -> CnvMonad (Value [Symbol]) convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol])
convertArg (RecType rs) nr path = convertArg opts (RecType rs) nr path =
mkRecord (map (\(lbl,ctype) -> (lbl,convertArg ctype nr (CProj lbl path))) rs) mkRecord (map (\(lbl,ctype) -> (lbl,convertArg opts ctype nr (CProj lbl path))) rs)
convertArg (Table pt vt) nr path = do convertArg opts (Table pt vt) nr path = do
vs <- getAllParamValues pt vs <- getAllParamValues pt
mkTable pt (map (\v -> (v,convertArg vt nr (CSel v path))) vs) mkTable pt (map (\v -> (v,convertArg opts vt nr (CSel v path))) vs)
convertArg (Sort _) nr path = do convertArg opts (Sort _) nr path = do
(args,_) <- get (args,_) <- get
let PFCat _ cat schema = args !! nr let PFCat _ cat schema = args !! nr
l = index (reversePath path) schema l = index (reversePath path) schema
sym | isLiteralCat cat = SymLit nr l sym | isLiteralCat opts cat = SymLit nr l
| otherwise = SymCat nr l | otherwise = SymCat nr l
return (CStr [sym]) return (CStr [sym])
where where
@@ -337,26 +339,26 @@ convertArg (Sort _) nr path = do
index (CSel trm path) (CTbl _ rs) = case lookup trm rs of index (CSel trm path) (CTbl _ rs) = case lookup trm rs of
Just (Identity t) -> index path t Just (Identity t) -> index path t
index CNil (CStr idx) = idx index CNil (CStr idx) = idx
convertArg ty nr path = do convertArg opts ty nr path = do
value <- choices nr (reversePath path) value <- choices nr (reversePath path)
return (CPar value) return (CPar value)
convertRec CNil (RecType rs) record = convertRec opts CNil (RecType rs) record =
mkRecord (map (\(lbl,ctype) -> (lbl,convertTerm CNil ctype (projectRec lbl record))) rs) mkRecord (map (\(lbl,ctype) -> (lbl,convertTerm opts CNil ctype (projectRec lbl record))) rs)
convertRec (CProj lbl path) ctype record = convertRec opts (CProj lbl path) ctype record =
convertTerm path ctype (projectRec lbl record) convertTerm opts path ctype (projectRec lbl record)
convertRec _ ctype _ = error ("convertRec: "++show ctype) 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 vs <- getAllParamValues pt
mkTable pt (zipWith (\v t -> (v,convertTerm CNil vt t)) vs ts) mkTable pt (zipWith (\v t -> (v,convertTerm opts CNil vt t)) vs ts)
convertTbl (CSel v sub_sel) ctype pt ts = do convertTbl opts (CSel v sub_sel) ctype pt ts = do
vs <- getAllParamValues pt vs <- getAllParamValues pt
case lookup v (zip vs ts) of 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 $$ Nothing -> error (render (text "convertTbl:" <+> (text "missing value" <+> ppTerm Unqualified 0 v $$
text "among" <+> vcat (map (ppTerm Unqualified 0) vs)))) 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] goB :: Branch (Value SeqId) -> Path -> [SeqId] -> BacktrackM Env [SeqId]

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

@@ -87,7 +87,7 @@ renameIdentTerm env@(act,imps) t =
-- this facility is mainly for BWC with GF1: you need not import PredefAbs -- this facility is mainly for BWC with GF1: you need not import PredefAbs
predefAbs c s predefAbs c s
| isLiteralCat c = return $ Q (cPredefAbs,c) | isPredefCat c = return $ Q (cPredefAbs,c)
| otherwise = checkError s | otherwise = checkError s
ident alt c = case lookupTree showIdent c act of ident alt c = case lookupTree showIdent c act of

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

@@ -11,8 +11,8 @@ module GF.Data.TrieMap
, insertWith , insertWith
, unionWith , union, unionWith
, unionsWith , unions, unionsWith
, elems , elems
) where ) 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) 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) 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 :: Ord k => (v -> v -> v) -> TrieMap k v -> TrieMap k v -> TrieMap k v
unionWith f (Tr mb_v1 m1) (Tr mb_v2 m2) = unionWith f (Tr mb_v1 m1) (Tr mb_v2 m2) =
let mb_v = case (mb_v1,mb_v2) of 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 m = Map.unionWith (unionWith f) m1 m2
in Tr mb_v m 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 :: Ord k => (v -> v -> v) -> [TrieMap k v] -> TrieMap k v
unionsWith f = foldl (unionWith f) empty unionsWith f = foldl (unionWith f) empty

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

@@ -60,7 +60,7 @@ lookupIdentInfo mo i = lookupIdent i (jments mo)
lookupResDef :: SourceGrammar -> QIdent -> Err Term lookupResDef :: SourceGrammar -> QIdent -> Err Term
lookupResDef gr (m,c) lookupResDef gr (m,c)
| isLiteralCat c = lock c defLinType | isPredefCat c = lock c defLinType
| otherwise = look m c | otherwise = look m c
where where
look m c = do look m c = do
@@ -161,7 +161,7 @@ lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c))
_ -> return (Nothing,Nothing) _ -> return (Nothing,Nothing)
lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type 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 lookupLincat gr m c = do
mo <- lookupModule gr m mo <- lookupModule gr m
info <- lookupIdentInfo mo c info <- lookupIdentInfo mo c

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

@@ -25,7 +25,7 @@ module GF.Grammar.Predef
, cErrorType , cErrorType
, cOverload , cOverload
, cUndefinedType , cUndefinedType
, isLiteralCat , isPredefCat
, cPTrue, cPFalse , cPTrue, cPFalse
@@ -92,8 +92,8 @@ cOverload = identC (BS.pack "overload")
cUndefinedType :: Ident cUndefinedType :: Ident
cUndefinedType = identC (BS.pack "UndefinedType") cUndefinedType = identC (BS.pack "UndefinedType")
isLiteralCat :: Ident -> Bool isPredefCat :: Ident -> Bool
isLiteralCat c = elem c [cInt,cString,cFloat,cVar] isPredefCat c = elem c [cInt,cString,cFloat]
cPTrue :: Ident cPTrue :: Ident
cPTrue = identC (BS.pack "PTrue") 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, Binds, Constraints, MetaSubst,
-- * for TC -- * for TC
valAbsInt, valAbsFloat, valAbsString, vType, valAbsInt, valAbsFloat, valAbsString, vType,
isLiteralCat, isPredefCat,
eType, eType,
--Z tree2exp, loc2treeFocus --Z tree2exp, loc2treeFocus
) where ) where

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

@@ -17,7 +17,7 @@ module GF.Infra.Option
helpMessage, helpMessage,
-- * Checking specific options -- * Checking specific options
flag, cfgTransform, haskellOption, readOutputFormat, flag, cfgTransform, haskellOption, readOutputFormat,
isLexicalCat, renameEncoding, isLexicalCat, isLiteralCat, renameEncoding,
-- * Setting specific options -- * Setting specific options
setOptimization, setCFGTransform, setOptimization, setCFGTransform,
-- * Convenience methods for checking options -- * Convenience methods for checking options
@@ -28,7 +28,9 @@ import Control.Monad
import Data.Char (toLower, isDigit) import Data.Char (toLower, isDigit)
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import GF.Infra.Ident
import GF.Infra.GetOpt import GF.Infra.GetOpt
import GF.Grammar.Predef
--import System.Console.GetOpt --import System.Console.GetOpt
import System.FilePath import System.FilePath
import System.IO import System.IO
@@ -37,7 +39,7 @@ import GF.Data.ErrM
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as BS
@@ -146,6 +148,7 @@ data Flags = Flags {
optSISR :: Maybe SISRFormat, optSISR :: Maybe SISRFormat,
optHaskellOptions :: Set HaskellOption, optHaskellOptions :: Set HaskellOption,
optLexicalCats :: Set String, optLexicalCats :: Set String,
optLiteralCats :: Set Ident,
optGFODir :: Maybe FilePath, optGFODir :: Maybe FilePath,
optOutputFile :: Maybe FilePath, optOutputFile :: Maybe FilePath,
optOutputDir :: Maybe FilePath, optOutputDir :: Maybe FilePath,
@@ -244,6 +247,7 @@ defaultFlags = Flags {
optOutputFormats = [], optOutputFormats = [],
optSISR = Nothing, optSISR = Nothing,
optHaskellOptions = Set.empty, optHaskellOptions = Set.empty,
optLiteralCats = Set.fromList [cString,cInt,cFloat],
optLexicalCats = Set.empty, optLexicalCats = Set.empty,
optGFODir = Nothing, optGFODir = Nothing,
optOutputFile = Nothing, optOutputFile = Nothing,
@@ -308,6 +312,8 @@ optDescr =
++ concat (intersperse " | " (map fst haskellOptionNames))), ++ concat (intersperse " | " (map fst haskellOptionNames))),
Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
"Treat CAT as a lexical category.", "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") Option ['o'] ["output-file"] (ReqArg outFile "FILE")
"Save output in FILE (default is out.X, where X depends on output format.", "Save output in FILE (default is out.X, where X depends on output format.",
Option ['D'] ["output-dir"] (ReqArg outDir "DIR") Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
@@ -386,6 +392,7 @@ optDescr =
Just p -> set $ \o -> o { optHaskellOptions = Set.insert p (optHaskellOptions o) } Just p -> set $ \o -> o { optHaskellOptions = Set.insert p (optHaskellOptions o) }
Nothing -> fail $ "Unknown Haskell option: " ++ x Nothing -> fail $ "Unknown Haskell option: " ++ x
++ " Known: " ++ show (map fst haskellOptionNames) ++ " 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) } lexicalCat x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
outFile x = set $ \o -> o { optOutputFile = Just x } outFile x = set $ \o -> o { optOutputFile = Just x }
outDir x = set $ \o -> o { optOutputDir = 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 :: Options -> HaskellOption -> Bool
haskellOption opts o = Set.member o (flag optHaskellOptions opts) 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 :: Options -> String -> Bool
isLexicalCat opts c = Set.member c (flag optLexicalCats opts) 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 -> Skeleton
pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType pgf f))) | f <- fs]) pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType pgf f))) | f <- fs])
| (c,(_,fs)) <- Map.toList (cats (abstract pgf)), | (c,(_,fs)) <- Map.toList (cats (abstract pgf))]
not (isLiteralCat c)]
-- --
-- * Questions to ask -- * 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") Nothing -> error ("Can't parse '"++str++"' as type")
loop ps [] = Just ps 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 Left es -> Nothing
Right ps -> loop ps ts Right ps -> loop ps ts

18
src/runtime/haskell/PGF.hs
View File

@@ -80,8 +80,8 @@ module PGF(
complete, complete,
Parse.ParseState, Parse.ParseState,
Parse.initState, Parse.nextState, Parse.getCompletions, Parse.recoveryStates, Parse.initState, Parse.nextState, Parse.getCompletions, Parse.recoveryStates,
Parse.acceptsLiteral, Parse.feedLiteral, Parse.ParseInput(..), Parse.simpleParseInput, Parse.mkParseInput,
Parse.ParseResult(..), Parse.getParseResult, Parse.ParseOutput(..), Parse.getParseOutput,
-- ** Generation -- ** Generation
generateRandom, generateAll, generateAllDepth, generateRandom, generateAll, generateAllDepth,
@@ -155,10 +155,10 @@ parseAll :: PGF -> Type -> String -> [[Tree]]
parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])] parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])]
-- | The same as 'parse' but returns more detailed information -- | The same as 'parse' but returns more detailed information
parse_ :: PGF -> Language -> Type -> String -> (Parse.ParseResult,BracketedString) parse_ :: PGF -> Language -> Type -> String -> (Parse.ParseOutput,BracketedString)
-- | This is an experimental function. Use it on your own risk -- | This is an experimental function. Use it on your own risk
parseWithRecovery :: PGF -> Language -> Type -> [Type] -> String -> (Parse.ParseResult,BracketedString) parseWithRecovery :: PGF -> Language -> Type -> [Type] -> String -> (Parse.ParseOutput,BracketedString)
-- | The same as 'generateAllDepth' but does not limit -- | The same as 'generateAllDepth' but does not limit
-- the depth in the generation, and doesn't give an initial expression. -- the depth in the generation, and doesn't give an initial expression.
@@ -223,13 +223,13 @@ readPGF f = decodeFile f
parse pgf lang typ s = parse pgf lang typ s =
case parse_ pgf lang typ s of case parse_ pgf lang typ s of
(Parse.ParseResult ts,_) -> ts (Parse.ParseOk ts,_) -> ts
_ -> [] _ -> []
parseAll mgr typ = map snd . parseAllLang mgr typ parseAll mgr typ = map snd . parseAllLang mgr typ
parseAllLang mgr typ s = parseAllLang mgr typ s =
[(lang,ts) | lang <- languages mgr, (Parse.ParseResult ts,_) <- [parse_ mgr lang typ s]] [(lang,ts) | lang <- languages mgr, (Parse.ParseOk ts,_) <- [parse_ mgr lang typ s]]
parse_ pgf lang typ s = parse_ pgf lang typ s =
case Map.lookup lang (concretes pgf) of case Map.lookup lang (concretes pgf) of
@@ -281,8 +281,8 @@ complete pgf from typ input =
++ [unwords (ws++[c]) ++ " " | c <- Map.keys (Parse.getCompletions state prefix)] ++ [unwords (ws++[c]) ++ " " | c <- Map.keys (Parse.getCompletions state prefix)]
where where
isSuccessful state = isSuccessful state =
case Parse.getParseResult state typ of case Parse.getParseOutput state typ of
(Parse.ParseResult ts, _) -> not (null ts) (Parse.ParseOk ts, _) -> not (null ts)
_ -> False _ -> False
tokensAndPrefix :: String -> ([String],String) tokensAndPrefix :: String -> ([String],String)
@@ -292,7 +292,7 @@ complete pgf from typ input =
where ws = words s where ws = words s
loop ps [] = Just ps loop ps [] = Just ps
loop ps (t:ts) = case Parse.nextState ps t of loop ps (t:ts) = case Parse.nextState ps (Parse.simpleParseInput t) of
Left es -> Nothing Left es -> Nothing
Right ps -> loop ps ts Right ps -> loop ps ts

5
src/runtime/haskell/PGF/Macros.hs
View File

@@ -48,7 +48,7 @@ lookGlobalFlag pgf f = Map.lookup f (gflags pgf)
lookAbsFlag :: PGF -> CId -> Maybe Literal lookAbsFlag :: PGF -> CId -> Maybe Literal
lookAbsFlag pgf f = Map.lookup f (aflags (abstract pgf)) lookAbsFlag pgf f = Map.lookup f (aflags (abstract pgf))
lookConcr :: PGF -> CId -> Concr lookConcr :: PGF -> Language -> Concr
lookConcr pgf cnc = lookConcr pgf cnc =
lookMap (error $ "Missing concrete syntax: " ++ showCId cnc) cnc $ concretes pgf lookMap (error $ "Missing concrete syntax: " ++ showCId cnc) cnc $ concretes pgf
@@ -127,9 +127,6 @@ combinations t = case t of
[] -> [[]] [] -> [[]]
aa:uu -> [a:u | a <- aa, u <- combinations uu] aa:uu -> [a:u | a <- aa, u <- combinations uu]
isLiteralCat :: CId -> Bool
isLiteralCat = (`elem` [cidString, cidFloat, cidInt, cidVar])
cidString = mkCId "String" cidString = mkCId "String"
cidInt = mkCId "Int" cidInt = mkCId "Int"
cidFloat = mkCId "Float" cidFloat = mkCId "Float"

186
src/runtime/haskell/PGF/Parse.hs
View File

@@ -5,10 +5,9 @@ module PGF.Parse
, initState , initState
, nextState , nextState
, getCompletions , getCompletions
, acceptsLiteral
, feedLiteral
, recoveryStates , recoveryStates
, ParseResult(..), getParseResult , ParseInput(..), simpleParseInput, mkParseInput
, ParseOutput(..), getParseOutput
, parse , parse
, parseWithRecovery , parseWithRecovery
) where ) where
@@ -31,34 +30,45 @@ import PGF.Macros
import PGF.TypeCheck import PGF.TypeCheck
import PGF.Forest(Forest(Forest), linearizeWithBrackets, foldForest) import PGF.Forest(Forest(Forest), linearizeWithBrackets, foldForest)
-- | The input to the parser is a pair of predicates. The first one
-- 'piToken' checks that a given token, suggested by the grammar,
-- actually appears at the current position in the input string.
-- The second one 'piLiteral' recognizes whether a literal with forest id 'FId'
-- could be matched at the current position.
data ParseInput
= ParseInput
{ piToken :: Token -> Bool
, piLiteral :: FId -> Maybe (CId,Tree,[Token])
}
-- | This data type encodes the different outcomes which you could get from the parser. -- | This data type encodes the different outcomes which you could get from the parser.
data ParseResult data ParseOutput
= ParseFailed Int -- ^ The integer is the position in number of tokens where the parser failed. = ParseFailed Int -- ^ The integer is the position in number of tokens where the parser failed.
| TypeError FId [TcError] -- ^ The parsing was successful but none of the trees is type correct. | TypeError FId [TcError] -- ^ The parsing was successful but none of the trees is type correct.
-- The forest id ('FId') points to the bracketed string from the parser -- The forest id ('FId') points to the bracketed string from the parser
-- where the type checking failed. More than one error is returned -- where the type checking failed. More than one error is returned
-- if there are many analizes for some phrase but they all are not type correct. -- if there are many analizes for some phrase but they all are not type correct.
| ParseResult [Tree] -- ^ If the parsing was successful we get a list of abstract syntax trees. The list should be non-empty. | ParseOk [Tree] -- ^ If the parsing was successful we get a list of abstract syntax trees. The list should be non-empty.
parse :: PGF -> Language -> Type -> [String] -> (ParseResult,BracketedString) parse :: PGF -> Language -> Type -> [Token] -> (ParseOutput,BracketedString)
parse pgf lang typ toks = loop (initState pgf lang typ) toks parse pgf lang typ toks = loop (initState pgf lang typ) toks
where where
loop ps [] = getParseResult ps typ loop ps [] = getParseOutput ps typ
loop ps (t:ts) = case nextState ps t of loop ps (t:ts) = case nextState ps (simpleParseInput t) of
Left es -> case es of Left es -> case es of
EState _ _ chart -> (ParseFailed (offset chart),snd (getParseResult ps typ)) EState _ _ chart -> (ParseFailed (offset chart),snd (getParseOutput ps typ))
Right ps -> loop ps ts Right ps -> loop ps ts
parseWithRecovery :: PGF -> Language -> Type -> [Type] -> [String] -> (ParseResult,BracketedString) parseWithRecovery :: PGF -> Language -> Type -> [Type] -> [String] -> (ParseOutput,BracketedString)
parseWithRecovery pgf lang typ open_typs toks = accept (initState pgf lang typ) toks parseWithRecovery pgf lang typ open_typs toks = accept (initState pgf lang typ) toks
where where
accept ps [] = getParseResult ps typ accept ps [] = getParseOutput ps typ
accept ps (t:ts) = accept ps (t:ts) =
case nextState ps t of case nextState ps (simpleParseInput t) of
Right ps -> accept ps ts Right ps -> accept ps ts
Left es -> skip (recoveryStates open_typs es) ts Left es -> skip (recoveryStates open_typs es) ts
skip ps_map [] = getParseResult (fst ps_map) typ skip ps_map [] = getParseOutput (fst ps_map) typ
skip ps_map (t:ts) = skip ps_map (t:ts) =
case Map.lookup t (snd ps_map) of case Map.lookup t (snd ps_map) of
Just ps -> accept ps ts Just ps -> accept ps ts
@@ -84,17 +94,52 @@ initState pgf lang (DTyp _ start _) =
(Chart emptyAC [] emptyPC (pproductions cnc) (totalCats cnc) 0) (Chart emptyAC [] emptyPC (pproductions cnc) (totalCats cnc) 0)
(TMap.singleton [] (Set.fromList items)) (TMap.singleton [] (Set.fromList items))
-- | This function constructs the simplest possible parser input.
-- It checks the tokens for exact matching and recognizes only @String@, @Int@ and @Float@ literals.
-- The @Int@ and @Float@ literals matche only if the token passed is some number.
-- The @String@ literal always match but the length of the literal could be only one token.
simpleParseInput :: Token -> ParseInput
simpleParseInput t = ParseInput (==t) (matchLit t)
where
matchLit t fid
| fid == fidString = Just (cidString,ELit (LStr t),[t])
| fid == fidInt = case reads t of {[(n,"")] -> Just (cidInt,ELit (LInt n),[t]);
_ -> Nothing }
| fid == fidFloat = case reads t of {[(d,"")] -> Just (cidFloat,ELit (LFlt d),[t]);
_ -> Nothing }
| fid == fidVar = Just (cidVar,EFun (mkCId t),[t])
| otherwise = Nothing
mkParseInput :: PGF -> Language -> (a -> Token -> Bool) -> [(CId,a -> Maybe (Tree,[Token]))] -> a -> ParseInput
mkParseInput pgf lang ftok flits = \x -> ParseInput (ftok x) (flit x)
where
flit = mk flits
cnc = lookConcr pgf lang
mk [] = \x fid -> Nothing
mk ((c,flit):flits) = \x fid -> if match fid
then fmap (\(tree,toks) -> (c,tree,toks)) (flit x)
else flit' x fid
where
flit' = mk flits
match fid =
case Map.lookup c (cnccats cnc) of
Just (CncCat s e _) -> inRange (s,e) fid
Nothing -> False
-- | From the current state and the next token -- | From the current state and the next token
-- 'nextState' computes a new state, where the token -- 'nextState' computes a new state, where the token
-- is consumed and the current position is shifted by one. -- is consumed and the current position is shifted by one.
-- If the new token cannot be accepted then an error state -- If the new token cannot be accepted then an error state
-- is returned. -- is returned.
nextState :: ParseState -> Token -> Either ErrorState ParseState nextState :: ParseState -> ParseInput -> Either ErrorState ParseState
nextState (PState pgf cnc chart items) t = nextState (PState pgf cnc chart items) input =
let (mb_agenda,map_items) = TMap.decompose items let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda agenda = maybe [] Set.toList mb_agenda
acc = fromMaybe TMap.empty (Map.lookup t map_items) acc = TMap.unions [tmap | (t,tmap) <- Map.toList map_items, piToken input t]
(acc1,chart1) = process (litCatMatch (Just t)) add (sequences cnc) (cncfuns cnc) agenda acc chart (acc1,chart1) = process flit ftok (sequences cnc) (cncfuns cnc) agenda acc chart
chart2 = chart1{ active =emptyAC chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1 , actives=active chart1 : actives chart1
, passive=emptyPC , passive=emptyPC
@@ -104,44 +149,12 @@ nextState (PState pgf cnc chart items) t =
then Left (EState pgf cnc chart2) then Left (EState pgf cnc chart2)
else Right (PState pgf cnc chart2 acc1) else Right (PState pgf cnc chart2 acc1)
where where
add (tok:toks) item acc flit = piLiteral input
| tok == t = TMap.insertWith Set.union toks (Set.singleton item) acc
add _ item acc = acc
acceptsLiteral :: ParseState -> Type -> Bool ftok (tok:toks) item acc
acceptsLiteral (PState pgf cnc chart items) (DTyp _ cat _) = | piToken input tok = TMap.insertWith Set.union toks (Set.singleton item) acc
case Map.lookup cat (cnccats cnc) of ftok _ item acc = acc
Just (CncCat s e _) -> or [IntMap.member fid (active chart1) | fid <- [s..e]]
Nothing -> False
where
(mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda
(acc1,chart1) = process (litCatMatch Nothing) add (sequences cnc) (cncfuns cnc) agenda TMap.empty chart
add (tok:toks) item acc = acc
feedLiteral :: ParseState -> Expr -> Either ErrorState ParseState
feedLiteral (PState pgf cnc chart items) (ELit lit) =
let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda
(acc1,chart1) = process (magic lit) add (sequences cnc) (cncfuns cnc) agenda TMap.empty chart
chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1
, passive=emptyPC
, offset =offset chart1+1
}
in if TMap.null acc1
then Left (EState pgf cnc chart2)
else Right (PState pgf cnc chart2 acc1)
where
add toks item acc = TMap.insertWith Set.union toks (Set.singleton item) acc
magic lit fid =
case lit of
LStr s | fid == fidString -> Just (cidString, ELit lit, words s)
LInt n | fid == fidInt -> Just (cidInt, ELit lit, [show n])
LFlt d | fid == fidFloat -> Just (cidFloat, ELit lit, [show d])
_ -> Nothing
-- | If the next token is not known but only its prefix (possible empty prefix) -- | If the next token is not known but only its prefix (possible empty prefix)
-- then the 'getCompletions' function can be used to calculate the possible -- then the 'getCompletions' function can be used to calculate the possible
@@ -152,7 +165,7 @@ getCompletions (PState pgf cnc chart items) w =
let (mb_agenda,map_items) = TMap.decompose items let (mb_agenda,map_items) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda agenda = maybe [] Set.toList mb_agenda
acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items
(acc',chart1) = process (litCatMatch Nothing) add (sequences cnc) (cncfuns cnc) agenda acc chart (acc',chart1) = process flit ftok (sequences cnc) (cncfuns cnc) agenda acc chart
chart2 = chart1{ active =emptyAC chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1 , actives=active chart1 : actives chart1
, passive=emptyPC , passive=emptyPC
@@ -160,15 +173,17 @@ getCompletions (PState pgf cnc chart items) w =
} }
in fmap (PState pgf cnc chart2) acc' in fmap (PState pgf cnc chart2) acc'
where where
add (tok:toks) item acc flit _ = Nothing
ftok (tok:toks) item acc
| isPrefixOf w tok = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc | isPrefixOf w tok = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc
add _ item acc = acc ftok _ item acc = acc
recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map Token ParseState) recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map Token ParseState)
recoveryStates open_types (EState pgf cnc chart) = recoveryStates open_types (EState pgf cnc chart) =
let open_fcats = concatMap type2fcats open_types let open_fcats = concatMap type2fcats open_types
agenda = foldl (complete open_fcats) [] (actives chart) agenda = foldl (complete open_fcats) [] (actives chart)
(acc,chart1) = process (litCatMatch Nothing) add (sequences cnc) (cncfuns cnc) agenda Map.empty chart (acc,chart1) = process flit ftok (sequences cnc) (cncfuns cnc) agenda Map.empty chart
chart2 = chart1{ active =emptyAC chart2 = chart1{ active =emptyAC
, actives=active chart1 : actives chart1 , actives=active chart1 : actives chart1
, passive=emptyPC , passive=emptyPC
@@ -186,14 +201,15 @@ recoveryStates open_types (EState pgf cnc chart) =
items items
[set | fcat <- open_fcats, set <- lookupACByFCat fcat ac] [set | fcat <- open_fcats, set <- lookupACByFCat fcat ac]
add (tok:toks) item acc = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc flit _ = Nothing
ftok (tok:toks) item acc = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc
-- | This function extracts the list of all completed parse trees -- | This function extracts the list of all completed parse trees
-- that spans the whole input consumed so far. The trees are also -- that spans the whole input consumed so far. The trees are also
-- limited by the category specified, which is usually -- limited by the category specified, which is usually
-- the same as the startup category. -- the same as the startup category.
getParseResult :: ParseState -> Type -> (ParseResult,BracketedString) getParseOutput :: ParseState -> Type -> (ParseOutput,BracketedString)
getParseResult (PState pgf cnc chart items) ty@(DTyp _ start _) = getParseOutput (PState pgf cnc chart items) ty@(DTyp _ start _) =
let froots | null roots = getPartialSeq (sequences cnc) (reverse (active st : actives st)) acc1 let froots | null roots = getPartialSeq (sequences cnc) (reverse (active st : actives st)) acc1
| otherwise = [([SymCat 0 lbl],[fid]) | AK fid lbl <- roots] | otherwise = [([SymCat 0 lbl],[fid]) | AK fid lbl <- roots]
@@ -209,15 +225,16 @@ getParseResult (PState pgf cnc chart items) ty@(DTyp _ start _) =
res = if null exps res = if null exps
then ParseFailed (offset chart) then ParseFailed (offset chart)
else ParseResult exps else ParseOk exps
in (res,bs) in (res,bs)
where where
(mb_agenda,acc) = TMap.decompose items (mb_agenda,acc) = TMap.decompose items
agenda = maybe [] Set.toList mb_agenda agenda = maybe [] Set.toList mb_agenda
(acc1,st) = process (litCatMatch Nothing) add (sequences cnc) (cncfuns cnc) agenda [] chart (acc1,st) = process flit ftok (sequences cnc) (cncfuns cnc) agenda [] chart
add _ (Active j ppos funid seqid args key) items = (j,lin,args,key) : items flit _ = Nothing
ftok _ (Active j ppos funid seqid args key) items = (j,lin,args,key) : items
where where
lin = take (ppos-1) (elems (unsafeAt (sequences cnc) seqid)) lin = take (ppos-1) (elems (unsafeAt (sequences cnc) seqid))
@@ -274,8 +291,8 @@ getPartialSeq seqs actives = expand Set.empty
inc n (SymLit d r) = SymLit (n+d) r inc n (SymLit d r) = SymLit (n+d) r
inc n s = s inc n s = s
process mbt fn !seqs !funs [] acc chart = (acc,chart) process flit ftok !seqs !funs [] acc chart = (acc,chart)
process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart process flit ftok !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart
| inRange (bounds lin) ppos = | inRange (bounds lin) ppos =
case unsafeAt lin ppos of case unsafeAt lin ppos of
SymCat d r -> let !fid = args !! d SymCat d r -> let !fid = args !! d
@@ -288,15 +305,15 @@ process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) ac
(\_ _ items -> items) (\_ _ items -> items)
items2 fid (forest chart) items2 fid (forest chart)
in case lookupAC key (active chart) of in case lookupAC key (active chart) of
Nothing -> process mbt fn seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)} Nothing -> process flit ftok seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)}
Just set | Set.member item set -> process mbt fn seqs funs items acc chart Just set | Set.member item set -> process flit ftok seqs funs items acc chart
| otherwise -> process mbt fn seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)} | otherwise -> process flit ftok seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)}
SymKS toks -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc SymKS toks -> let !acc' = ftok toks (Active j (ppos+1) funid seqid args key0) acc
in process mbt fn seqs funs items acc' chart in process flit ftok seqs funs items acc' chart
SymKP strs vars SymKP strs vars
-> let !acc' = foldl (\acc toks -> fn toks (Active j (ppos+1) funid seqid args key0) acc) acc -> let !acc' = foldl (\acc toks -> ftok toks (Active j (ppos+1) funid seqid args key0) acc) acc
(strs:[strs' | Alt strs' _ <- vars]) (strs:[strs' | Alt strs' _ <- vars])
in process mbt fn seqs funs items acc' chart in process flit ftok seqs funs items acc' chart
SymLit d r -> let fid = args !! d SymLit d r -> let fid = args !! d
key = AK fid r key = AK fid r
!fid' = case lookupPC (mkPK key k) (passive chart) of !fid' = case lookupPC (mkPK key k) (passive chart) of
@@ -304,17 +321,17 @@ process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) ac
Just fid -> fid Just fid -> fid
in case [ts | PConst _ _ ts <- maybe [] Set.toList (IntMap.lookup fid' (forest chart))] of in case [ts | PConst _ _ ts <- maybe [] Set.toList (IntMap.lookup fid' (forest chart))] of
(toks:_) -> let !acc' = fn toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc (toks:_) -> let !acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc
in process mbt fn seqs funs items acc' chart in process flit ftok seqs funs items acc' chart
[] -> case mbt fid of [] -> case flit fid of
Just (cat,lit,toks) Just (cat,lit,toks)
-> let fid' = nextId chart -> let fid' = nextId chart
!acc' = fn toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc !acc' = ftok toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc
in process mbt fn seqs funs items acc' chart{passive=insertPC (mkPK key k) fid' (passive chart) in process flit ftok seqs funs items acc' chart{passive=insertPC (mkPK key k) fid' (passive chart)
,forest =IntMap.insert fid' (Set.singleton (PConst cat lit toks)) (forest chart) ,forest =IntMap.insert fid' (Set.singleton (PConst cat lit toks)) (forest chart)
,nextId =nextId chart+1 ,nextId =nextId chart+1
} }
Nothing -> process mbt fn seqs funs items acc chart{active=insertAC key (Set.singleton item) (active chart)} Nothing -> process flit ftok seqs funs items acc chart{active=insertAC key (Set.singleton item) (active chart)}
| otherwise = | otherwise =
case lookupPC (mkPK key0 j) (passive chart) of case lookupPC (mkPK key0 j) (passive chart) of
Nothing -> let fid = nextId chart Nothing -> let fid = nextId chart
@@ -324,12 +341,12 @@ process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) ac
Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) -> Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) ->
let SymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos let SymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos
in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set
in process mbt fn seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart) in process flit ftok seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart)
,forest =IntMap.insert fid (Set.singleton (PApply funid args)) (forest chart) ,forest =IntMap.insert fid (Set.singleton (PApply funid args)) (forest chart)
,nextId =nextId chart+1 ,nextId =nextId chart+1
} }
Just id -> let items2 = [Active k 0 funid (rhs funid r) args (AK id r) | r <- labelsAC id (active chart)] ++ items Just id -> let items2 = [Active k 0 funid (rhs funid r) args (AK id r) | r <- labelsAC id (active chart)] ++ items
in process mbt fn seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (PApply funid args)) (forest chart)} in process flit ftok seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (PApply funid args)) (forest chart)}
where where
!lin = unsafeAt seqs seqid !lin = unsafeAt seqs seqid
!k = offset chart !k = offset chart
@@ -344,15 +361,6 @@ process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) ac
updateAt :: Int -> a -> [a] -> [a] updateAt :: Int -> a -> [a] -> [a]
updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs] updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs]
litCatMatch (Just t) fid
| fid == fidString = Just (cidString,ELit (LStr t),[t])
| fid == fidInt = case reads t of {[(n,"")] -> Just (cidInt,ELit (LInt n),[t]);
_ -> Nothing }
| fid == fidFloat = case reads t of {[(d,"")] -> Just (cidFloat,ELit (LFlt d),[t]);
_ -> Nothing }
| fid == fidVar = Just (cidVar,EFun (mkCId t),[t])
litCatMatch _ _ = Nothing
---------------------------------------------------------------- ----------------------------------------------------------------
-- Active Chart -- Active Chart