summaryrefslogtreecommitdiff
path: root/src/GF/Grammar
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Grammar')
-rw-r--r--src/GF/Grammar/AppPredefined.hs12
-rw-r--r--src/GF/Grammar/Grammar.hs6
-rw-r--r--src/GF/Grammar/LookAbs.hs2
-rw-r--r--src/GF/Grammar/Lookup.hs2
-rw-r--r--src/GF/Grammar/MMacros.hs1
-rw-r--r--src/GF/Grammar/Macros.hs7
-rw-r--r--src/GF/Grammar/PatternMatch.hs1
-rw-r--r--src/GF/Grammar/PrGrammar.hs1
-rw-r--r--src/GF/Grammar/TC.hs14
-rw-r--r--src/GF/Grammar/TypeCheck.hs2
-rw-r--r--src/GF/Grammar/Values.hs14
11 files changed, 45 insertions, 17 deletions
diff --git a/src/GF/Grammar/AppPredefined.hs b/src/GF/Grammar/AppPredefined.hs
index 5a2450632..c8710f32d 100644
--- a/src/GF/Grammar/AppPredefined.hs
+++ b/src/GF/Grammar/AppPredefined.hs
@@ -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
diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
index ff5209204..4a983abcc 100644
--- a/src/GF/Grammar/Grammar.hs
+++ b/src/GF/Grammar/Grammar.hs
@@ -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)
diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs
index f0681934c..0c86ae3e9 100644
--- a/src/GF/Grammar/LookAbs.hs
+++ b/src/GF/Grammar/LookAbs.hs
@@ -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]
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
index 57806fc05..4123f450f 100644
--- a/src/GF/Grammar/Lookup.hs
+++ b/src/GF/Grammar/Lookup.hs
@@ -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
diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs
index 8370e102a..dd7331685 100644
--- a/src/GF/Grammar/MMacros.hs
+++ b/src/GF/Grammar/MMacros.hs
@@ -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)
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index 440a54562..dc4f790fd 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -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
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
index 696f19e78..db6f7dc5b 100644
--- a/src/GF/Grammar/PatternMatch.hs
+++ b/src/GF/Grammar/PatternMatch.hs
@@ -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)
diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs
index 905eb39f4..4c35089f3 100644
--- a/src/GF/Grammar/PrGrammar.hs
+++ b/src/GF/Grammar/PrGrammar.hs
@@ -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
diff --git a/src/GF/Grammar/TC.hs b/src/GF/Grammar/TC.hs
index 8cfe23408..be52d1889 100644
--- a/src/GF/Grammar/TC.hs
+++ b/src/GF/Grammar/TC.hs
@@ -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
diff --git a/src/GF/Grammar/TypeCheck.hs b/src/GF/Grammar/TypeCheck.hs
index 53c9a4ad7..97b7ff243 100644
--- a/src/GF/Grammar/TypeCheck.hs
+++ b/src/GF/Grammar/TypeCheck.hs
@@ -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
diff --git a/src/GF/Grammar/Values.hs b/src/GF/Grammar/Values.hs
index e6247cfc8..a7c58036d 100644
--- a/src/GF/Grammar/Values.hs
+++ b/src/GF/Grammar/Values.hs
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 16:51:20 +0000