Merge remote-tracking branch 'origin/master' into criterion

semantic.cabal

@@ -163,6 +163,7 @@ library
                      , pointed
                      , recursion-schemes
                      , semigroups
+                     , scientific
                      , split
                      , stm-chans
                      , template-haskell

src/Control/Abstract/Value.hs

@@ -10,6 +10,7 @@ import Data.Abstract.Environment
 import Data.Abstract.FreeVariables
 import Data.Abstract.Value as Value
 import Data.Abstract.Type as Type
+import Data.Scientific (Scientific)
 import Prologue
 import Prelude hiding (fail)
 
@@ -29,6 +30,9 @@ class (MonadEvaluator t v m) => MonadValue t v m where
   -- | Construct an abstract string value.
   string :: ByteString -> m v
 
+  -- | Construct a floating-point value.
+  float :: Scientific -> m v
+
   -- | Eliminate boolean values. TODO: s/boolean/truthy
   ifthenelse :: v -> m v -> m v -> m v
 
@@ -51,6 +55,7 @@ instance ( FreeVariables t
   integer = pure . inj . Integer
   boolean = pure . inj . Boolean
   string  = pure . inj . Value.String
+  float   = pure . inj . Value.Float
 
   ifthenelse cond if' else'
     | Just (Boolean b) <- prj cond = if b then if' else else'
@@ -83,6 +88,7 @@ instance (Alternative m, MonadEvaluator t Type m, MonadFresh m) => MonadValue t
   integer _ = pure Int
   boolean _ = pure Bool
   string _  = pure Type.String
+  float _   = pure Type.Float
 
   ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')
 

src/Data/Abstract/Type.hs

@@ -13,6 +13,7 @@ data Type
   | Bool           -- ^ Primitive boolean type.
   | String         -- ^ Primitive string type.
   | Unit           -- ^ The unit type.
+  | Float          -- ^ Floating-point type.
   | Type :-> Type  -- ^ Binary function types.
   | Var TName      -- ^ A type variable.
   | Product [Type] -- ^ N-ary products.

src/Data/Abstract/Value.hs

@@ -8,8 +8,9 @@ import Data.Abstract.FreeVariables
 import Data.Abstract.Live
 import qualified Data.Abstract.Type as Type
 import qualified Data.Set as Set
+import Data.Scientific (Scientific)
 import Prologue
-import Prelude hiding (Integer, String, fail)
+import Prelude hiding (Float, Integer, String, fail)
 import qualified Prelude
 
 type ValueConstructors location
@@ -17,6 +18,7 @@ type ValueConstructors location
     , Interface location
     , Unit
     , Boolean
+    , Float
     , Integer
     , String
     ]
@@ -75,6 +77,14 @@ instance Eq1 String where liftEq = genericLiftEq
 instance Ord1 String where liftCompare = genericLiftCompare
 instance Show1 String where liftShowsPrec = genericLiftShowsPrec
 
+-- | Float values.
+newtype Float term = Float Scientific
+  deriving (Eq, Generic1, Ord, Show)
+
+instance Eq1 Float where liftEq = genericLiftEq
+instance Ord1 Float where liftCompare = genericLiftCompare
+instance Show1 Float where liftShowsPrec = genericLiftShowsPrec
+
 -- | The environment for an abstract value type.
 type EnvironmentFor v = Environment (LocationFor v) v
 

src/Data/Syntax/Literal.hs

@@ -1,10 +1,15 @@
-{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses #-}
+{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, TypeApplications #-}
 module Data.Syntax.Literal where
 
 import Data.Abstract.Evaluatable
-import Data.ByteString.Char8 (readInteger)
+import Data.ByteString.Char8 (readInteger, unpack)
+import qualified Data.ByteString.Char8 as B
+import Data.Monoid (Endo (..), appEndo)
+import Data.Scientific (Scientific)
 import Diffing.Algorithm
+import Prelude hiding (Float, fail)
 import Prologue hiding (Set)
+import Text.Read (readMaybe)
 
 -- Boolean
 
@@ -45,16 +50,52 @@ instance Evaluatable Data.Syntax.Literal.Integer where
 -- TODO: Consider a Numeric datatype with FloatingPoint/Integral/etc constructors.
 
 -- | A literal float of unspecified width.
-newtype Float a = Float { floatContent :: ByteString }
+newtype Float a = Float { floatContent  :: ByteString }
   deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
 
 instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
 instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
 instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for Float
-instance Evaluatable Data.Syntax.Literal.Float
+-- | Ensures that numbers of the form '.52' are parsed correctly. Most languages need this.
+padWithLeadingZero :: ByteString -> ByteString
+padWithLeadingZero b
+  | fmap fst (B.uncons b) == Just '.' = B.cons '0' b
+  | otherwise                         = b
 
+-- | As @padWithLeadingZero@, but on the end. Not all languages need this.
+padWithTrailingZero :: ByteString -> ByteString
+padWithTrailingZero b
+  | fmap snd (B.unsnoc b) == Just '.' = B.snoc b '0'
+  | otherwise                         = b
+
+-- | Removes underscores in numeric literals. Python 3 and Ruby support this, whereas Python 2, JS, and Go do not.
+removeUnderscores :: ByteString -> ByteString
+removeUnderscores = B.filter (/= '_')
+
+-- | Strip suffixes from floating-point literals so as to handle Python's
+--   TODO: tree-sitter-python needs some love so that it parses j-suffixed floats as complexen
+dropAlphaSuffix :: ByteString -> ByteString
+dropAlphaSuffix = B.takeWhile (\x -> x `notElem` ("lLjJiI" :: [Char]))
+
+-- | This is the shared function that munges a bytestring representation of a float
+--   so that it can be parsed to a @Scientific@ later. It takes as its arguments a list of functions, which
+--   will be some combination of the above 'ByteString -> ByteString' functions. This is meant
+--   to be called from an @Assignment@, hence the @MonadFail@ constraint. Caveat: the list is
+--   order-dependent; the rightmost function will be applied first.
+normalizeFloatString :: MonadFail m => [ByteString -> ByteString] -> ByteString -> m (Float a)
+normalizeFloatString preds val =
+  let munger = appEndo (foldMap Endo preds)
+  in case readMaybe @Scientific (unpack (munger val)) of
+    Nothing -> fail ("Invalid floating-point value: " <> show val)
+    Just _  -> pure (Float val)
+
+instance Evaluatable Data.Syntax.Literal.Float where
+  eval (Float s) = do
+    sci <- case readMaybe (unpack s) of
+      Just s  -> pure s
+      Nothing -> fail ("Bug: non-normalized float string: " <> show s)
+    float sci
 
 -- Rational literals e.g. `2/3r`
 newtype Rational a = Rational ByteString

src/Language/Go/Assignment.hs

@@ -225,7 +225,7 @@ fieldIdentifier :: Assignment
 fieldIdentifier = makeTerm <$> symbol FieldIdentifier <*> (Syntax.Identifier <$> source)
 
 floatLiteral :: Assignment
-floatLiteral = makeTerm <$> symbol FloatLiteral <*> (Literal.Float <$> source)
+floatLiteral = makeTerm <$> symbol FloatLiteral <*> (source >>= Literal.normalizeFloatString [Literal.padWithLeadingZero, Literal.dropAlphaSuffix])
 
 identifier :: Assignment
 identifier =  makeTerm <$> (symbol Identifier <|> symbol Identifier') <*> (Syntax.Identifier <$> source)

src/Language/JSON/Assignment.hs

@@ -50,7 +50,7 @@ array :: Assignment
 array = makeTerm <$> symbol Array <*> children (Literal.Array <$> many jsonValue)
 
 number :: Assignment
-number = makeTerm <$> symbol Number <*> (Literal.Float <$> source)
+number = makeTerm <$> symbol Number <*> (source >>= Literal.normalizeFloatString [Literal.padWithLeadingZero])
 
 string :: Assignment
 string = makeTerm <$> symbol String <*> (Literal.TextElement <$> source)

src/Language/PHP/Assignment.hs

@@ -470,7 +470,7 @@ literal :: Assignment
 literal = integer <|> float <|> string
 
 float :: Assignment
-float = makeTerm <$> symbol Float <*> (Literal.Float <$> source)
+float = makeTerm <$> symbol Float <*> (source >>= Literal.normalizeFloatString [Literal.padWithLeadingZero])
 
 integer :: Assignment
 integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source)

src/Language/Python/Assignment.hs

@@ -364,7 +364,11 @@ concatenatedString :: Assignment
 concatenatedString = makeTerm <$> symbol ConcatenatedString <*> children (manyTerm string)
 
 float :: Assignment
-float = makeTerm <$> symbol Float <*> (Literal.Float <$> source)
+float = makeTerm <$> symbol Float <*> (source >>= Literal.normalizeFloatString [ Literal.padWithLeadingZero
+                                                                               , Literal.padWithTrailingZero
+                                                                               , Literal.dropAlphaSuffix
+                                                                               , Literal.removeUnderscores
+                                                                               ])
 
 integer :: Assignment
 integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source)

src/Language/Ruby/Assignment.hs

@@ -166,7 +166,7 @@ literal =
   <|> makeTerm <$> token  Grammar.False    <*> pure Literal.false
   <|> makeTerm <$> token  Grammar.Nil      <*> pure Literal.Null
   <|> makeTerm <$> symbol Grammar.Integer  <*> (Literal.Integer <$> source)
-  <|> makeTerm <$> symbol Grammar.Float    <*> (Literal.Float <$> source)
+  <|> makeTerm <$> symbol Grammar.Float    <*> (source >>= Literal.normalizeFloatString [Literal.padWithLeadingZero, Literal.removeUnderscores])
   <|> makeTerm <$> symbol Grammar.Rational <*> (Literal.Rational <$> source)
   <|> makeTerm <$> symbol Grammar.Complex  <*> (Literal.Complex <$> source)
    -- TODO: Do we want to represent the difference between .. and ...

src/Language/TypeScript/Assignment.hs

@@ -325,7 +325,7 @@ importAlias' :: Assignment
 importAlias' = makeTerm <$> symbol Grammar.ImportAlias <*> children (TypeScript.Syntax.ImportAlias <$> term identifier <*> term (identifier <|> nestedIdentifier))
 
 number :: Assignment
-number = makeTerm <$> symbol Grammar.Number <*> (Literal.Float <$> source)
+number = makeTerm <$> symbol Grammar.Number <*> (source >>= Literal.normalizeFloatString [Literal.padWithLeadingZero])
 
 string :: Assignment
 string = makeTerm <$> symbol Grammar.String <*> (Literal.TextElement <$> source)