Founding the newly structured GF2.0 cvs archive.

1 files changed, 256 insertions, 0 deletions

diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
new file mode 100644
index 000000000..bf84d776b
--- /dev/null
+++ b/src/GF/UseGrammar/Custom.hs
@@ -0,0 +1,256 @@
+module Custom where
+
+import Operations
+import Text
+import Tokenize
+import qualified Grammar as G
+import qualified AbsGFC as A
+import qualified GFC as C
+import qualified AbsGF as GF
+import qualified MMacros as MM
+import AbsCompute
+import TypeCheck
+------import Compile
+import ShellState
+import Editing
+import Paraphrases
+import Option
+import CF
+import CFIdent
+
+---- import CFtoGrammar
+import PPrCF
+import PrGrammar
+
+----import Morphology
+-----import GrammarToHaskell
+-----import GrammarToCanon (showCanon, showCanonOpt)
+-----import qualified GrammarToGFC as GFC
+
+-- the cf parsing algorithms
+import ChartParser -- or some other CF Parser
+
+import MoreCustom -- either small/ or big/. The one in Small is empty.
+
+import UseIO
+
+-- minimal version also used in Hugs. AR 2/12/2002. 
+
+-- databases for customizable commands. AR 21/11/2001
+-- for:  grammar parsers, grammar printers, term commands, string commands
+-- idea: items added here are usable throughout GF; nothing else need be edited
+-- they are often usable through the API: hence API cannot be imported here!
+
+-- Major redesign 3/4/2002: the first entry in each database is DEFAULT.
+-- If no other value is given, the default is selected.
+-- Because of this, two invariants have to be preserved:
+-- ** no databases may be empty
+-- ** additions are made to the end of the database
+
+-- these are the databases; the comment gives the name of the flag
+
+-- grammarFormat, "-format=x" or file suffix
+customGrammarParser :: CustomData (FilePath -> IOE C.CanonGrammar) 
+
+-- grammarPrinter, "-printer=x"
+customGrammarPrinter :: CustomData (StateGrammar -> String)             
+
+-- syntaxPrinter, "-printer=x"
+customSyntaxPrinter  :: CustomData (GF.Grammar -> String)        
+
+-- termPrinter, "-printer=x"
+customTermPrinter  :: CustomData (StateGrammar -> A.Exp -> String)
+
+-- termCommand, "-transform=x"
+customTermCommand    :: CustomData (StateGrammar -> A.Exp -> [A.Exp])
+
+-- editCommand, "-edit=x"
+customEditCommand    :: CustomData (StateGrammar -> Action)
+
+-- filterString, "-filter=x"
+customStringCommand  :: CustomData (StateGrammar -> String -> String)
+
+-- useParser, "-parser=x"
+customParser         :: CustomData (StateGrammar -> CFCat -> CFParser)
+
+-- useTokenizer, "-lexer=x"
+customTokenizer      :: CustomData (StateGrammar -> String -> [CFTok])  
+
+-- useUntokenizer, "-unlexer=x" --- should be from token list to string
+customUntokenizer    :: CustomData (StateGrammar -> String -> String)  
+
+
+-- this is the way of selecting an item
+customOrDefault :: Options -> OptFun -> CustomData a -> a
+customOrDefault opts optfun db = maybe (defaultCustomVal db) id $ 
+                                   customAsOptVal opts optfun db
+
+-- to produce menus of custom operations
+customInfo :: CustomData a -> (String, [String])
+customInfo c = (titleCustomData c, map (ciStr . fst) (dbCustomData c))
+
+-------------------------------
+
+type CommandId = String
+
+strCI :: String -> CommandId
+strCI = id
+
+ciStr :: CommandId -> String
+ciStr = id
+
+ciOpt :: CommandId -> Option
+ciOpt = iOpt
+
+newtype CustomData a = CustomData (String, [(CommandId,a)])
+customData title db = CustomData (title,db)
+dbCustomData (CustomData (_,db)) = db
+titleCustomData (CustomData (t,_)) = t
+
+lookupCustom :: CustomData a -> CommandId -> Maybe a
+lookupCustom = flip lookup . dbCustomData
+
+customAsOptVal :: Options -> OptFun -> CustomData a -> Maybe a
+customAsOptVal opts optfun db = do
+  arg <- getOptVal opts optfun
+  lookupCustom db (strCI arg)
+
+-- take the first entry from the database
+defaultCustomVal :: CustomData a -> a
+defaultCustomVal (CustomData (s,db)) = 
+  ifNull (error ("empty database:" +++ s)) (snd . head) db
+
+-------------------------------------------------------------------------
+-- and here's the customizable part:
+
+-- grammar parsers: the ID is also used as file name suffix
+customGrammarParser = 
+  customData "Grammar parsers, selected by file name suffix" $
+  [
+------   (strCI "gf",  compileModule noOptions) -- DEFAULT
+-- add your own grammar parsers here
+  ] 
+  ++ moreCustomGrammarParser
+
+
+customGrammarPrinter = 
+  customData "Grammar printers, selected by option -printer=x" $
+  [
+----   (strCI "gf",      prt)  -- DEFAULT
+  (strCI "cf",      prCF . stateCF)
+
+{- ----
+   (strCI "gf",      prt  . st2grammar . stateGrammarST)  -- DEFAULT
+  ,(strCI "canon",   showCanon "Lang" . stateGrammarST)
+  ,(strCI "gfc",     GFC.showGFC . stateGrammarST)
+  ,(strCI "canonOpt",showCanonOpt "Lang" . stateGrammarST)
+  ,(strCI "morpho",  prMorpho . stateMorpho)
+  ,(strCI "opts",    prOpts . stateOptions)
+-}
+-- add your own grammar printers here
+--- also include printing via grammar2syntax!
+  ] 
+  ++ moreCustomGrammarPrinter
+
+customSyntaxPrinter = 
+  customData "Syntax printers, selected by option -printer=x" $
+  [ 
+-- add your own grammar printers here
+  ] 
+  ++ moreCustomSyntaxPrinter
+
+
+customTermPrinter = 
+  customData "Term printers, selected by option -printer=x" $
+  [ 
+    (strCI "gf",     const prt) -- DEFAULT
+-- add your own term printers here
+  ]
+  ++ moreCustomTermPrinter
+
+customTermCommand = 
+  customData "Term transformers, selected by option -transform=x" $
+  [
+   (strCI "identity",   \_ t -> [t]) -- DEFAULT
+{- ----
+  ,(strCI "compute",    \g t -> err (const [t]) return (computeAbsTerm g t))
+  ,(strCI "paraphrase", \g t -> mkParaphrases g t)
+  ,(strCI "typecheck",  \g t -> err (const []) return (checkIfValidExp g t))
+  ,(strCI "solve",      \g t -> editAsTermCommand g 
+                                            (uniqueRefinements g) t)
+  ,(strCI "context",    \g t -> editAsTermCommand g  
+                                            (contextRefinements g) t)
+-}
+---  ,(strCI "delete",     \g t -> [MM.mExp0])
+-- add your own term commands here
+  ]
+  ++ moreCustomTermCommand
+
+customEditCommand = 
+  customData "Editor state transformers, selected by option -edit=x" $
+  [
+   (strCI "identity",   const return) -- DEFAULT
+  ,(strCI "transfer",   const return) --- done ad hoc on top level
+{- ----
+  ,(strCI "typecheck",  reCheckState)
+  ,(strCI "solve",      solveAll)
+  ,(strCI "context",    contextRefinements)
+  ,(strCI "compute",    computeSubTree)
+-}
+  ,(strCI "paraphrase", const return) --- done ad hoc on top level
+-- add your own edit commands here
+  ]
+  ++ moreCustomEditCommand
+
+customStringCommand = 
+  customData "String filters, selected by option -filter=x" $
+  [
+   (strCI "identity",  const $ id)   -- DEFAULT
+  ,(strCI "erase",     const $ const "")
+  ,(strCI "take100",   const $ take 100)
+  ,(strCI "text",      const $ formatAsText)
+  ,(strCI "code",      const $ formatAsCode)
+----  ,(strCI "latexfile", const $ mkLatexFile)
+  ,(strCI "length",    const $ show . length)
+-- add your own string commands here
+  ]
+  ++ moreCustomStringCommand
+
+customParser = 
+  customData "Parsers, selected by option -parser=x" $
+  [
+   (strCI "chart",    chartParser . stateCF)
+-- add your own parsers here
+  ]
+  ++ moreCustomParser
+
+customTokenizer = 
+  customData "Tokenizers, selected by option -lexer=x" $
+  [
+   (strCI "words",     const $ tokWords)
+  ,(strCI "literals",  const $ tokLits)
+  ,(strCI "vars",      const $ tokVars)
+  ,(strCI "chars",     const $ map (tS . singleton))
+  ,(strCI "code",      const $ lexHaskell)
+  ,(strCI "text",      const $ lexText)
+----  ,(strCI "codelit",   lexHaskellLiteral . stateIsWord)
+----  ,(strCI "textlit",   lexTextLiteral . stateIsWord)
+  ,(strCI "codeC",     const $ lexC2M)
+  ,(strCI "codeCHigh", const $ lexC2M' True)
+-- add your own tokenizers here
+  ]
+  ++ moreCustomTokenizer
+
+customUntokenizer = 
+  customData "Untokenizers, selected by option -unlexer=x" $
+  [
+   (strCI "unwords",   const $ id)   -- DEFAULT
+  ,(strCI "text",      const $ formatAsText)
+  ,(strCI "code",      const $ formatAsCode)
+  ,(strCI "textlit",   const $ formatAsTextLit)
+  ,(strCI "codelit",   const $ formatAsCodeLit)
+  ,(strCI "concat",    const $ concat . words)
+  ,(strCI "bind",      const $ performBinds)
+-- add your own untokenizers here
+  ]
+  ++ moreCustomUntokenizer