Fixed several things, e.g. tokenizer.

src/GF.hs

@@ -14,6 +14,7 @@ import UTF8
 import Today (today)
 import Arch
 import System (getArgs)
+import Monad (foldM)
 
 -- AR 19/4/2000 -- 11/11/2001
 
@@ -24,8 +25,8 @@ main = do
       java    = oElem forJava os
   putStrLn $ if java then encodeUTF8 welcomeMsg else welcomeMsg
   st <- case fs of 
-    f:_ -> useIOE emptyShellState (shellStateFromFiles os emptyShellState f)
+    _ -> useIOE emptyShellState $ foldM (shellStateFromFiles os) emptyShellState fs
-    _ -> return emptyShellState
+  ---  _ -> return emptyShellState
   if null fs then return () else putCPU 
   if java then sessionLineJ st else do
   gfInteract (initHState st) 

src/GF/API.hs

@@ -177,9 +177,10 @@ optLinearizeTree opts gr t = case getOptVal opts transferFun of
 
   lin mk
     | oElem showRecord opts = liftM prt . linearizeNoMark g c
-    | otherwise             = return . linTree2string mk g c
+    | otherwise             = return . untok . linTree2string mk g c
   g = grammar gr
   c = cncId gr
+  untok = customOrDefault opts useUntokenizer customUntokenizer gr
 
 {- ----
         untoksl . lin where

src/GF/CF/CFIdent.hs

@@ -56,23 +56,17 @@ type Profile  = [([[Int]],[Int])]
 mkCFFun :: Atom -> CFFun
 mkCFFun t = CFFun (t,[])
 
-{- ----
-getCFLiteral :: String -> Maybe (CFCat, CFFun)
-getCFLiteral s = case lookupLiteral' s of
-  Ok (c, lit) -> Just (cat2CFCat c, mkCFFun lit)
-  _ -> Nothing
--}
-
 varCFFun :: Ident -> CFFun
 varCFFun = mkCFFun . AV
 
 consCFFun :: CIdent -> CFFun
 consCFFun = mkCFFun . AC
 
-{- ----
+stringCFFun :: String -> CFFun 
-string2CFFun :: String -> CFFun 
+stringCFFun = mkCFFun . AS
-string2CFFun = consCFFun . Ident
+
--}
+intCFFun :: Int -> CFFun 
+intCFFun = mkCFFun . AI . toInteger
 
 cfFun2String :: CFFun -> String
 cfFun2String (CFFun (f,_)) = prt f
@@ -110,6 +104,11 @@ catVarCF = ident2CFCat (mkCIdent "_" "#Var") (identC "_") ----
 cat2CFCat :: (Ident,Ident) -> CFCat
 cat2CFCat = uncurry idents2CFCat
 
+---- literals
+cfCatString = string2CFCat "Predef" "String"
+cfCatInt = string2CFCat "Predef" "Int"
+
+
 
 {- ----
 uCFCat :: CFCat

src/GF/CF/CanonToCF.hs

@@ -27,8 +27,9 @@ canon2cf opts gr c = do
   let mms  = [(a, tree2list (M.jments m)) | m <- cncs]
   rules0 <- liftM concat $ mapM (uncurry (cnc2cfCond opts)) mms
   let rules = filter (not . isCircularCF) rules0 ---- temporarily here
-  let predef = const [] ---- mkCFPredef cfcats
+  let grules = groupCFRules rules
-  return $ CF (groupCFRules rules, predef)
+  let predef = mkCFPredef $ map fst grules
+  return $ CF (grules, predef)
 
 cnc2cfCond :: Options -> Ident -> [(Ident,Info)] -> Err [CFRule]
 cnc2cfCond opts m gr = 
@@ -144,14 +145,9 @@ term2CFItems m t = errIn "forming cf items" $ case t of
                                      ---- ??
       _   -> prtBad "cannot extract record field from" arg
 
-{- Proof + 1 @ 4     catVarCF :: CFCat
-PNonterm CIdent Integer Label Bool -- cat, position, part/bind, whether arg
-
-
 mkCFPredef :: [CFCat] -> CFPredef
 mkCFPredef cats s = 
-  [(cat, metaCFFun)  | TM _ _ <- [s], cat <- cats] ++
+  [(cat,         metaCFFun)     | TM _ _ <- [s], cat <- cats] ++
-  [(cat, varCFFun x) | TV x   <- [s], cat <- cats] ++
+  [(cat,         varCFFun x)    | TV x   <- [s], cat <- cats] ++
-  [(cat, lit)        | TL t   <- [s], Just (cat,lit) <- [getCFLiteral t]] ++
+  [(cfCatString, stringCFFun t) | TL t   <- [s]]              ++
-  [(cat, lit)        | TI i   <- [s], Just (cat,lit) <- [getCFLiteral (show i)]] ---
+  [(cfCatInt,    intCFFun t)    | TI t   <- [s]]
--}

src/GF/Canon/Look.hs

@@ -144,6 +144,8 @@ ccompute cnc = comp []
 
     Con c xs -> liftM (Con c) $ mapM compt xs
 
+    K (KS []) -> return E --- should not be needed
+
     _        -> return t  
    where
      compt = comp g xs

src/GF/Compile/Compile.hs

@@ -47,15 +47,27 @@ batchCompileOld f = compileOld defOpts f
     defOpts = options [beVerbose, emitCode] 
 
 -- compile with one module as starting point
+-- command-line options override options (marked by --#) in the file
+-- As for path: if it is read from file, the file path is prepended to each name.
+-- If from command line, it is used as it is.
 
 compileModule :: Options -> ShellState -> FilePath -> 
                  IOE (GFC.CanonGrammar, (SourceGrammar,[(FilePath,ModTime)]))
-compileModule opts st file = do
+compileModule opts1 st0 file = do
-  let ps   = pathListOpts opts
+  opts0 <- ioeIO $ getOptionsFromFile file
+  let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
+  let opts = addOptions opts1 opts0 
+  let ps0  = pathListOpts opts
+  let fpath = justInitPath file
+  let ps = if useFileOpt 
+             then (map (prefixPathName fpath) ps0)
+             else ps0
   ioeIO $ print ps ----
   let putp = putPointE opts
-  let rfs  = readFiles st
+  let st = st0 --- if useFileOpt then emptyShellState else st0
-  files <- getAllFiles ps rfs file
+  let rfs = readFiles st
+  let file' = if useFileOpt then justFileName file else file -- to find file itself
+  files <- getAllFiles ps rfs file'
   ioeIO $ print files ----
   let names = map (fileBody . justFileName) files
   ioeIO $ print names ----

src/GF/Compile/ShellState.hs

@@ -70,7 +70,8 @@ data StateGrammar = StGr {
   grammar :: CanonGrammar,
   cf      :: CF,
 ----  parser :: StaticParserInfo,
-  morpho  :: Morpho
+  morpho  :: Morpho,
+  loptions :: Options
   }
 
 emptyStateGrammar = StGr {
@@ -78,14 +79,15 @@ emptyStateGrammar = StGr {
   cncId   = identC "#EMPTY", ---
   grammar = M.emptyMGrammar,
   cf      = emptyCF,
-  morpho  = emptyMorpho
+  morpho  = emptyMorpho,
+  loptions = noOptions
   }
 
 -- analysing shell grammar into parts
 stateGrammarST = grammar
 stateCF        = cf
 stateMorpho    = morpho
-stateOptions _ = noOptions ----
+stateOptions   = loptions ----
 
 cncModuleIdST = stateGrammarST
 
@@ -122,16 +124,17 @@ updateShellState opts sh (gr,(sgr,rts)) = do
                                       | (c,co) <- cats, let tc = cat2val co c]
   let deps = True ---- not $ null $ allDepCats cgr
   let binds = [] ---- allCatsWithBind cgr 
+  let src = M.updateMGrammar (srcModules sh) sgr
 
   return $ ShSt {
     abstract   = abstr0, 
     concrete   = concr0, 
     concretes  = zip concrs concrs,
     canModules = cgr,
-    srcModules = M.updateMGrammar (srcModules sh) sgr,
+    srcModules = src,
     cfs        = zip concrs cfs,
     morphos    = zip concrs (repeat emptyMorpho),
-    gloptions  = opts,                            ---- -- global options
+    gloptions  = options (M.allFlags src), ---- canModules
     readFiles  = [ft | ft@(f,_) <- readFiles sh, notInrts f] ++ rts,
     absCats    = csi,
     statistics = [StDepTypes deps,StBoundVars binds]
@@ -194,7 +197,8 @@ stateGrammarOfLang st l = StGr {
   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))
+  morpho  = maybe emptyMorpho id (lookup l (morphos st)),
+  loptions = gloptions st ---- only the own ones!
   }
 
 grammarOfLang st = stateGrammarST . stateGrammarOfLang st
@@ -218,7 +222,8 @@ stateAbstractGrammar st = StGr {
   cncId   = identC "#Cnc", ---
   grammar = canModules st, ---- only abstarct ones
   cf      = emptyCF,
-  morpho  = emptyMorpho
+  morpho  = emptyMorpho,
+  loptions = gloptions st ----
   }
 
 

src/GF/Grammar/PrGrammar.hs

@@ -9,6 +9,8 @@ import qualified PrintGFC as C
 import qualified AbsGFC as A
 import Values
 import GrammarToSource
+
+import Option
 import Ident
 import Str
 
@@ -97,13 +99,6 @@ prMarkedTree = prf 1 where
 prTree :: Tree -> [String]
 prTree = prMarkedTree . mapTr (\n -> (n,False))
 
---- to get rig of brackets
-prRefinement :: Term -> String
-prRefinement t = case t of
-  Q m c  -> prQIdent (m,c)
-  QC m c -> prQIdent (m,c)
-  _ -> prt t
-
 -- a pretty-printer for parsable output
 tree2string = unlines . prprTree
 
@@ -187,3 +182,12 @@ prExp e = case e of
    pr2 e = case e of
      App _ _ -> prParenth $ prExp e
      _ -> pr1 e
+
+-- option -strip strips qualifications
+prTermOpt opts = if oElem nostripQualif opts then prt else prExp
+
+--- to get rid of brackets in the editor
+prRefinement t = case t of
+    Q m c  -> prQIdent (m,c)
+    QC m c -> prQIdent (m,c)
+    _ -> prt t

src/GF/Infra/Modules.hs

@@ -63,6 +63,9 @@ updateModule (Module  mt ms fs me ops js) i t =
 replaceJudgements :: Module i f t -> BinTree (i,t) -> Module i f t
 replaceJudgements (Module mt ms fs me ops _) js = Module mt ms fs me ops js
 
+allFlags :: MGrammar i f a -> [f]
+allFlags gr = concat $ map flags $ reverse [m | (_, ModMod m) <- modules gr]
+
 data MainGrammar i = MainGrammar {
     mainAbstract  :: i ,
     mainConcretes :: [MainConcreteSpec i]

src/GF/Infra/Option.hs

@@ -59,6 +59,9 @@ addOption o (Opts os) = iOpts (o:os)
 
 addOptions (Opts os) os0 = foldr addOption os0 os
 
+concatOptions :: [Options] -> Options
+concatOptions = foldr addOptions noOptions
+
 removeOption :: Option -> Options -> Options
 removeOption o (Opts os) = iOpts (filter (/=o) os)
 
@@ -152,6 +155,8 @@ doTrace      = iOpt "tr"
 noCPU        = iOpt "nocpu"
 doCompute    = iOpt "c"
 optimizeCanon = iOpt "opt"
+stripQualif   = iOpt "strip"
+nostripQualif = iOpt "nostrip"
 
 -- mainly for stand-alone
 useUnicode    = iOpt "unicode"

src/GF/Infra/ReadFiles.hs

@@ -2,11 +2,13 @@ module ReadFiles where
 
 import Arch (selectLater, modifiedFiles, ModTime)
 
+import Option
 import Operations
 import UseIO
 import System
 import Char
 import Monad
+import List
 
 -- make analysis for GF grammar modules. AR 11/6/2003
 
@@ -122,6 +124,14 @@ lexs s = x:xs where
       (x,y) = head $ lex s
       xs = if null y then [] else lexs y
 
+-- options can be passed to the compiler by comments in --#, in the main file
+ 
+getOptionsFromFile ::  FilePath -> IO Options
+getOptionsFromFile file = do
+  s <- readFileIf file
+  let ls = filter (isPrefixOf "--#") $ lines s
+  return $ fst $ getOptions "-" $ map (unwords . words . drop 3) ls
+
 -- old GF tolerated newlines in quotes. No more supported!
 fixNewlines s = case s of
      '"':cs -> '"':mk cs

src/GF/Shell/CommandL.hs

@@ -51,7 +51,7 @@ getCommandUTF = do
 
 pCommand = pCommandWords . words where 
   pCommandWords s = case s of
-    "n" : cat : _ -> CNewCat (strings2Cat cat)
+    "n" : cat : _ -> CNewCat cat
     "t" : ws      -> CNewTree $ unwords ws
     "g" : ws      -> CRefineWithTree $ unwords ws  -- *g*ive
     "p" : ws      -> CRefineParse $ unwords ws

src/GF/Shell/Commands.hs

@@ -6,9 +6,10 @@ import Zipper
 import qualified Grammar as G ---- Cat, Fun, Q, QC
 import GFC
 import CMacros
+import Macros (qq)----
 import LookAbs
 import Look
-import Values (loc2treeFocus)----
+import Values (loc2treeFocus,tree2exp)----
 
 import GetTree
 import API
@@ -46,7 +47,7 @@ import List (intersperse)
 -- See CommandsL for a parser of a command language.
 
 data Command =
-   CNewCat G.Cat
+   CNewCat String
  | CNewTree String
  | CAhead Int
  | CBack Int
@@ -201,7 +202,8 @@ execCommand env c s = case c of
 execECommand :: CEnv -> Command -> ECommand
 execECommand env c = case c of
   CNewCat cat        -> action2commandNext $ \x -> do
-                          s' <- newCat cgr cat x
+                          cat' <- string2cat sgr cat
+                          s' <- newCat cgr cat' x
                           uniqueRefinements cgr s'
   CNewTree s         -> action2commandNext $ \x -> do 
                           t  <- string2treeErr gr s 
@@ -271,6 +273,7 @@ execECommand env c = case c of
    gr   = grammarCEnv env
    der  = maybe True not $ caseYesNo (globalOptions env) noDepTypes
           -- if there are dep types, then derived refs;  deptypes is the default
+   abs = absId sgr
 
 --
 
@@ -285,7 +288,7 @@ string2varPair s = case words s of
 cMenuDisplay :: String -> Command
 cMenuDisplay s = CAddOption (menuDisplay s)
 
-newCatMenu env = [(CNewCat c, printname env initSState c) | 
+newCatMenu env = [(CNewCat (prQIdent c), printname env initSState c) | 
                                   (c,[]) <- allCatsOf (canCEnv env)]
 
 mkRefineMenu :: CEnv -> SState -> [(Command,String)]
@@ -302,8 +305,7 @@ mkRefineMenuAll env sstate =
        [(CAddClip,     (ifShort "ac" "AddClip",  "ac"))]
     (refs,[],_)   -> 
        [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs] ++
-       [(CRefineWithClip i, prClip i t e) | (i,t) <- possClipsSState gr sstate, 
+       [(CRefineWithClip i, prClip i t) | (i,t) <- possClipsSState gr sstate] 
-                                            let e = tree2string t]
     (_,cands,_)   -> 
        [(CSelectCand i,   prCand (t,i))    | (t,i) <- zip cands [0..]]
 
@@ -311,8 +313,8 @@ mkRefineMenuAll env sstate =
   prRef (f,t) = 
     (ifShort "r" "Refine" +++ prOrLinRef f +++ ifTyped (":" +++ prt t),
      "r" +++ prRefinement f)
-  prClip i t e =
+  prClip i t =
-    (ifShort "rc" "Paste" +++ prOrLinTree t e,
+    (ifShort "rc" "Paste" +++ prOrLinTree t,
      "rc" +++ show i)
   prChangeHead f = 
     (ifShort "ch" "ChangeHead" +++ prOrLinFun f,
@@ -339,10 +341,10 @@ mkRefineMenuAll env sstate =
     G.QC m f ->  printname env sstate (m,f) 
     _ -> prt t
   prOrLinFun = printname env sstate
-  prOrLinTree t e = case getOptVal opts menuDisplay of
+  prOrLinTree t = case getOptVal opts menuDisplay of
-    Just "Abs" -> e
+    Just "Abs" -> prTermOpt opts $ tree2exp t
     Just lang  -> prQuotedString $ lin lang t
-    _ -> e
+    _ -> prTermOpt opts $ tree2exp t
   lin lang t = optLinearizeTreeVal opts (stateGrammarOfLang env (language lang)) t
 
 -- there are three orthogonal parameters: Abs/[conc], short/long, typed/untyped
@@ -364,6 +366,8 @@ displayCommandMenu :: CEnv -> [(Command,String)]
 displayCommandMenu env =
   [(CAddOption (menuDisplay s), s) | s <- "Abs" : langs] ++
   [(CAddOption (sizeDisplay s), s) | s <- ["short", "long"]] ++
+  [(fo nostripQualif, s) | (fo,s) <- [(CAddOption,"qualified"),
+                                      (CRemoveOption,"unqualified")]] ++
   [(CAddOption (typeDisplay s), s) | s <- ["typed", "untyped"]]
  where
    langs = map prLanguage $ allLanguages env
@@ -456,7 +460,7 @@ printname :: CEnv -> SState -> G.Fun -> String
 printname env state f = case getOptVal opts menuDisplay of
   Just "Abs" -> prQIdent f
   Just lang  -> printn lang f
-  _ -> prQIdent f
+  _ -> prTermOpt opts (qq f)
  where
   opts = addOptions (optsSState state) (globalOptions env)
   printn lang f = err id (ifNull (prQIdent f) (sstr . head)) $ do

src/GF/Text/Text.hs

@@ -31,15 +31,23 @@ formatAsText = unwords . format . cap . words where
   para  = (=="<p>") 
 
 formatAsCode :: String -> String
-formatAsCode = unwords . format . words where
+formatAsCode = rend 0 . words where
-  format ws = case ws of
+  -- render from BNF Converter
-    p : w : ww | parB p -> format ((p ++ w') : ww') where (w':ww') = format (w:ww)
+  rend i ss = case ss of
-    w : p : ww | par  p -> format ((w ++ p') : ww') where (p':ww') = format (p:ww)
+    "["      :ts -> cons "["  $ rend i ts
-    w     : ww           -> w        : format ww
+    "("      :ts -> cons "("  $ rend i ts
-    [] -> []
+    "{"      :ts -> cons "{"  $ new (i+1) $ rend (i+1) ts
-  parB = flip elem (map singleton "([{")
+    "}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts
-  parE = flip elem (map singleton "}])")
+    "}"      :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts
-  par t = parB t || parE t
+    ";"      :ts -> cons ";"  $ new i $ rend i ts
+    t  : "," :ts -> cons t    $ space "," $ rend i ts
+    t  : ")" :ts -> cons t    $ cons ")"  $ rend i ts
+    t  : "]" :ts -> cons t    $ cons "]"  $ rend i ts
+    t        :ts -> space t   $ rend i ts
+    _            -> ""
+  cons s t  = s ++ t
+  new i s   = '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s
+  space t s = if null s then t else t ++ " " ++ s
 
 performBinds :: String -> String
 performBinds = unwords . format . words where

src/GF/UseGrammar/GetTree.hs

@@ -44,3 +44,9 @@ string2ref gr s =
   if elem '.' s 
     then return $ uncurry G.Q $ strings2Fun s
     else return $ G.Vr $ identC s
+
+string2cat :: StateGrammar -> String -> Err G.Cat
+string2cat gr s = 
+  if elem '.' s 
+    then return $ strings2Fun s
+    else return $ curry id (absId gr) (identC s)

src/GF/UseGrammar/Linear.hs

@@ -12,7 +12,7 @@ import LookAbs
 import MMacros
 import TypeCheck (annotate) ----
 import Str
-import Unlex
+import Text
 ----import TypeCheck -- to annotate
 
 import Operations
@@ -105,10 +105,14 @@ linLab0 = L (identC "s")
 sTables2strs :: [[([Patt],[Str])]] -> [[Str]]
 sTables2strs = map snd . concat
 
--- from this, to get a list of strings --- customize unlexer
+-- from this, to get a list of strings
 strs2strings :: [[Str]] -> [String]
 strs2strings = map unlex
 
+-- this is just unwords; use an unlexer from Text to postprocess
+unlex :: [Str] -> String
+unlex = performBinds . concat . map sstr . take 1 ----
+
 -- finally, a top-level function to get a string from an expression
 linTree2string :: Marker -> CanonGrammar -> Ident -> A.Tree -> String
 linTree2string mk gr m e = err id id $ do

src/GF/UseGrammar/Tokenize.hs

@@ -21,7 +21,11 @@ tokVars :: String -> [CFTok]
 tokVars = map mkCFTokVar . words
 
 mkCFTok :: String -> CFTok
-mkCFTok s = tS s ---- if (isLiteral s) then (mkLit s) else (tS s)
+mkCFTok s = case s of
+  '"' :cs@(_:_) -> tL $ init cs
+  '\'':cs@(_:_) -> tL $ init cs --- 's Gravenhage
+  _:_ | all isDigit s -> tI s
+  _ -> tS s
 
 mkCFTokVar :: String -> CFTok
 mkCFTokVar s = case s of

src/Today.hs

@@ -1 +1 @@
-module Today where today = "Fri Oct 24 16:27:10 CEST 2003"
+module Today where today = "Mon Nov  3 17:53:59 CET 2003"