From b1402e8bd6a68a891b00a214d6cf184d66defe19 Mon Sep 17 00:00:00 2001 From: aarne Date: Mon, 22 Sep 2003 13:16:55 +0000 Subject: Founding the newly structured GF2.0 cvs archive. --- src/GF/Compile/ShellState.hs | 338 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 338 insertions(+) create mode 100644 src/GF/Compile/ShellState.hs (limited to 'src/GF/Compile/ShellState.hs') diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs new file mode 100644 index 000000000..f24c3b87c --- /dev/null +++ b/src/GF/Compile/ShellState.hs @@ -0,0 +1,338 @@ +module ShellState where + +import Operations +import GFC +import AbsGFC +---import CMacros +import Look +import qualified Modules as M +import qualified Grammar as G +import qualified PrGrammar as P +import CF +import CFIdent +import CanonToCF +import Morphology +import Option +import Ident +import Arch (ModTime) + +-- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished + +-- multilingual state with grammars and options +data ShellState = ShSt { + abstract :: Maybe Ident , -- pointer to actual abstract; nothing in empty st + concrete :: Maybe Ident , -- pointer to primary concrete + concretes :: [(Ident,Ident)], -- list of all concretes + canModules :: CanonGrammar , -- the place where abstracts and concretes reside + srcModules :: G.SourceGrammar , -- the place of saved resource modules + cfs :: [(Ident,CF)] , -- context-free grammars + morphos :: [(Ident,Morpho)], -- morphologies + gloptions :: Options, -- global options + readFiles :: [(FilePath,ModTime)],-- files read + absCats :: [(G.Cat,(G.Context, -- cats, their contexts, + [(G.Fun,G.Type)], -- functions to them, + [((G.Fun,Int),G.Type)]))], -- functions on them + statistics :: [Statistics] -- statistics on grammars + } + +data Statistics = + StDepTypes Bool -- whether there are dependent types + | StBoundVars [G.Cat] -- which categories have bound variables + --- -- etc + deriving (Eq,Ord) + +emptyShellState = ShSt { + abstract = Nothing, + concrete = Nothing, + concretes = [], + canModules = M.emptyMGrammar, + srcModules = M.emptyMGrammar, + cfs = [], + morphos = [], + gloptions = noOptions, + readFiles = [], + absCats = [], + statistics = [] + } + +type Language = Ident +language = identC +prLanguage = prIdent + +-- grammar for one language in a state, comprising its abs and cnc + +data StateGrammar = StGr { + absId :: Ident, + cncId :: Ident, + grammar :: CanonGrammar, + cf :: CF, + morpho :: Morpho + } + +emptyStateGrammar = StGr { + absId = identC "#EMPTY", --- + cncId = identC "#EMPTY", --- + grammar = M.emptyMGrammar, + cf = emptyCF, + morpho = emptyMorpho + } + +-- analysing shell grammar into parts +stateGrammarST = grammar +stateCF = cf +stateMorpho = morpho +stateOptions _ = noOptions ---- + +cncModuleIdST = stateGrammarST + +-- form a shell state from a canonical grammar + +grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState +grammar2shellState opts (gr,sgr) = updateShellState opts emptyShellState (gr,(sgr,[])) + +-- update a shell state from a canonical grammar + +updateShellState :: Options -> ShellState -> + (CanonGrammar,(G.SourceGrammar,[(FilePath,ModTime)])) -> + Err ShellState +updateShellState opts sh (gr,(sgr,rts)) = do + let cgr = M.updateMGrammar (canModules sh) gr + a' = ifNull Nothing (return . last) $ allAbstracts cgr + abstr0 <- case abstract sh of + Just a -> do + --- test that abstract is compatible + return $ Just a + _ -> return a' + let concrs = maybe [] (allConcretes cgr) abstr0 + concr0 = ifNull Nothing (return . last) concrs + notInrts f = notElem f $ map fst rts + cfs <- mapM (canon2cf opts cgr) concrs --- would not need to update all... + + let funs = [] ---- funRulesOf cgr + let cats = [] ---- allCatsOf cgr + let csi = [] ---- +{- + [(c,(co, + [(fun,typ) | (fun,typ) <- funs, compatType tc typ], + funsOnTypeFs compatType funs tc)) + | (c,co) <- cats, let tc = cat2type c] +-} + let deps = True ---- not $ null $ allDepCats cgr + let binds = [] ---- allCatsWithBind cgr + + return $ ShSt { + abstract = abstr0, + concrete = concr0, + concretes = zip concrs concrs, + canModules = cgr, + srcModules = M.updateMGrammar (srcModules sh) sgr, + cfs = zip concrs cfs, + morphos = zip concrs (repeat emptyMorpho), + gloptions = opts, ---- -- global options + readFiles = [ft | ft@(f,_) <- readFiles sh, notInrts f] ++ rts, + absCats = csi, + statistics = [StDepTypes deps,StBoundVars binds] + } + +prShellStateInfo :: ShellState -> String +prShellStateInfo sh = unlines [ + "main abstract : " +++ maybe "(none)" P.prt (abstract sh), + "main concrete : " +++ maybe "(none)" P.prt (concrete sh), + "all concretes : " +++ unwords (map (P.prt . fst) (concretes sh)), + "canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))), + "source modules : " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))), + "global options : " +++ prOpts (gloptions sh) + ] + + +-- form just one state grammar, if unique, from a canonical grammar + +grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar +grammar2stateGrammar opts gr = do + st <- grammar2shellState opts (gr,M.emptyMGrammar) + concr <- maybeErr "no concrete syntax" $ concrete st + return $ stateGrammarOfLang st concr + +-- all abstract modules +allAbstracts :: CanonGrammar -> [Ident] +allAbstracts gr = [i | (i,M.ModMod m) <- M.modules gr, M.mtype m == M.MTAbstract] + +-- the last abstract in dependency order +greatestAbstract :: CanonGrammar -> Maybe Ident +greatestAbstract gr = case allAbstracts gr of + [] -> Nothing + a -> return $ last a + +-- all concretes for a given abstract +allConcretes :: CanonGrammar -> Ident -> [Ident] +allConcretes gr a = [i | (i,M.ModMod m) <- M.modules gr, M.mtype m== M.MTConcrete a] + +stateGrammarOfLang :: ShellState -> Language -> StateGrammar +stateGrammarOfLang st l = StGr { + absId = maybe (identC "Abs") id (abstract st), --- + cncId = l, + grammar = canModules st, ---- only those needed for l + cf = maybe emptyCF id (lookup l (cfs st)), + morpho = maybe emptyMorpho id (lookup l (morphos st)) + } + +grammarOfLang st = stateGrammarST . stateGrammarOfLang st +cfOfLang st = stateCF . stateGrammarOfLang st +morphoOfLang st = stateMorpho . stateGrammarOfLang st +optionsOfLang st = stateOptions . stateGrammarOfLang st + +-- the last introduced grammar, stored in options, is the default for operations + +firstStateGrammar :: ShellState -> StateGrammar +firstStateGrammar st = errVal emptyStateGrammar $ do + concr <- maybeErr "no concrete syntax" $ concrete st + return $ stateGrammarOfLang st concr + +mkStateGrammar :: ShellState -> Language -> StateGrammar +mkStateGrammar = stateGrammarOfLang + +-- analysing shell state into parts +globalOptions = gloptions +allLanguages = map fst . concretes + +allStateGrammars = map snd . allStateGrammarsWithNames + +allStateGrammarsWithNames st = [(c, mkStateGrammar st c) | (c,_) <- concretes st] + +allGrammarFileNames st = [prLanguage c ++ ".gf" | (c,_) <- concretes st] --- + +{- +allActiveStateGrammarsWithNames (ShSt (ma,gs,_)) = + [(l, mkStateGrammar a c) | (l,((_,True),c)) <- gs, Just a <- [ma]] + + + +allActiveGrammars = map snd . allActiveStateGrammarsWithNames + +allGrammarSTs = map stateGrammarST . allStateGrammars +allCFs = map stateCF . allStateGrammars + +firstGrammarST = stateGrammarST . firstStateGrammar +firstAbstractST = abstractOf . firstGrammarST +firstConcreteST = concreteOf . firstGrammarST +-} +-- command-line option -language=foo overrides the actual grammar in state +grammarOfOptState :: Options -> ShellState -> StateGrammar +grammarOfOptState opts st = + maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $ + getOptVal opts useLanguage + +-- command-line option -cat=foo overrides the possible start cat of a grammar +firstCatOpts :: Options -> StateGrammar -> CFCat +firstCatOpts opts sgr = + maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $ + getOptVal opts firstCat + +-- a grammar can have start category as option startcat=foo ; default is S +stateFirstCat sgr = + maybe (string2CFCat a "S") (string2CFCat a) $ + getOptVal (stateOptions sgr) gStartCat + where + a = P.prt (absId sgr) + +-- the first cat for random generation +firstAbsCat :: Options -> StateGrammar -> G.QIdent +firstAbsCat opts sgr = + maybe (absId sgr, identC "S") (\c -> (absId sgr, identC c)) $ ---- + getOptVal opts firstCat + +{- +-- command-line option -cat=foo overrides the possible start cat of a grammar +stateTransferFun :: StateGrammar -> Maybe Fun +stateTransferFun sgr = getOptVal (stateOptions sgr) transferFun >>= return . zIdent + +stateConcrete = concreteOf . stateGrammarST +stateAbstract = abstractOf . stateGrammarST + +maybeStateAbstract (ShSt (ma,_,_)) = ma +hasStateAbstract = maybe False (const True) . maybeStateAbstract +abstractOfState = maybe emptyAbstractST id . maybeStateAbstract + +stateIsWord sg = isKnownWord (stateMorpho sg) + + +-- getting info on a language +existLang :: ShellState -> Language -> Bool +existLang st lang = elem lang (allLanguages st) + +stateConcreteOfLang :: ShellState -> Language -> StateConcrete +stateConcreteOfLang (ShSt (_,gs,_)) lang = + maybe emptyStateConcrete snd $ lookup lang gs + +fileOfLang :: ShellState -> Language -> FilePath +fileOfLang (ShSt (_,gs,_)) lang = + maybe nonExistingLangFile (fst .fst) $ lookup lang gs + +nonExistingLangFile = "NON-EXISTING LANGUAGE" --- + + +allLangOptions st lang = unionOptions (optionsOfLang st lang) (globalOptions st) + +-- construct state + +stateGrammar st cf mo opts = StGr ((st,cf,mo),opts) + +initShellState ab fs gs opts = + ShSt (Just ab, [(getLangName f, ((f,True),g)) | (f,g) <- zip fs gs], opts) +emptyInitShellState opts = ShSt (Nothing, [], opts) + +-- the second-last part of a file name is the default language name +getLangName :: String -> Language +getLangName file = language (if notElem '.' file then file else langname) where + elif = reverse file + xiferp = tail (dropWhile (/='.') elif) + langname = reverse (takeWhile (flip notElem "./") xiferp) + +-- option -language=foo overrides the default language name +getLangNameOpt :: Options -> String -> Language +getLangNameOpt opts file = + maybe (getLangName file) language $ getOptVal opts useLanguage +-} +-- modify state + +type ShellStateOper = ShellState -> ShellState + +reinitShellState :: ShellStateOper +reinitShellState = const emptyShellState + +{- +languageOn = languageOnOff True +languageOff = languageOnOff False + +languageOnOff :: Bool -> Language -> ShellStateOper +languageOnOff b lang (ShSt (ab,gs,os)) = ShSt (ab, gs', os) where + gs' = [if lang==l then (l,((f,b),g)) else i | i@(l,((f,_),g)) <- gs] + +updateLanguage :: FilePath -> (Language, StateConcrete) -> ShellStateOper +updateLanguage file (lang,gr) (ShSt (ab,gs,os)) = + ShSt (ab, updateAssoc (lang,((file,True),gr)) gs, os') where + os' = changeOptVal os useLanguage (prLanguage lang) -- actualizes the new lang + +initWithAbstract :: AbstractST -> ShellStateOper +initWithAbstract ab st@(ShSt (ma,cs,os)) = + maybe (ShSt (Just ab,cs,os)) (const st) ma + +removeLanguage :: Language -> ShellStateOper +removeLanguage lang (ShSt (ab,gs,os)) = ShSt (ab,removeAssoc lang gs, os) +-} +changeOptions :: (Options -> Options) -> ShellStateOper +changeOptions f (ShSt a c cs can src cfs ms os ff ts ss) = + ShSt a c cs can src cfs ms (f os) ff ts ss + +changeModTimes :: [(FilePath,ModTime)] -> ShellStateOper +changeModTimes mfs (ShSt a c cs can src cfs ms os ff ts ss) = + ShSt a c cs can src cfs ms os ff' ts ss + where + ff' = mfs ++ [mf | mf@(f,_) <- ff, notElem f (map fst mfs)] + +addGlobalOptions :: Options -> ShellStateOper +addGlobalOptions = changeOptions . addOptions + +removeGlobalOptions :: Options -> ShellStateOper +removeGlobalOptions = changeOptions . removeOptions + -- cgit v1.2.3