diff --git a/src/GF.hs b/src/GF.hs index 122d52766..bdc9a9fea 100644 --- a/src/GF.hs +++ b/src/GF.hs @@ -54,10 +54,8 @@ gfInteract st@(env,_) = do gfInteract st' Just (ICEditSession,os) -> editSession (addOptions os opts) env >> gfInteract st -{- ----- Just (ICTranslateSession,os) -> translateSession (addOptions os opts) env >> gfInteract st --} -- this is a normal command sequence _ -> do st' <- execLinesH s cs st diff --git a/src/GF/Compile/GetGrammar.hs b/src/GF/Compile/GetGrammar.hs index fb3fbf5ad..a9a40ee06 100644 --- a/src/GF/Compile/GetGrammar.hs +++ b/src/GF/Compile/GetGrammar.hs @@ -14,6 +14,7 @@ import SourceToGrammar import Option --- import Custom import ParGF +import qualified LexGF as L import ReadFiles ---- @@ -57,7 +58,7 @@ parseOldGrammar :: FilePath -> IOE ([FilePath],[A.TopDef]) parseOldGrammar file = do putStrE $ "reading old file" +++ file s <- ioeIO $ readFileIf file - A.OldGr incl topdefs <- ioeErr $ err2err $ pOldGrammar $ myLexer $ fixNewlines s + A.OldGr incl topdefs <- ioeErr $ err2err $ pOldGrammar $ oldLexer $ fixNewlines s includes <- ioeErr $ transInclude incl return (includes, topdefs) @@ -69,3 +70,13 @@ err2err (E.Bad s) = Bad s ioeEErr = ioeErr . err2err +-- To resolve the new reserved words: change them by turning the final letter to Z. +--- There is a risk of clash. + +oldLexer :: String -> [L.Token] +oldLexer = map change . L.tokens where + change t = case t of + (L.PT p (L.TS s)) | elem s new -> (L.PT p (L.TV (init s ++ "Z"))) + _ -> t + new = words $ "abstract concrete interface incomplete " ++ + "instance out open resource reuse transfer with" diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index 120286d4d..49e08ab6e 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -1,6 +1,7 @@ module Rename where import Grammar +import Values import Modules import Ident import Macros @@ -78,6 +79,8 @@ renameIdentTerm env@(act,imps) t = Vr c -> do f <- lookupTreeMany prt opens c return $ f c + Vr (IC "Int") -> return $ Q cPredefAbs cInt -- Int and String are predefined cats + Vr (IC "String") -> return $ Q cPredefAbs cString Cn c -> do f <- lookupTreeMany prt opens c return $ f c diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs index 43a8c580a..3cd8999ce 100644 --- a/src/GF/Grammar/LookAbs.hs +++ b/src/GF/Grammar/LookAbs.hs @@ -75,13 +75,20 @@ isPrimitiveFun gr (m,c) = case lookupAbsDef gr m c of lookupRef :: GFCGrammar -> Binds -> Term -> Err Val lookupRef gr binds at = case at of - Q m f -> lookupFunType gr m f >>= return . vClos - Vr i -> maybeErr ("unknown variable" +++ prt at) $ lookup i binds - _ -> prtBad "cannot refine with complex term" at --- + Q m f -> lookupFunType gr m f >>= return . vClos + Vr i -> maybeErr ("unknown variable" +++ prt at) $ lookup i binds + EInt _ -> return valAbsInt + K _ -> return valAbsString + _ -> prtBad "cannot refine with complex term" at --- refsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Binds -> Val -> [(Term,Val)] refsForType compat gr binds val = + -- bound variables [(vr i, t) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++ + -- integer and string literals + [(EInt i, val) | val == valAbsInt, i <- [0,1,2,5,11,1978]] ++ + [(K s, val) | val == valAbsString, s <- ["foo", "NN", "x"]] ++ + -- functions defined in the current abstract syntax [(qq f, vClos t) | (f,t) <- funsForType compat gr val] diff --git a/src/GF/Grammar/TC.hs b/src/GF/Grammar/TC.hs index 88e66379c..b031fa080 100644 --- a/src/GF/Grammar/TC.hs +++ b/src/GF/Grammar/TC.hs @@ -119,6 +119,8 @@ inferExp th tenv@(k,rho,gamma) e = case e of Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x Q m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) QC m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) ---- + EInt i -> return (AInt i, valAbsInt, []) + K i -> return (AStr i, valAbsString, []) Sort _ -> return (AType, vType, []) App f t -> do (f',w,csf) <- inferExp th tenv f diff --git a/src/GF/Grammar/TypeCheck.hs b/src/GF/Grammar/TypeCheck.hs index 45a0d7c36..53bf426c8 100644 --- a/src/GF/Grammar/TypeCheck.hs +++ b/src/GF/Grammar/TypeCheck.hs @@ -162,6 +162,10 @@ aexp2tree (aexp,cs) = do ACn c v -> do v' <- whnf v ---- return ([],AtC c,v',[]) + AInt i -> do + return ([],AtI i,valAbsInt,[]) + AStr s -> do + return ([],AtL s,valAbsString,[]) AMeta m v -> do v' <- whnf v ---- return ([],AtM m,v',[]) diff --git a/src/GF/Grammar/Values.hs b/src/GF/Grammar/Values.hs index 9df2fc13e..4d787488d 100644 --- a/src/GF/Grammar/Values.hs +++ b/src/GF/Grammar/Values.hs @@ -31,11 +31,18 @@ type MetaSubst = [(MetaSymb,Val)] -- for TC +valAbsInt, valAbsString :: Val +valAbsInt = VCn (cPredefAbs, cInt) +valAbsString = VCn (cPredefAbs, cString) + vType :: Val vType = VType -cType :: Ident +cType,cPredefAbs,cInt,cString :: Ident cType = identC "Type" --- #0 +cPredefAbs = identC "PredefAbs" +cInt = identC "Int" +cString = identC "String" eType :: Exp eType = Sort "Type" diff --git a/src/GF/Shell/SubShell.hs b/src/GF/Shell/SubShell.hs index c910d3dd0..1b8a647df 100644 --- a/src/GF/Shell/SubShell.hs +++ b/src/GF/Shell/SubShell.hs @@ -21,7 +21,7 @@ editSession opts st myUniFont = "-mutt-clearlyu-medium-r-normal--0-0-100-100-p-0-iso10646-1" mkOptFont = id -{- ---- + translateSession :: Options -> ShellState -> IO () translateSession opts st = do let grs = allStateGrammars st @@ -40,4 +40,3 @@ translateLoop opts trans = do if s == "." then return () else do putStrLnFlush $ trans s loopLine --} diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs index 1b4185796..d38701eb6 100644 --- a/src/GF/Source/GrammarToSource.hs +++ b/src/GF/Source/GrammarToSource.hs @@ -38,7 +38,7 @@ forName (MTConcrete a) = tri a trOpen :: OpenSpec Ident -> P.Open trOpen o = case o of - OSimple OQNormal i -> P.OQualQO P.QOCompl (tri i) + OSimple OQNormal i -> P.OName (tri i) OSimple q i -> P.OQualQO (trQualOpen q) (tri i) OQualif q i j -> P.OQual (trQualOpen q) (tri i) (tri j) diff --git a/src/GF/UseGrammar/GetTree.hs b/src/GF/UseGrammar/GetTree.hs index 9ad91c21f..0db35baf2 100644 --- a/src/GF/UseGrammar/GetTree.hs +++ b/src/GF/UseGrammar/GetTree.hs @@ -13,6 +13,8 @@ import ShellState import Operations +import Char + -- how to form linearizable trees from strings and from terms of different levels -- -- String --> raw Term --> annot, qualif Term --> Tree @@ -39,11 +41,12 @@ strings2Cat s = (identC m, identC (drop 1 c)) where (m,c) = span (/= '.') s strings2Fun = strings2Cat string2ref :: StateGrammar -> String -> Err G.Term -string2ref _ ('x':'_':ds) = return $ freshAsTerm ds --- hack for generated vars -string2ref gr s = - if elem '.' s - then return $ uncurry G.Q $ strings2Fun s - else return $ G.Vr $ identC s +string2ref gr s = case s of + 'x':'_':ds -> return $ freshAsTerm ds --- hack for generated vars + '"':_:_ -> return $ G.K $ init $ tail s + _:_ | all isDigit s -> return $ G.EInt $ read s + _ | elem '.' s -> return $ uncurry G.Q $ strings2Fun s + _ -> return $ G.Vr $ identC s string2cat :: StateGrammar -> String -> Err G.Cat string2cat gr s = diff --git a/src/Today.hs b/src/Today.hs index b1a3f414b..4d0cffe81 100644 --- a/src/Today.hs +++ b/src/Today.hs @@ -1 +1 @@ -module Today where today = "Wed Nov 5 13:15:35 CET 2003" +module Today where today = "Fri Nov 7 16:15:47 CET 2003"