diff --git a/src/GF.hs b/src/GF.hs index a75f4ee0c..122d52766 100644 --- a/src/GF.hs +++ b/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) - _ -> return emptyShellState + _ -> useIOE emptyShellState $ foldM (shellStateFromFiles os) emptyShellState fs + --- _ -> return emptyShellState if null fs then return () else putCPU if java then sessionLineJ st else do gfInteract (initHState st) diff --git a/src/GF/API.hs b/src/GF/API.hs index db2e4a066..927c9683c 100644 --- a/src/GF/API.hs +++ b/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 diff --git a/src/GF/CF/CFIdent.hs b/src/GF/CF/CFIdent.hs index ab86b8bd4..02343bfb7 100644 --- a/src/GF/CF/CFIdent.hs +++ b/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 -{- ---- -string2CFFun :: String -> CFFun -string2CFFun = consCFFun . Ident --} +stringCFFun :: String -> CFFun +stringCFFun = mkCFFun . AS + +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 diff --git a/src/GF/CF/CanonToCF.hs b/src/GF/CF/CanonToCF.hs index 6f7dc6d6b..6651b0100 100644 --- a/src/GF/CF/CanonToCF.hs +++ b/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 - return $ CF (groupCFRules rules, predef) + let grules = groupCFRules rules + 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, varCFFun x) | TV x <- [s], cat <- cats] ++ - [(cat, lit) | TL t <- [s], Just (cat,lit) <- [getCFLiteral t]] ++ - [(cat, lit) | TI i <- [s], Just (cat,lit) <- [getCFLiteral (show i)]] --- --} + [(cat, metaCFFun) | TM _ _ <- [s], cat <- cats] ++ + [(cat, varCFFun x) | TV x <- [s], cat <- cats] ++ + [(cfCatString, stringCFFun t) | TL t <- [s]] ++ + [(cfCatInt, intCFFun t) | TI t <- [s]] diff --git a/src/GF/Canon/Look.hs b/src/GF/Canon/Look.hs index 4318239b6..2126edd60 100644 --- a/src/GF/Canon/Look.hs +++ b/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 diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs index 4822cf2b4..a1b1758fb 100644 --- a/src/GF/Compile/Compile.hs +++ b/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 - let ps = pathListOpts opts +compileModule opts1 st0 file = do + 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 - files <- getAllFiles ps rfs file + let st = st0 --- if useFileOpt then emptyShellState else st0 + 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 ---- diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs index 51e05abd0..ad1566f1f 100644 --- a/src/GF/Compile/ShellState.hs +++ b/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 ---- } diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs index 03197ea02..607b766da 100644 --- a/src/GF/Grammar/PrGrammar.hs +++ b/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 diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index ed3e2db83..5d2e0fd15 100644 --- a/src/GF/Infra/Modules.hs +++ b/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] diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs index 59e9f352a..100ded735 100644 --- a/src/GF/Infra/Option.hs +++ b/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" diff --git a/src/GF/Infra/ReadFiles.hs b/src/GF/Infra/ReadFiles.hs index bc2706b49..285665747 100644 --- a/src/GF/Infra/ReadFiles.hs +++ b/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 diff --git a/src/GF/Shell/CommandL.hs b/src/GF/Shell/CommandL.hs index dcf62d44b..c3d159574 100644 --- a/src/GF/Shell/CommandL.hs +++ b/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 diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs index 649afb682..aac758ae7 100644 --- a/src/GF/Shell/Commands.hs +++ b/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, - let e = tree2string t] + [(CRefineWithClip i, prClip i t) | (i,t) <- possClipsSState gr sstate] (_,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 = - (ifShort "rc" "Paste" +++ prOrLinTree t e, + prClip i t = + (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 - Just "Abs" -> e + prOrLinTree t = case getOptVal opts menuDisplay of + 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 diff --git a/src/GF/Text/Text.hs b/src/GF/Text/Text.hs index 08e897a9b..2fbf97fd3 100644 --- a/src/GF/Text/Text.hs +++ b/src/GF/Text/Text.hs @@ -31,15 +31,23 @@ formatAsText = unwords . format . cap . words where para = (=="

") formatAsCode :: String -> String -formatAsCode = unwords . format . words where - format ws = case ws of - p : w : ww | parB p -> format ((p ++ w') : ww') where (w':ww') = format (w:ww) - w : p : ww | par p -> format ((w ++ p') : ww') where (p':ww') = format (p:ww) - w : ww -> w : format ww - [] -> [] - parB = flip elem (map singleton "([{") - parE = flip elem (map singleton "}])") - par t = parB t || parE t +formatAsCode = rend 0 . words where + -- render from BNF Converter + rend i ss = case ss of + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + "{" :ts -> cons "{" $ new (i+1) $ rend (i+1) ts + "}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts + "}" :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts + ";" :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 diff --git a/src/GF/UseGrammar/GetTree.hs b/src/GF/UseGrammar/GetTree.hs index 9b545c7dd..9ad91c21f 100644 --- a/src/GF/UseGrammar/GetTree.hs +++ b/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) diff --git a/src/GF/UseGrammar/Linear.hs b/src/GF/UseGrammar/Linear.hs index 929273562..a46200b36 100644 --- a/src/GF/UseGrammar/Linear.hs +++ b/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 diff --git a/src/GF/UseGrammar/Tokenize.hs b/src/GF/UseGrammar/Tokenize.hs index dd0879931..ac28276f5 100644 --- a/src/GF/UseGrammar/Tokenize.hs +++ b/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 diff --git a/src/Today.hs b/src/Today.hs index 09acfaae2..9053efb0d 100644 --- a/src/Today.hs +++ b/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"