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

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