diff --git a/src/GF/Command/Abstract.hs b/src/GF/Command/Abstract.hs index 1ae5d6dff..cf82e96c6 100644 --- a/src/GF/Command/Abstract.hs +++ b/src/GF/Command/Abstract.hs @@ -1,5 +1,6 @@ module GF.Command.Abstract where +import PGF.CId import PGF.Data type Ident = String @@ -19,7 +20,7 @@ data Option data Value = VId Ident - | VInt Integer + | VInt Int | VStr String deriving (Eq,Ord,Show) @@ -29,27 +30,25 @@ data Argument | AMacro Ident deriving (Eq,Ord,Show) -valIdOpts :: String -> String -> [Option] -> String -valIdOpts flag def opts = case valOpts flag (VId def) opts of - VId v -> v - _ -> def +valCIdOpts :: String -> CId -> [Option] -> CId +valCIdOpts flag def opts = + case [v | OFlag f (VId v) <- opts, f == flag] of + (v:_) -> mkCId v + _ -> def -valIntOpts :: String -> Integer -> [Option] -> Int -valIntOpts flag def opts = fromInteger $ case valOpts flag (VInt def) opts of - VInt v -> v - _ -> def +valIntOpts :: String -> Int -> [Option] -> Int +valIntOpts flag def opts = + case [v | OFlag f (VInt v) <- opts, f == flag] of + (v:_) -> v + _ -> def valStrOpts :: String -> String -> [Option] -> String -valStrOpts flag def opts = case valOpts flag (VStr def) opts of - VStr v -> v - _ -> def - -valOpts :: String -> Value -> [Option] -> Value -valOpts flag def opts = case lookup flag flags of - Just v -> v - _ -> def - where - flags = [(f,v) | OFlag f v <- opts] +valStrOpts flag def opts = + case [v | OFlag f v <- opts, f == flag] of + (VStr v:_) -> v + (VId v:_) -> v + (VInt v:_) -> show v + _ -> def isOpt :: String -> [Option] -> Bool isOpt o opts = elem o [x | OOpt x <- opts] diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs index e9a2819ba..a2850b6a2 100644 --- a/src/GF/Command/Commands.hs +++ b/src/GF/Command/Commands.hs @@ -164,7 +164,7 @@ allCommands cod pgf = Map.fromList [ ], exec = \opts _ -> do let pgfr = optRestricted opts - ts <- generateRandom pgfr (optCat opts) + ts <- generateRandom pgfr (optType opts) return $ fromTrees $ take (optNum opts) ts }), ("gt", emptyCommandInfo { @@ -185,7 +185,7 @@ allCommands cod pgf = Map.fromList [ exec = \opts _ -> do let pgfr = optRestricted opts let dp = return $ valIntOpts "depth" 4 opts - let ts = generateAllDepth pgfr (optCat opts) dp + let ts = generateAllDepth pgfr (optType opts) dp return $ fromTrees $ take (optNumInf opts) ts }), ("h", emptyCommandInfo { @@ -285,8 +285,8 @@ allCommands cod pgf = Map.fromList [ synopsis = "start a morphology quiz", exec = \opts _ -> do let lang = optLang opts - let cat = optCat opts - morphologyQuiz cod pgf lang cat + let typ = optType opts + morphologyQuiz cod pgf lang typ return void, flags = [ ("lang","language of the quiz"), @@ -405,7 +405,7 @@ allCommands cod pgf = Map.fromList [ ("tree","convert strings into trees") ], exec = \opts arg -> do - let file = valIdOpts "file" "_gftmp" opts + let file = valStrOpts "file" "_gftmp" opts s <- readFile file return $ case opts of _ | isOpt "lines" opts && isOpt "tree" opts -> @@ -420,10 +420,10 @@ allCommands cod pgf = Map.fromList [ longname = "translation_quiz", synopsis = "start a translation quiz", exec = \opts _ -> do - let from = valIdOpts "from" (optLang opts) opts - let to = valIdOpts "to" (optLang opts) opts - let cat = optCat opts - translationQuiz cod pgf from to cat + let from = valCIdOpts "from" (optLang opts) opts + let to = valCIdOpts "to" (optLang opts) opts + let typ = optType opts + translationQuiz cod pgf from to typ return void, flags = [ ("from","translate from this language"), @@ -516,7 +516,7 @@ allCommands cod pgf = Map.fromList [ longname = "write_file", synopsis = "send string or tree to a file", exec = \opts arg -> do - let file = valIdOpts "file" "_gftmp" opts + let file = valStrOpts "file" "_gftmp" opts if isOpt "append" opts then appendFile file (enc (toString arg)) else writeFile file (enc (toString arg)) @@ -530,7 +530,7 @@ allCommands cod pgf = Map.fromList [ where enc = encodeUnicode cod lin opts t = unlines [linearize pgf lang t | lang <- optLangs opts] - par opts s = concat [parse pgf lang (optCat opts) s | lang <- optLangs opts, canParse pgf lang] + par opts s = concat [parse pgf lang (optType opts) s | lang <- optLangs opts, canParse pgf lang] void = ([],[]) @@ -539,21 +539,21 @@ allCommands cod pgf = Map.fromList [ _ -> unlines [linear opts lang t | lang <- optLangs opts] linear opts lang = let unl = unlex opts lang in case opts of - _ | isOpt "all" opts -> allLinearize unl pgf (mkCId lang) - _ | isOpt "table" opts -> tableLinearize unl pgf (mkCId lang) - _ | isOpt "term" opts -> termLinearize pgf (mkCId lang) - _ | isOpt "record" opts -> recordLinearize pgf (mkCId lang) + _ | isOpt "all" opts -> allLinearize unl pgf lang + _ | isOpt "table" opts -> tableLinearize unl pgf lang + _ | isOpt "term" opts -> termLinearize pgf lang + _ | isOpt "record" opts -> recordLinearize pgf lang _ -> unl . linearize pgf lang treebank opts t = unlines $ - (abstractName pgf ++ ": " ++ showTree t) : - [lang ++ ": " ++ linear opts lang t | lang <- optLangs opts] + (prCId (abstractName pgf) ++ ": " ++ showTree t) : + [prCId lang ++ ": " ++ linear opts lang t | lang <- optLangs opts] unlex opts lang = stringOps (getUnlex opts lang ++ map prOpt opts) getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of lexs -> case lookup lang - [(la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of + [(mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of Just le -> chunks ',' le _ -> [] @@ -571,13 +571,17 @@ allCommands cod pgf = Map.fromList [ _ -> map prOpt opts optRestricted opts = - restrictPGF (\f -> and [hasLin pgf (mkCId la) f | la <- optLangs opts]) pgf + restrictPGF (\f -> and [hasLin pgf la f | la <- optLangs opts]) pgf - optLangs opts = case valIdOpts "lang" "" opts of + optLangs opts = case valStrOpts "lang" "" opts of "" -> languages pgf - lang -> chunks ',' lang - optLang opts = head $ optLangs opts ++ ["#NOLANG"] - optCat opts = valIdOpts "cat" (lookStartCat pgf) opts + lang -> map mkCId (chunks ',' lang) + optLang opts = head $ optLangs opts ++ [wildCId] + optType opts = + let str = valStrOpts "cat" (lookStartCat pgf) opts + in case readType str of + Just ty -> ty + Nothing -> error ("Can't parse '"++str++"' as type") optComm opts = valStrOpts "command" "" opts optViewFormat opts = valStrOpts "format" "ps" opts optViewGraph opts = valStrOpts "view" "gv" opts @@ -591,17 +595,17 @@ allCommands cod pgf = Map.fromList [ toString = unwords . toStrings prGrammar opts = case opts of - _ | isOpt "cats" opts -> unwords $ categories pgf + _ | isOpt "cats" opts -> unwords $ map prCId $ categories pgf _ | isOpt "fullform" opts -> concatMap - (prFullFormLexicon . buildMorpho pgf . mkCId) $ optLangs opts + (prFullFormLexicon . buildMorpho pgf) $ optLangs opts _ | isOpt "missing" opts -> - unlines $ [unwords (la:":": map prCId cs) | - la <- optLangs opts, let cs = missingLins pgf (mkCId la)] - _ -> case valIdOpts "printer" "pgf" opts of + unlines $ [unwords (prCId la:":": map prCId cs) | + la <- optLangs opts, let cs = missingLins pgf la] + _ -> case valStrOpts "printer" "pgf" opts of v -> concatMap snd $ exportPGF noOptions (read v) pgf morphos opts s = - [lookupMorpho (buildMorpho pgf (mkCId la)) s | la <- optLangs opts] + [lookupMorpho (buildMorpho pgf la) s | la <- optLangs opts] -- ps -f -g s returns g (f s) stringOps opts s = foldr app s (reverse opts) where @@ -643,14 +647,14 @@ stringOpOptions = [ treeOpOptions pgf = [(op,expl) | (op,(expl,_)) <- allTreeOps pgf] -translationQuiz :: String -> PGF -> Language -> Language -> Category -> IO () -translationQuiz cod pgf ig og cat = do - tts <- translationList pgf ig og cat infinity +translationQuiz :: String -> PGF -> Language -> Language -> Type -> IO () +translationQuiz cod pgf ig og typ = do + tts <- translationList pgf ig og typ infinity mkQuiz cod "Welcome to GF Translation Quiz." tts -morphologyQuiz :: String -> PGF -> Language -> Category -> IO () -morphologyQuiz cod pgf ig cat = do - tts <- morphologyList pgf ig cat infinity +morphologyQuiz :: String -> PGF -> Language -> Type -> IO () +morphologyQuiz cod pgf ig typ = do + tts <- morphologyList pgf ig typ infinity mkQuiz cod "Welcome to GF Morphology Quiz." tts -- | the maximal number of precompiled quiz problems diff --git a/src/GF/Quiz.hs b/src/GF/Quiz.hs index 92969aa3c..bfdd9a54a 100644 --- a/src/GF/Quiz.hs +++ b/src/GF/Quiz.hs @@ -39,19 +39,19 @@ mkQuiz cod msg tts = do teachDialogue qas msg translationList :: - PGF -> Language -> Language -> Category -> Int -> IO [(String,[String])] -translationList pgf ig og cat number = do - ts <- generateRandom pgf cat >>= return . take number + PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])] +translationList pgf ig og typ number = do + ts <- generateRandom pgf typ >>= return . take number return $ map mkOne $ ts where mkOne t = (norml (linearize pgf ig t), map (norml . linearize pgf og) (homonyms t)) - homonyms = nub . parse pgf ig cat . linearize pgf ig + homonyms = nub . parse pgf ig typ . linearize pgf ig -morphologyList :: PGF -> Language -> Category -> Int -> IO [(String,[String])] -morphologyList pgf ig cat number = do - ts <- generateRandom pgf cat >>= return . take (max 1 number) +morphologyList :: PGF -> Language -> Type -> Int -> IO [(String,[String])] +morphologyList pgf ig typ number = do + ts <- generateRandom pgf typ >>= return . take (max 1 number) gen <- newStdGen - let ss = map (tabularLinearize pgf (mkCId ig)) ts + let ss = map (tabularLinearize pgf ig) ts let size = length (head ss) let forms = take number $ randomRs (0,size-1) gen return [(head (snd (head pws)) +++ par, ws) | diff --git a/src/GFI.hs b/src/GFI.hs index 1e9cfba2f..59c792eb5 100644 --- a/src/GFI.hs +++ b/src/GFI.hs @@ -148,7 +148,7 @@ importInEnv gfenv opts files pgf0 = multigrammar (commandenv gfenv) pgf1 <- importGrammar pgf0 opts' files if (verbAtLeast opts Normal) - then putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1 + then putStrLnFlush $ unwords $ "\nLanguages:" : map prCId (languages pgf1) else return () return $ gfenv { commandenv = mkCommandEnv (coding gfenv) pgf1 } @@ -177,10 +177,11 @@ welcome = unlines [ "Bug reports: http://trac.haskell.org/gf/" ] -prompt env = absname ++ "> " where - absname = case abstractName (multigrammar env) of - "_" -> "" --- created by new Ident handling 22/5/2008 - n -> n +prompt env + | abs == wildCId = "> " + | otherwise = prCId abs ++ "> " + where + abs = abstractName (multigrammar env) data GFEnv = GFEnv { sourcegrammar :: Grammar, -- gfo grammar -retain @@ -201,7 +202,7 @@ wordCompletion gfenv line0 prefix0 p = CmplCmd pref -> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name] CmplStr (Just (Command _ opts _)) s - -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat opts))) + -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optType opts))) case mb_state0 of Right state0 -> let ws = words (take (length s - length prefix) s) in case foldM nextState state0 ws of @@ -230,8 +231,8 @@ wordCompletion gfenv line0 prefix0 p = pgf = multigrammar cmdEnv cmdEnv = commandenv gfenv - optLang opts = valIdOpts "lang" (head (languages pgf)) opts - optCat opts = valIdOpts "cat" (lookStartCat pgf) opts + optLang opts = valCIdOpts "lang" (head (languages pgf)) opts + optType opts = DTyp [] (mkCId (valStrOpts "type" (lookStartCat pgf) opts)) [] ret c [x] = return [x++[c]] ret _ xs = return xs diff --git a/src/PGF.hs b/src/PGF.hs index 65697fe8a..f989e3969 100644 --- a/src/PGF.hs +++ b/src/PGF.hs @@ -89,19 +89,19 @@ import Control.Monad -- Interface --------------------------------------------------- --- | This is just a string with the language name. +-- | This is just a 'CId' with the language name. -- A language name is the identifier that you write in the -- top concrete or abstract module in GF after the -- concrete/abstract keyword. Example: -- -- > abstract Lang = ... -- > concrete LangEng of Lang = ... -type Language = String +type Language = CId --- | This is just a string with the category name. +-- | This is just a 'CId' with the category name. -- The categories are defined in the abstract syntax -- with the \'cat\' keyword. -type Category = String +type Category = CId -- | Reads file in Portable Grammar Format and produces -- 'PGF' structure. The file is usually produced with: @@ -118,7 +118,7 @@ linearize :: PGF -> Language -> Tree -> String -- contain more than one element if the grammar is ambiguous. -- Throws an exception if the given language cannot be used -- for parsing, see 'canParse'. -parse :: PGF -> Language -> Category -> String -> [Tree] +parse :: PGF -> Language -> Type -> String -> [Tree] -- | Checks whether the given language can be used for parsing. canParse :: PGF -> Language -> Bool @@ -133,7 +133,7 @@ linearizeAllLang :: PGF -> Tree -> [(Language,String)] -- | The same as 'parseAllLang' but does not return -- the language. -parseAll :: PGF -> Category -> String -> [[Tree]] +parseAll :: PGF -> Type -> String -> [[Tree]] -- | Tries to parse the given string with all available languages. -- Languages which cannot be used for parsing (see 'canParse') @@ -143,31 +143,31 @@ parseAll :: PGF -> Category -> String -> [[Tree]] -- (this is a list, since grammars can be ambiguous). -- Only those languages -- for which at least one parsing is possible are listed. -parseAllLang :: PGF -> Category -> String -> [(Language,[Tree])] +parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])] -- | Creates an initial parsing state for a given language and -- startup category. -initState :: PGF -> Language -> Category -> Incremental.ParseState +initState :: PGF -> Language -> Type -> Incremental.ParseState -- | This function extracts the list of all completed parse trees -- that spans the whole input consumed so far. The trees are also -- limited by the category specified, which is usually -- the same as the startup category. -extractExps :: Incremental.ParseState -> Category -> [Tree] +extractExps :: Incremental.ParseState -> Type -> [Tree] -- | The same as 'generateAllDepth' but does not limit -- the depth in the generation. -generateAll :: PGF -> Category -> [Tree] +generateAll :: PGF -> Type -> [Tree] -- | Generates an infinite list of random abstract syntax expressions. -- This is usefull for tree bank generation which after that can be used -- for grammar testing. -generateRandom :: PGF -> Category -> IO [Tree] +generateRandom :: PGF -> Type -> IO [Tree] -- | Generates an exhaustive possibly infinite list of -- abstract syntax expressions. A depth can be specified -- to limit the search space. -generateAllDepth :: PGF -> Category -> Maybe Int -> [Tree] +generateAllDepth :: PGF -> Type -> Maybe Int -> [Tree] -- | List of all languages available in the given grammar. languages :: PGF -> [Language] @@ -197,7 +197,7 @@ startCat :: PGF -> Category -- is empty or ends in whitespace, the last word is considred -- to be the empty string. This means that the completions -- will be all possible next words. -complete :: PGF -> Language -> Category -> String +complete :: PGF -> Language -> Type -> String -> [String] -- ^ Possible word completions of, -- including the given input. @@ -211,61 +211,58 @@ readPGF f = do g <- parseGrammar s return $! toPGF g -linearize pgf lang = concat . take 1 . PGF.Linearize.linearizes pgf (mkCId lang) +linearize pgf lang = concat . take 1 . PGF.Linearize.linearizes pgf lang -parse pgf lang cat s = - case Map.lookup (mkCId lang) (concretes pgf) of +parse pgf lang typ s = + case Map.lookup lang (concretes pgf) of Just cnc -> case parser cnc of Just pinfo -> if Map.lookup (mkCId "erasing") (cflags cnc) == Just "on" - then Incremental.parse pinfo (mkCId cat) (words s) - else case parseFCFG "topdown" pinfo (mkCId cat) (words s) of + then Incremental.parse pinfo typ (words s) + else case parseFCFG "topdown" pinfo typ (words s) of Ok x -> x Bad s -> error s - Nothing -> error ("No parser built for language: " ++ lang) - Nothing -> error ("Unknown language: " ++ lang) + Nothing -> error ("No parser built for language: " ++ prCId lang) + Nothing -> error ("Unknown language: " ++ prCId lang) -canParse pgf cnc = isJust (lookParser pgf (mkCId cnc)) +canParse pgf cnc = isJust (lookParser pgf cnc) linearizeAll mgr = map snd . linearizeAllLang mgr linearizeAllLang mgr t = [(lang,PGF.linearize mgr lang t) | lang <- languages mgr] -parseAll mgr cat = map snd . parseAllLang mgr cat +parseAll mgr typ = map snd . parseAllLang mgr typ -parseAllLang mgr cat s = - [(lang,ts) | lang <- languages mgr, canParse mgr lang, let ts = parse mgr lang cat s, not (null ts)] +parseAllLang mgr typ s = + [(lang,ts) | lang <- languages mgr, canParse mgr lang, let ts = parse mgr lang typ s, not (null ts)] -initState pgf lang cat = - case lookParser pgf langCId of - Just pinfo -> Incremental.initState pinfo catCId - _ -> error ("Unknown language: " ++ lang) - where - langCId = mkCId lang - catCId = mkCId cat +initState pgf lang typ = + case lookParser pgf lang of + Just pinfo -> Incremental.initState pinfo typ + _ -> error ("Unknown language: " ++ prCId lang) -extractExps state cat = Incremental.extractExps state (mkCId cat) +extractExps state typ = Incremental.extractExps state typ generateRandom pgf cat = do gen <- newStdGen - return $ genRandom gen pgf (mkCId cat) + return $ genRandom gen pgf cat -generateAll pgf cat = generate pgf (mkCId cat) Nothing -generateAllDepth pgf cat = generate pgf (mkCId cat) +generateAll pgf cat = generate pgf cat Nothing +generateAllDepth pgf cat = generate pgf cat -abstractName pgf = prCId (absname pgf) +abstractName pgf = absname pgf -languages pgf = [prCId l | l <- cncnames pgf] +languages pgf = cncnames pgf languageCode pgf lang = - fmap (replace '_' '-') $ lookConcrFlag pgf (mkCId lang) (mkCId "language") + fmap (replace '_' '-') $ lookConcrFlag pgf lang (mkCId "language") -categories pgf = [prCId c | c <- Map.keys (cats (abstract pgf))] +categories pgf = Map.keys (cats (abstract pgf)) -startCat pgf = lookStartCat pgf +startCat pgf = mkCId (lookStartCat pgf) -complete pgf from cat input = +complete pgf from typ input = let (ws,prefix) = tokensAndPrefix input - state0 = initState pgf from cat + state0 = initState pgf from typ in case foldM Incremental.nextState state0 ws of Nothing -> [] Just state -> let compls = Incremental.getCompletions state prefix diff --git a/src/PGF/Generate.hs b/src/PGF/Generate.hs index 518c2c71b..94be66245 100644 --- a/src/PGF/Generate.hs +++ b/src/PGF/Generate.hs @@ -8,8 +8,8 @@ import qualified Data.Map as M import System.Random -- generate an infinite list of trees exhaustively -generate :: PGF -> CId -> Maybe Int -> [Tree] -generate pgf cat dp = concatMap (\i -> gener i cat) depths +generate :: PGF -> Type -> Maybe Int -> [Tree] +generate pgf (DTyp _ cat _) dp = concatMap (\i -> gener i cat) depths where gener 0 c = [Fun f [] | (f, ([],_)) <- fns c] gener i c = [ @@ -24,8 +24,8 @@ generate pgf cat dp = concatMap (\i -> gener i cat) depths depths = maybe [0 ..] (\d -> [0..d]) dp -- generate an infinite list of trees randomly -genRandom :: StdGen -> PGF -> CId -> [Tree] -genRandom gen pgf cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where +genRandom :: StdGen -> PGF -> Type -> [Tree] +genRandom gen pgf (DTyp _ cat _) = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where timeout = 47 -- give up diff --git a/src/PGF/Parsing/FCFG.hs b/src/PGF/Parsing/FCFG.hs index fe56f8712..088c9f480 100644 --- a/src/PGF/Parsing/FCFG.hs +++ b/src/PGF/Parsing/FCFG.hs @@ -30,10 +30,10 @@ import qualified Data.Map as Map parseFCFG :: String -- ^ parsing strategy -> ParserInfo -- ^ compiled grammar (fcfg) - -> CId -- ^ starting category + -> Type -- ^ start type -> [String] -- ^ input tokens -> Err [Tree] -- ^ resulting GF terms -parseFCFG "bottomup" pinfo start toks = return $ Active.parse "b" pinfo start toks -parseFCFG "topdown" pinfo start toks = return $ Active.parse "t" pinfo start toks -parseFCFG "incremental" pinfo start toks = return $ Incremental.parse pinfo start toks -parseFCFG strat pinfo start toks = fail $ "FCFG parsing strategy not defined: " ++ strat +parseFCFG "bottomup" pinfo typ toks = return $ Active.parse "b" pinfo typ toks +parseFCFG "topdown" pinfo typ toks = return $ Active.parse "t" pinfo typ toks +parseFCFG "incremental" pinfo typ toks = return $ Incremental.parse pinfo typ toks +parseFCFG strat pinfo typ toks = fail $ "FCFG parsing strategy not defined: " ++ strat diff --git a/src/PGF/Parsing/FCFG/Active.hs b/src/PGF/Parsing/FCFG/Active.hs index 0927a719b..ad1db7220 100644 --- a/src/PGF/Parsing/FCFG/Active.hs +++ b/src/PGF/Parsing/FCFG/Active.hs @@ -37,8 +37,8 @@ makeFinalEdge cat 0 0 = (cat, [EmptyRange]) makeFinalEdge cat i j = (cat, [makeRange i j]) -- | the list of categories = possible starting categories -parse :: String -> ParserInfo -> CId -> [FToken] -> [Tree] -parse strategy pinfo start toks = nubsort $ filteredForests >>= forest2trees +parse :: String -> ParserInfo -> Type -> [FToken] -> [Tree] +parse strategy pinfo (DTyp _ start _) toks = nubsort $ filteredForests >>= forest2trees where inTokens = input toks starts = Map.findWithDefault [] start (startCats pinfo) diff --git a/src/PGF/Parsing/FCFG/Incremental.hs b/src/PGF/Parsing/FCFG/Incremental.hs index e5f64365f..38c2e6c95 100644 --- a/src/PGF/Parsing/FCFG/Incremental.hs +++ b/src/PGF/Parsing/FCFG/Incremental.hs @@ -22,11 +22,11 @@ import PGF.CId import PGF.Data import Debug.Trace -parse :: ParserInfo -> CId -> [String] -> [Tree] -parse pinfo start toks = maybe [] (\ps -> extractExps ps start) (foldM nextState (initState pinfo start) toks) +parse :: ParserInfo -> Type -> [String] -> [Tree] +parse pinfo typ toks = maybe [] (\ps -> extractExps ps typ) (foldM nextState (initState pinfo typ) toks) -initState :: ParserInfo -> CId -> ParseState -initState pinfo start = +initState :: ParserInfo -> Type -> ParseState +initState pinfo (DTyp _ start _) = let items = do cat <- fromMaybe [] (Map.lookup start (startCats pinfo)) (funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args) @@ -97,8 +97,8 @@ getCompletions (State pinfo chart items) w = | isPrefixOf w tok = Map.insertWith Set.union tok (Set.singleton item) map | otherwise = map -extractExps :: ParseState -> CId -> [Tree] -extractExps (State pinfo chart items) start = exps +extractExps :: ParseState -> Type -> [Tree] +extractExps (State pinfo chart items) (DTyp _ start _) = exps where (_,st) = process (\_ _ -> id) (sequences pinfo) (functions pinfo) (Set.toList items) () chart