GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

floats in GF and GFC (parsing user input still doesn't work)

Browse Source
This commit is contained in:
aarne
2005-12-02 13:13:14 +00:00
parent 50ddb387f4
commit dea5158cbf
34 changed files with 2366 additions and 2185 deletions
Download Patch File Download Diff File Expand all files Collapse all files

25
src/GF/CF/CFIdent.hs
View File

@@ -14,17 +14,18 @@
module GF.CF.CFIdent (-- * Tokens and categories
CFTok(..), CFCat(..),
tS, tC, tL, tI, tV, tM, tInt,
tS, tC, tL, tI, tF, tV, tM, tInt,
prCFTok,
-- * Function names and profiles
CFFun(..), Profile,
wordsCFTok,
-- * CF Functions
mkCFFun, varCFFun, consCFFun, string2CFFun, stringCFFun, intCFFun, dummyCFFun,
mkCFFun, varCFFun, consCFFun, string2CFFun, stringCFFun,
intCFFun, floatCFFun, dummyCFFun,
cfFun2String, cfFun2Ident, cfFun2Profile, metaCFFun,
-- * CF Categories
mkCIdent, ident2CFCat, labels2CFCat, string2CFCat,
catVarCF, cat2CFCat, cfCatString, cfCatInt,
catVarCF, cat2CFCat, cfCatString, cfCatInt,cfCatFloat,
moduleOfCFCat, cfCat2Cat, cfCat2Ident, lexCFCat,
-- * CF Tokens
string2CFTok, str2cftoks,
@@ -48,7 +49,8 @@ data CFTok =
TS String -- ^ normal strings
| TC String -- ^ strings that are ambiguous between upper or lower case
| TL String -- ^ string literals
| TI Int -- ^ integer literals
| TI Integer -- ^ integer literals
| TF Double -- ^ float literals
| TV Ident -- ^ variables
| TM Int String -- ^ metavariables; the integer identifies it
deriving (Eq, Ord, Show)
@@ -60,6 +62,7 @@ tS :: String -> CFTok
tC :: String -> CFTok
tL :: String -> CFTok
tI :: String -> CFTok
tF :: String -> CFTok
tV :: String -> CFTok
tM :: String -> CFTok
@@ -67,10 +70,11 @@ tS = TS
tC = TC
tL = TL
tI = TI . read
tF = TF . read
tV = TV . identC
tM = TM 0
tInt :: Int -> CFTok
tInt :: Integer -> CFTok
tInt = TI
prCFTok :: CFTok -> String
@@ -79,6 +83,7 @@ prCFTok t = case t of
TC s -> s
TL s -> s
TI i -> show i
TF i -> show i
TV x -> prt x
TM i m -> m --- "?" --- m
@@ -113,8 +118,11 @@ string2CFFun m c = consCFFun $ mkCIdent m c
stringCFFun :: String -> CFFun
stringCFFun = mkCFFun . AS
intCFFun :: Int -> CFFun
intCFFun = mkCFFun . AI . toInteger
intCFFun :: Integer -> CFFun
intCFFun = mkCFFun . AI
floatCFFun :: Double -> CFFun
floatCFFun = mkCFFun . AF
-- | used in lexer-by-need rules
dummyCFFun :: CFFun
@@ -166,8 +174,9 @@ cat2CFCat = uncurry idents2CFCat
cfCatString :: CFCat
cfCatString = string2CFCat (prt cPredefAbs) "String"
cfCatInt :: CFCat
cfCatInt, cfCatFloat :: CFCat
cfCatInt = string2CFCat (prt cPredefAbs) "Int"
cfCatFloat = string2CFCat (prt cPredefAbs) "Float"

3
src/GF/CF/CanonToCF.hs
View File

@@ -190,7 +190,8 @@ mkCFPredef opts binds rules = (ruls, \s -> preds0 s ++ look s) where
[(cat, metaCFFun) | TM _ _ <- [s], cat <- cats] ++
[(cat, varCFFun x) | TV x <- [s], cat <- catVarCF : bindcats] ++
[(cfCatString, stringCFFun t) | TL t <- [s]] ++
[(cfCatInt, intCFFun t) | TI t <- [s]]
[(cfCatInt, intCFFun t) | TI t <- [s]] ++
[(cfCatFloat, floatCFFun t) | TF t <- [s]]
cats = nub [c | (_,rs) <- rules, (_,(_,its)) <- rs, CFNonterm c <- its]
bindcats = [c | c <- cats, elem (cfCat2Ident c) binds]
look = concatMap snd . map (trieLookup preds) . wordsCFTok --- for TC tokens

4
src/GF/Canon/AbsGFC.hs
View File

@@ -90,6 +90,7 @@ data APatt =
| APV Ident
| APS String
| API Integer
| APF Double
| APW
deriving (Eq,Ord,Show)
@@ -100,6 +101,7 @@ data Atom =
| AM Integer
| AS String
| AI Integer
| AF Double
| AT Sort
deriving (Eq,Ord,Show)
@@ -132,6 +134,7 @@ data Term =
| C Term Term
| FV [Term]
| EInt Integer
| EFloat Double
| K Tokn
| E
deriving (Eq,Ord,Show)
@@ -170,6 +173,7 @@ data Patt =
| PW
| PR [PattAssign]
| PI Integer
| PF Double
deriving (Eq,Ord,Show)
data PattAssign =

2
src/GF/Canon/CMacros.hs
View File

@@ -130,6 +130,7 @@ term2patt trm = case trm of
return (PR (map (uncurry PAss) (zip ll aa')))
LI x -> return $ PV x
EInt i -> return $ PI i
EFloat i -> return $ PF i
FV (t:_) -> term2patt t ----
_ -> prtBad "no pattern corresponds to term" trm
@@ -140,6 +141,7 @@ patt2term p = case p of
PW -> anyTerm ----
PR pas -> R [ Ass lbl (patt2term q) | PAss lbl q <- pas ]
PI i -> EInt i
PF i -> EFloat i
anyTerm :: Term
anyTerm = LI (A.identC "_") --- should not happen

6
src/GF/Canon/CanonToGrammar.hs
View File

@@ -156,7 +156,8 @@ redCTerm x = case x of
C term0 term -> liftM2 G.C (redCTerm term0) (redCTerm term)
FV terms -> liftM G.FV $ mapM redCTerm terms
K (KS str) -> return $ G.K str
EInt i -> return $ G.EInt $ fromInteger i
EInt i -> return $ G.EInt i
EFloat i -> return $ G.EFloat i
E -> return $ G.Empty
K (KP d vs) -> return $
G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs])
@@ -187,6 +188,7 @@ redPatt p = case p of
ls' = map redLabel ls
ts <- mapM redPatt ts
return $ G.PR $ zip ls' ts
PI i -> return $ G.PInt (fromInteger i)
PI i -> return $ G.PInt i
PF i -> return $ G.PFloat i
_ -> Bad $ "cannot recompile pattern" +++ show p

5
src/GF/Canon/GFC.cf
View File

@@ -80,6 +80,7 @@ APC. APatt ::= "(" CIdent [APatt] ")" ;
APV. APatt ::= Ident ;
APS. APatt ::= String ;
API. APatt ::= Integer ;
APF. APatt ::= Double ;
APW. APatt ::= "_" ;
separator Decl ";" ;
@@ -120,7 +121,8 @@ S. Term1 ::= Term1 "!" Term2 ;
C. Term ::= Term "++" Term1 ;
FV. Term1 ::= "variants" "{" [Term2] "}" ; --- no separator!
EInt. Term2 ::= Integer ;
EInt. Term2 ::= Integer ;
EFloat. Term2 ::= Double ;
K. Term2 ::= Tokn ;
E. Term2 ::= "[" "]" ;
@@ -144,6 +146,7 @@ PV. Patt ::= Ident ;
PW. Patt ::= "_" ;
PR. Patt ::= "{" [PattAssign] "}" ;
PI. Patt ::= Integer ;
PF. Patt ::= Double ;
PAss. PattAssign ::= Label "=" Patt ;

91
src/GF/Canon/LexGFC.hs
View File

File diff suppressed because one or more lines are too long

1473
src/GF/Canon/ParGFC.hs
View File

File diff suppressed because one or more lines are too long

3
src/GF/Canon/PrintGFC.hs
View File

@@ -231,6 +231,7 @@ instance Print APatt where
APV id -> prPrec i 0 (concatD [prt 0 id])
APS str -> prPrec i 0 (concatD [prt 0 str])
API n -> prPrec i 0 (concatD [prt 0 n])
APF n -> prPrec i 0 (concatD [prt 0 n])
APW -> prPrec i 0 (concatD [doc (showString "_")])
prtList es = case es of
@@ -292,6 +293,7 @@ instance Print Term where
C term0 term -> prPrec i 0 (concatD [prt 0 term0 , doc (showString "++") , prt 1 term])
FV terms -> prPrec i 1 (concatD [docs (showString "variants") , doc (showString "{") , prt 2 terms , doc (showString "}")])
EInt n -> prPrec i 2 (concatD [prt 0 n])
EFloat n -> prPrec i 2 (concatD [prt 0 n])
K tokn -> prPrec i 2 (concatD [prt 0 tokn])
E -> prPrec i 2 (concatD [doc (showString "[") , doc (showString "]")])
@@ -356,6 +358,7 @@ instance Print Patt where
PW -> prPrec i 0 (concatD [docs (showString "_")])
PR pattassigns -> prPrec i 0 (concatD [doc (showString "{") , prt 0 pattassigns , doc (showString "}")])
PI n -> prPrec i 0 (concatD [prt 0 n])
PF n -> prPrec i 0 (concatD [prt 0 n])
prtList es = case es of
[] -> (concatD [])

4
src/GF/Compile/CheckGrammar.hs
View File

@@ -279,6 +279,7 @@ computeLType gr t = do
App (Q (IC "Predef") (IC "Ints")) _ -> return ty ---- shouldn't be needed
Q (IC "Predef") (IC "Int") -> return ty ---- shouldn't be needed
Q (IC "Predef") (IC "Float") -> return ty ---- shouldn't be needed
Q m c | elem c [cPredef,cPredefAbs] -> return ty
@@ -416,6 +417,8 @@ inferLType gr trm = case trm of
EInt i -> return (trm, typeInt)
EFloat i -> return (trm, typeFloat)
Empty -> return (trm, typeTok)
C s1 s2 ->
@@ -508,6 +511,7 @@ inferLType gr trm = case trm of
PT _ p -> isConstPatt p
PString _ -> True
PInt _ -> True
PFloat _ -> True
_ -> False
inferPatt p = case p of

6
src/GF/Compile/GrammarToCanon.hs
View File

@@ -231,7 +231,8 @@ redCTerm t = case t of
return $ G.V ty' ts'
S u v -> liftM2 G.S (redCTerm u) (redCTerm v)
K s -> return $ G.K (G.KS s)
EInt i -> return $ G.EInt $ toInteger i
EInt i -> return $ G.EInt i
EFloat i -> return $ G.EFloat i
C u v -> liftM2 G.C (redCTerm u) (redCTerm v)
FV ts -> liftM G.FV $ mapM redCTerm ts
--- Ready ss -> return $ G.Ready [redStr ss] --- obsolete
@@ -259,7 +260,8 @@ redPatt p = case p of
ts <- mapM redPatt tts
return $ G.PR $ map (uncurry G.PAss) $ zip ls' ts
PT _ q -> redPatt q
PInt i -> return $ G.PI (toInteger i)
PInt i -> return $ G.PI i
PFloat i -> return $ G.PF i
PV x -> liftM G.PV $ redIdent x --- for parametrize optimization
_ -> prtBad "cannot reduce pattern" p

1
src/GF/Compile/Rename.hs
View File

@@ -94,6 +94,7 @@ renameIdentTerm env@(act,imps) t =
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
predefAbs c s = case c of
IC "Int" -> return $ const $ Q cPredefAbs cInt
IC "Float" -> return $ const $ Q cPredefAbs cFloat
IC "String" -> return $ const $ Q cPredefAbs cString
_ -> Bad s

12
src/GF/Grammar/AppPredefined.hs
View File

@@ -30,6 +30,7 @@ isInPredefined = err (const True) (const False) . typPredefined
typPredefined :: Ident -> Err Type
typPredefined c@(IC f) = case f of
"Int" -> return typePType
"Float" -> return typePType
"Ints" -> return $ mkFunType [cnPredef "Int"] typePType
"PBool" -> return typePType
"PFalse" -> return $ cnPredef "PBool"
@@ -65,17 +66,17 @@ appPredefined t = case t of
case f of
-- one-place functions
Q (IC "Predef") (IC f) -> case (f, x) of
("length", K s) -> retb $ EInt $ length s
("length", K s) -> retb $ EInt $ toInteger $ length s
_ -> retb t ---- prtBad "cannot compute predefined" t
-- two-place functions
App (Q (IC "Predef") (IC f)) z0 -> do
(z,_) <- appPredefined z0
case (f, norm z, norm x) of
("drop", EInt i, K s) -> retb $ K (drop i s)
("take", EInt i, K s) -> retb $ K (take i s)
("tk", EInt i, K s) -> retb $ K (take (max 0 (length s - i)) s)
("dp", EInt i, K s) -> retb $ K (drop (max 0 (length s - i)) s)
("drop", EInt i, K s) -> retb $ K (drop (fi i) s)
("take", EInt i, K s) -> retb $ K (take (fi i) s)
("tk", EInt i, K s) -> retb $ K (take (max 0 (length s - fi i)) s)
("dp", EInt i, K s) -> retb $ K (drop (max 0 (length s - fi i)) s)
("eqStr",K s, K t) -> retb $ if s == t then predefTrue else predefFalse
("occur",K s, K t) -> retb $ if substring s t then predefTrue else predefFalse
("occurs",K s, K t) -> retb $ if any (flip elem t) s then predefTrue else predefFalse
@@ -105,6 +106,7 @@ appPredefined t = case t of
norm t = case t of
Empty -> K []
_ -> t
fi = fromInteger
-- read makes variables into constants

6
src/GF/Grammar/Grammar.hs
View File

@@ -114,7 +114,8 @@ data Term =
| Con Ident -- ^ constructor
| EData -- ^ to mark in definition that a fun is a constructor
| Sort String -- ^ basic type
| EInt Int -- ^ integer literal
| EInt Integer -- ^ integer literal
| EFloat Double -- ^ floating point literal
| K String -- ^ string literal or token: @\"foo\"@
| Empty -- ^ the empty string @[]@
@@ -167,7 +168,8 @@ data Patt =
| PW -- ^ wild card pattern: @_@
| PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete
| PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract
| PInt Int -- ^ integer literal pattern: @12@ -- only abstract
| PInt Integer -- ^ integer literal pattern: @12@ -- only abstract
| PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract
| PT Type Patt -- ^ type-annotated pattern
deriving (Read, Show, Eq, Ord)

2
src/GF/Grammar/LookAbs.hs
View File

@@ -107,6 +107,7 @@ 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
EInt _ -> return valAbsInt
EFloat _ -> return valAbsFloat
K _ -> return valAbsString
_ -> prtBad "cannot refine with complex term" at ---
@@ -116,6 +117,7 @@ refsForType compat gr binds val =
[(vr i, (t,False)) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++
-- integer and string literals
[(EInt i, (val,False)) | val == valAbsInt, i <- [0,1,2,5,11,1978]] ++
[(EFloat i, (val,False)) | val == valAbsFloat, i <- [3.1415926]] ++
[(K s, (val,False)) | val == valAbsString, s <- ["foo", "NN", "x"]] ++
-- functions defined in the current abstract syntax
[(qq f, (vClos t,isRecursiveType t)) | (f,t) <- funsForType compat gr val]

2
src/GF/Grammar/Lookup.hs
View File

@@ -158,7 +158,7 @@ lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
lookupLincat gr m c | elem c [zIdent "String", zIdent "Int"] =
lookupLincat gr m c | elem c [zIdent "String", zIdent "Int", zIdent "Float"] =
return defLinType --- ad hoc; not needed?
lookupLincat gr m c = do

1
src/GF/Grammar/MMacros.hs
View File

@@ -335,6 +335,7 @@ exp2tree e = do
Meta m -> return $ AtM m
K s -> return $ AtL s
EInt n -> return $ AtI n
EFloat n -> return $ AtF n
_ -> prtBad "cannot convert to atom" f
ts <- mapM exp2tree xs
return $ Tr (N (cont,at,uVal,([],[]),True),ts)

7
src/GF/Grammar/Macros.hs
View File

@@ -287,11 +287,12 @@ typeStr = srt "Str"
typeTok = srt "Tok"
typeStrs = srt "Strs"
typeString, typeInt :: Term
typeInts :: Int -> Term
typeString, typeFloat, typeInt :: Term
typeInts :: Integer -> Term
typeString = constPredefRes "String"
typeInt = constPredefRes "Int"
typeFloat = constPredefRes "Float"
typeInts i = App (constPredefRes "Ints") (EInt i)
isTypeInts :: Term -> Bool
@@ -501,6 +502,7 @@ term2patt trm = case termForm trm of
aa' <- mapM term2patt aa
return (PR (zip ll aa'))
Ok ([],EInt i,[]) -> return $ PInt i
Ok ([],EFloat i,[]) -> return $ PFloat i
Ok ([],K s, []) -> return $ PString s
_ -> prtBad "no pattern corresponds to term" trm
@@ -513,6 +515,7 @@ patt2term pt = case pt of
PR r -> R [assign l (patt2term p) | (l,p) <- r]
PT _ p -> patt2term p
PInt i -> EInt i
PFloat i -> EFloat i
PString s -> K s
redirectTerm :: Ident -> Term -> Term

1
src/GF/Grammar/PatternMatch.hs
View File

@@ -61,6 +61,7 @@ tryMatch (p,t) = do
(PString s, ([],K i,[])) | s==i -> return []
(PString "",([],Empty,[])) -> return [] -- because "" = [""] = []
(PInt s, ([],EInt i,[])) | s==i -> return []
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
(PC p pp, ([], Con f, tt)) |
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)

1
src/GF/Grammar/PrGrammar.hs
View File

@@ -219,6 +219,7 @@ instance Print Atom where
prt (AtV i) = prt i
prt (AtL s) = s
prt (AtI i) = show i
prt (AtF i) = show i
prt_ (AtC (_,f)) = prt f
prt_ a = prt a

14
src/GF/Grammar/TC.hs
View File

@@ -32,7 +32,8 @@ data AExp =
AVr Ident Val
| ACn QIdent Val
| AType
| AInt Int
| AInt Integer
| AFloat Double
| AStr String
| AMeta MetaSymb Val
| AApp AExp AExp Val
@@ -145,11 +146,12 @@ inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)])
inferExp th tenv@(k,rho,gamma) e = case e of
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
Q m c
| m == cPredefAbs && (elem c (map identC ["Int","String"])) ->
| m == cPredefAbs && (elem c (map identC ["Int","String","Float"])) ->
return (ACn (m,c) vType, vType, [])
| otherwise -> 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, [])
EFloat i -> return (AFloat i, valAbsFloat, [])
K i -> return (AStr i, valAbsString, [])
Sort _ -> return (AType, vType, [])
App f t -> do
@@ -165,6 +167,7 @@ inferExp th tenv@(k,rho,gamma) e = case e of
where
predefAbs c s = case c of
IC "Int" -> return $ const $ Q cPredefAbs cInt
IC "Float" -> return $ const $ Q cPredefAbs cFloat
IC "String" -> return $ const $ Q cPredefAbs cString
_ -> Bad s
@@ -189,7 +192,8 @@ checkEqs th tenv@(k,rho,gamma) (fun@(m,f),def) val = case def of
PV IW -> (meta (MetaSymb i) : ps, i+1, g)
PV x -> (meta (MetaSymb i) : ps, i+1,upd x i g)
PString s -> ( K s : ps, i, g)
PInt i -> (EInt i : ps, i, g)
PInt n -> (EInt n : ps, i, g)
PFloat n -> (EFloat n : ps, i, g)
PP m c xs -> (mkApp (qq (m,c)) xss : ps, i', g')
where (xss,i',g') = foldr p2t ([],i,g) xs
_ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch"
@@ -238,7 +242,8 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
PV IW -> (meta (MetaSymb i) : ps, i+1,g,k)
PV x -> (vr x : ps, i, upd x k g,k+1)
PString s -> (K s : ps, i, g, k)
PInt i -> (EInt i : ps, i, g, k)
PInt n -> (EInt n : ps, i, g, k)
PFloat n -> (EFloat n : ps, i, g, k)
PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k')
where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
_ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch"
@@ -262,6 +267,7 @@ checkPatt th tenv exp val = do
Meta m -> return $ (AMeta m val, val, [])
Vr x -> return $ (AVr x val, val, [])
EInt i -> return (AInt i, valAbsInt, [])
EFloat i -> return (AFloat i, valAbsFloat, [])
K s -> return (AStr s, valAbsString, [])
Q m c -> do

2
src/GF/Grammar/TypeCheck.hs
View File

@@ -218,6 +218,8 @@ aexp2tree (aexp,cs) = do
return ([],AtC c,v',[])
AInt i -> do
return ([],AtI i,valAbsInt,[])
AFloat i -> do
return ([],AtF i,valAbsFloat,[])
AStr s -> do
return ([],AtL s,valAbsString,[])
AMeta m v -> do

14
src/GF/Grammar/Values.hs
View File

@@ -17,9 +17,9 @@ module GF.Grammar.Values (-- * values used in TC type checking
-- * annotated tree used in editing
Tree, TrNode(..), Atom(..), Binds, Constraints, MetaSubst,
-- * for TC
valAbsInt, valAbsString, vType,
valAbsInt, valAbsFloat, valAbsString, vType,
isPredefCat,
cType, cPredefAbs, cInt, cString,
cType, cPredefAbs, cInt, cFloat, cString,
eType, tree2exp, loc2treeFocus
) where
@@ -45,7 +45,8 @@ type Tree = Tr TrNode
newtype TrNode = N (Binds,Atom,Val,(Constraints,MetaSubst),Bool)
deriving (Eq,Show)
data Atom = AtC Fun | AtM MetaSymb | AtV Ident | AtL String | AtI Int
data Atom =
AtC Fun | AtM MetaSymb | AtV Ident | AtL String | AtI Integer | AtF Double
deriving (Eq,Show)
type Binds = [(Ident,Val)]
@@ -57,6 +58,9 @@ type MetaSubst = [(MetaSymb,Val)]
valAbsInt :: Val
valAbsInt = VCn (cPredefAbs, cInt)
valAbsFloat :: Val
valAbsFloat = VCn (cPredefAbs, cFloat)
valAbsString :: Val
valAbsString = VCn (cPredefAbs, cString)
@@ -72,6 +76,9 @@ cPredefAbs = identC "PredefAbs"
cInt :: Ident
cInt = identC "Int"
cFloat :: Ident
cFloat = identC "Float"
cString :: Ident
cString = identC "String"
@@ -89,6 +96,7 @@ tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where
AtM m -> Meta m
AtL s -> K s
AtI s -> EInt s
AtF s -> EFloat s
bi' = map fst bi
ts' = map tree2exp ts

6
src/GF/Probabilistic/Probabilistic.hs
View File

@@ -125,6 +125,7 @@ str2tr t = case t of
SMeta _ -> mkMeta 0
SString s -> K s
SInt i -> EInt i
SFloat i -> EFloat i
where
trId = cn . zIdent
@@ -142,7 +143,8 @@ data STree =
-- | SAppN (SIdent,[STree]) -- no probability given
| SMeta SCat
| SString String
| SInt Int
| SInt Integer
| SFloat Double
deriving (Show,Eq)
probTree :: STree -> Double
@@ -165,6 +167,7 @@ genTree :: [Double] -> SGrammar -> SCat -> (STree,Int)
genTree rs gr = gett rs where
gett ds "String" = (SString "foo",1)
gett ds "Int" = (SInt 1978,1)
gett ds "Float" = (SFloat 3.1415926, 1)
gett ds cat = case look cat of
[] -> (SMeta cat,1) -- if no productions, return ?
fs -> let
@@ -212,6 +215,7 @@ prSTree t = case t of
SMeta c -> '?':c
SString s -> prQuotedString s
SInt i -> show i
SFloat i -> show i
where
pr1 t@(SApp (_,ts)) = ' ' : (if null ts then id else prParenth) (prSTree t)
pr1 t = prSTree t

2
src/GF/Source/AbsGF.hs
View File

@@ -164,6 +164,7 @@ data Exp =
| ESort Sort
| EString String
| EInt Integer
| EFloat Double
| EMeta
| EEmpty
| EData
@@ -213,6 +214,7 @@ data Patt =
| PCon Ident
| PQ Ident Ident
| PInt Integer
| PFloat Double
| PStr String
| PR [PattAss]
| PTup [PattTupleComp]

2
src/GF/Source/GF.cf
View File

@@ -156,6 +156,7 @@ ECons. Exp4 ::= "%" Ident "%" ;
ESort. Exp4 ::= Sort ;
EString. Exp4 ::= String ;
EInt. Exp4 ::= Integer ;
EFloat. Exp4 ::= Double ;
EMeta. Exp4 ::= "?" ;
EEmpty. Exp4 ::= "[" "]" ;
EData. Exp4 ::= "data" ;
@@ -210,6 +211,7 @@ PV. Patt1 ::= Ident ;
PCon. Patt1 ::= "{" Ident "}" ;
PQ. Patt1 ::= Ident "." Ident ;
PInt. Patt1 ::= Integer ;
PFloat. Patt1 ::= Double ;
PStr. Patt1 ::= String ;
PR. Patt1 ::= "{" [PattAss] "}" ;
PTup. Patt1 ::= "<" [PattTupleComp] ">" ;

6
src/GF/Source/GrammarToSource.hs
View File

@@ -172,7 +172,8 @@ trt trm = case trm of
K a -> P.EString a
C a b -> P.EConcat (trt a) (trt b)
EInt i -> P.EInt $ toInteger i
EInt i -> P.EInt i
EFloat i -> P.EFloat i
Glue a b -> P.EGlue (trt a) (trt b)
Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
@@ -192,7 +193,8 @@ trp p = case p of
PP p c a -> P.PQC (tri p) (tri c) (map trp a)
PR r -> P.PR [P.PA [trLabelIdent l] (trp p) | (l,p) <- r]
PString s -> P.PStr s
PInt i -> P.PInt $ toInteger i
PInt i -> P.PInt i
PFloat i -> P.PFloat i
PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t)

88
src/GF/Source/LexGF.hs
View File

File diff suppressed because one or more lines are too long

2727
src/GF/Source/ParGF.hs
View File

File diff suppressed because one or more lines are too long

2
src/GF/Source/PrintGF.hs
View File

@@ -335,6 +335,7 @@ instance Print Exp where
ESort sort -> prPrec i 4 (concatD [prt 0 sort])
EString str -> prPrec i 4 (concatD [prt 0 str])
EInt n -> prPrec i 4 (concatD [prt 0 n])
EFloat n -> prPrec i 4 (concatD [prt 0 n])
EMeta -> prPrec i 4 (concatD [doc (showString "?")])
EEmpty -> prPrec i 4 (concatD [doc (showString "[") , doc (showString "]")])
EData -> prPrec i 4 (concatD [doc (showString "data")])
@@ -390,6 +391,7 @@ instance Print Patt where
PCon id -> prPrec i 1 (concatD [doc (showString "{0") , prt 0 id , doc (showString "}0")]) -- H
PQ id0 id -> prPrec i 1 (concatD [prt 0 id0 , doc (showString ".") , prt 0 id])
PInt n -> prPrec i 1 (concatD [prt 0 n])
PFloat n -> prPrec i 1 (concatD [prt 0 n])
PStr str -> prPrec i 1 (concatD [prt 0 str])
PR pattasss -> prPrec i 1 (concatD [doc (showString "{") , prt 0 pattasss , doc (showString "}")])
PTup patttuplecomps -> prPrec i 1 (concatD [doc (showString "<") , prt 0 patttuplecomps , doc (showString ">")])

6
src/GF/Source/SourceToGrammar.hs
View File

@@ -396,7 +396,8 @@ transExp x = case x of
EQCons m c -> liftM2 G.Q (transIdent m) (transIdent c)
EString str -> return $ G.K str
ESort sort -> liftM G.Sort $ transSort sort
EInt n -> return $ G.EInt $ fromInteger n
EInt n -> return $ G.EInt n
EFloat n -> return $ G.EFloat n
EMeta -> return $ M.meta $ M.int2meta 0
EEmpty -> return G.Empty
-- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n)
@@ -522,7 +523,8 @@ transPatt x = case x of
PV id -> liftM G.PV $ transIdent id
PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts)
PCon id -> liftM2 G.PC (transIdent id) (return [])
PInt n -> return $ G.PInt (fromInteger n)
PInt n -> return $ G.PInt n
PFloat n -> return $ G.PFloat n
PStr str -> return $ G.PString str
PR pattasss -> do
let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]

5
src/GF/UseGrammar/Generate.hs
View File

@@ -85,6 +85,7 @@ tr2str (Tr (N (_,at,val,_,_),ts)) = case (at,val) of
(AtM _, v) -> SMeta (catOf v)
(AtL s, _) -> SString s
(AtI i, _) -> SInt i
(AtF i, _) -> SFloat i
_ -> SMeta "FAILED_TO_GENERATE" ---- err monad!
where
catOf v = case v of
@@ -148,7 +149,8 @@ data STree =
SApp (SFun,[STree])
| SMeta SCat
| SString String
| SInt Int
| SInt Integer
| SFloat Double
deriving (Show,Eq)
depth :: STree -> Int
@@ -164,6 +166,7 @@ prSTree t = case t of
SMeta c -> '?':c
SString s -> prQuotedString s
SInt i -> show i
SFloat i -> show i
where
pr1 t@(SApp (_,ts)) = ' ' : (if null ts then id else prParenth) (prSTree t)
pr1 t = prSTree t

1
src/GF/UseGrammar/Linear.hs
View File

@@ -62,6 +62,7 @@ linearizeToRecord gr mk m = lin [] where
A.AtC f -> lookf c t f >>= comp xs'
A.AtL s -> return $ recS $ tK $ prt at
A.AtI i -> return $ recS $ tK $ prt at
A.AtF i -> return $ recS $ tK $ prt at
A.AtV x -> lookCat c >>= comp [tK (prt_ at)]
A.AtM m -> lookCat c >>= comp [tK (prt_ at)]

21
src/GF/UseGrammar/Tokenize.hs
View File

@@ -52,10 +52,17 @@ tokLits = map mkCFTok . mergeStr . words where
tokVars :: String -> [CFTok]
tokVars = map mkCFTokVar . words
isFloat s = case s of
c:cs | isDigit c -> isFloat cs
'.':cs@(_:_) -> all isDigit cs
_ -> False
mkCFTok :: String -> CFTok
mkCFTok s = case s of
'"' :cs@(_:_) | last cs == '"' -> tL $ init cs
'\'':cs@(_:_) | last cs == '\'' -> tL $ init cs --- 's Gravenhage
_:_ | isFloat s -> tF s
_:_ | all isDigit s -> tI s
_ -> tS s
@@ -73,10 +80,16 @@ mkTokVars tok = map tv . tok where
tv t = t
mkLit :: String -> CFTok
mkLit s = if (all isDigit s) then (tI s) else (tL s)
mkLit s
| isFloat s = tF s
| all isDigit s = tI s
| otherwise = tL s
mkTL :: String -> CFTok
mkTL s = if (all isDigit s) then (tI s) else (tL ("'" ++ s ++ "'"))
mkTL s
| isFloat s = tF s
| all isDigit s = tI s
| otherwise = tL ("'" ++ s ++ "'")
-- | Haskell lexer, usable for much code
@@ -120,7 +133,7 @@ lexC2M' isHigherOrder s = case s of
where
lexC = lexC2M' isHigherOrder
getId s = mkT i : lexC cs where (i,cs) = span isIdChar s
getLit s = tI i : lexC cs where (i,cs) = span isDigit s
getLit s = tI i : lexC cs where (i,cs) = span isDigit s ---- Float!
isIdChar c = isAlpha c || isDigit c || elem c "'_"
isSymb = reservedAnsiCSymbol
dropComment s = case s of
@@ -160,6 +173,7 @@ unknown2string :: (String -> Bool) -> [CFTok] -> [CFTok]
unknown2string isKnown = map mkOne where
mkOne t@(TS s)
| isKnown s = t
| isFloat s = tF s
| all isDigit s = tI s
| otherwise = tL s
mkOne t@(TC s) = if isKnown s then t else mkTL s
@@ -170,6 +184,7 @@ unknown2var isKnown = map mkOne where
mkOne t@(TS "??") = if isKnown "??" then t else tM "??"
mkOne t@(TS s)
| isKnown s = t
| isFloat s = tF s
| all isDigit s = tI s
| otherwise = tV s
mkOne t@(TC s) = if isKnown s then t else tV s