Founding the newly structured GF2.0 cvs archive.

1 files changed, 338 insertions, 0 deletions

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
+