msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests 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 e1504e6ba0
commit ef504a4cbe
34 changed files with 2366 additions and 2185 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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