mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-18 17:29:32 -06:00
Founding the newly structured GF2.0 cvs archive.
This commit is contained in:
aarne
338
src/GF/Compile/ShellState.hs
Normal file
338
src/GF/Compile/ShellState.hs
Normal file
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user