Add support for floating point literals, and negative integers

src/Axel/AST.hs

@@ -10,9 +10,6 @@ import Axel.Prelude
 import Axel.Haskell.Language (isOperator)
 import Axel.Haskell.Macros (hygenisizeMacroName)
 import qualified Axel.Parse.AST as Parse
-  ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression,
-           Symbol)
-  )
 import Axel.Sourcemap
   ( Bracket(CurlyBraces, DoubleQuotes, Parentheses, SingleQuotes,
         SquareBrackets)
@@ -223,6 +220,7 @@ data TypeSynonym ann =
 
 data Literal ann
   = LChar ann Char
+  | LFloat ann Float
   | LInt ann Int
   | LString ann Text
   deriving (Data, Eq, Functor, Show)
@@ -354,15 +352,12 @@ instance {-# OVERLAPPING #-} HasAnnotation (Statement ann) ann where
 
 instance {-# OVERLAPPING #-} HasAnnotation (Parse.Expression ann) ann where
   getAnn :: Parse.Expression ann -> ann
-  getAnn (Parse.LiteralChar ann' _) = ann'
-  getAnn (Parse.LiteralInt ann' _) = ann'
-  getAnn (Parse.LiteralString ann' _) = ann'
-  getAnn (Parse.SExpression ann' _) = ann'
-  getAnn (Parse.Symbol ann' _) = ann'
+  getAnn = Parse.getAnn
 
 instance {-# OVERLAPPING #-} HasAnnotation (Literal ann) ann where
   getAnn :: Literal ann -> ann
   getAnn (LChar ann' _) = ann'
+  getAnn (LFloat ann' _) = ann'
   getAnn (LInt ann' _) = ann'
   getAnn (LString ann' _) = ann'
 
@@ -440,6 +435,7 @@ instance ToHaskell (Literal (Maybe SM.Expression)) where
   toHaskell literal@(LChar _ x) =
     mkHaskell literal $
     Display.surround SingleQuotes (handleCharEscapes (T.singleton x))
+  toHaskell literal@(LFloat _ x) = mkHaskell literal $ showText x
   toHaskell literal@(LInt _ x) = mkHaskell literal $ showText x
   toHaskell literal@(LString _ x) =
     mkHaskell literal $ Display.surround DoubleQuotes (handleCharEscapes x)

src/Axel/Denormalize.hs

@@ -8,7 +8,7 @@ import Axel.AST
            ERawExpression, ERecordDefinition, ERecordType)
   , Import(ImportItem, ImportType)
   , ImportSpecification(ImportAll, ImportOnly)
-  , Literal(LChar, LInt, LString)
+  , Literal(LChar, LFloat, LInt, LString)
   , SMExpression
   , SMStatement
   , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,
@@ -46,10 +46,7 @@ import Axel.AST
   , wrappedType
   )
 import qualified Axel.Parse.AST as Parse
-  ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression,
-           Symbol)
-  )
-import qualified Axel.Sourcemap as SM (Expression)
+import qualified Axel.Sourcemap as SM
 
 import Control.Lens.Operators ((^.))
 
@@ -117,6 +114,7 @@ denormalizeExpression (ELetBlock letBlock) =
 denormalizeExpression (ELiteral x) =
   case x of
     LChar _ char -> Parse.LiteralChar (getAnn' x) char
+    LFloat _ float -> Parse.LiteralFloat (getAnn' x) float
     LInt _ int -> Parse.LiteralInt (getAnn' x) int
     LString _ string -> Parse.LiteralString (getAnn' x) (T.unpack string)
 denormalizeExpression expr'@(ERawExpression _ rawSource) =

src/Axel/Normalize.hs

@@ -19,7 +19,7 @@ import Axel.AST
   , ImportSpecification(ImportAll, ImportOnly)
   , Lambda(Lambda)
   , LetBlock(LetBlock)
-  , Literal(LChar, LInt, LString)
+  , Literal(LChar, LFloat, LInt, LString)
   , MacroDefinition(MacroDefinition)
   , MacroImport(MacroImport)
   , NewtypeDeclaration(NewtypeDeclaration)
@@ -43,8 +43,8 @@ import Axel.AST
   )
 import Axel.Eff.Error (Error(NormalizeError), renderError, unsafeRunError)
 import qualified Axel.Parse.AST as Parse
-  ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression,
-           Symbol)
+  ( Expression(LiteralChar, LiteralFloat, LiteralInt, LiteralString,
+           SExpression, Symbol)
   )
 import qualified Axel.Sourcemap as SM (Expression)
 
@@ -81,6 +81,8 @@ normalizeExpression ::
   -> Sem.Sem effs (Expression (Maybe SM.Expression))
 normalizeExpression expr@(Parse.LiteralChar _ char) =
   pure $ ELiteral (LChar (Just expr) char)
+normalizeExpression expr@(Parse.LiteralFloat _ float) =
+  pure $ ELiteral (LFloat (Just expr) float)
 normalizeExpression expr@(Parse.LiteralInt _ int) =
   pure $ ELiteral (LInt (Just expr) int)
 normalizeExpression expr@(Parse.LiteralString _ string) =

src/Axel/Parse.hs

@@ -7,8 +7,8 @@ import Axel.Prelude
 import Axel.Eff.Error (Error(ParseError))
 import Axel.Haskell.Language (haskellOperatorSymbols, haskellSyntaxSymbols)
 import Axel.Parse.AST
-  ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression,
-           Symbol)
+  ( Expression(LiteralChar, LiteralFloat, LiteralInt, LiteralString,
+           SExpression, Symbol)
   , bottomUpFmapSplicing
   , getAnn
   )
@@ -34,7 +34,12 @@ import qualified Polysemy.Error as Sem
 
 import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as P
-import qualified Text.Megaparsec.Char.Lexer as P (charLiteral)
+import qualified Text.Megaparsec.Char.Lexer as P
+  ( charLiteral
+  , decimal
+  , float
+  , signed
+  )
 
 type Parser = P.Parsec Void Text
 
@@ -68,7 +73,10 @@ literalChar :: Parser SM.Expression
 literalChar = ann LiteralChar (P.string "#\\" *> P.anySingle)
 
 literalInt :: Parser SM.Expression
-literalInt = ann LiteralInt (read <$> P.some P.digitChar)
+literalInt = ann LiteralInt (P.signed mempty P.decimal)
+
+literalFloat :: Parser SM.Expression
+literalFloat = ann LiteralFloat (P.signed mempty P.float)
 
 literalList :: Parser SM.Expression
 literalList =
@@ -122,12 +130,13 @@ comment =
 
 expression :: Parser SM.Expression
 expression =
-  sExpression <|> infixSExpression <|> literalList <|> literalString <|>
+  P.try literalFloat <|> P.try literalInt <|> sExpression <|> infixSExpression <|>
+  literalList <|>
+  literalString <|>
   quotedExpression <|>
   quasiquotedExpression <|>
   spliceUnquotedExpression <|>
   unquotedExpression <|>
-  literalInt <|>
   literalChar <|>
   symbol
 

src/Axel/Parse/AST.hs

@@ -42,6 +42,7 @@ import GHC.Generics (Generic)
 --      on `Axel.Prelude` in user-facing code.
 data Expression ann
   = LiteralChar ann Char
+  | LiteralFloat ann Float
   | LiteralInt ann Int
   | LiteralString ann String
   | SExpression ann [Expression ann]
@@ -55,6 +56,7 @@ instance (Hashable ann) => Hashable (Expression ann)
 -- TODO Derive this automatically.
 getAnn :: Expression ann -> ann
 getAnn (LiteralChar ann _) = ann
+getAnn (LiteralFloat ann _) = ann
 getAnn (LiteralInt ann _) = ann
 getAnn (LiteralString ann _) = ann
 getAnn (SExpression ann _) = ann
@@ -73,6 +75,7 @@ instance (Data ann) => ZipperRecursive (Expression ann) where
         let recurse =
               case hole z of
                 LiteralChar _ _ -> pure
+                LiteralFloat _ _ -> pure
                 LiteralInt _ _ -> pure
                 LiteralString _ _ -> pure
                 SExpression _ [] -> pure
@@ -96,6 +99,7 @@ instance (Data ann) => ZipperRecursive (Expression ann) where
         let recurse =
               case x of
                 LiteralChar _ _ -> pure
+                LiteralFloat _ _ -> pure
                 LiteralInt _ _ -> pure
                 LiteralString _ _ -> pure
                 SExpression _ [] -> pure
@@ -116,6 +120,7 @@ bottomUpFmapSplicing f =
 
 toAxel :: Expression ann -> Text
 toAxel (LiteralChar _ x) = "#\\" <> T.singleton x
+toAxel (LiteralFloat _ x) = showText x
 toAxel (LiteralInt _ x) = showText x
 toAxel (LiteralString _ xs) = "\"" <> handleCharEscapes (T.pack xs) <> "\""
 toAxel (SExpression _ (Symbol _ "applyInfix":xs)) =
@@ -140,6 +145,10 @@ quoteExpression quoteAnn (LiteralChar ann x) =
   SExpression
     ann
     [Symbol ann "AST.LiteralChar", quoteAnn ann, LiteralChar ann x]
+quoteExpression quoteAnn (LiteralFloat ann x) =
+  SExpression
+    ann
+    [Symbol ann "AST.LiteralFloat", quoteAnn ann, LiteralFloat ann x]
 quoteExpression quoteAnn (LiteralInt ann x) =
   SExpression ann [Symbol ann "AST.LiteralInt", quoteAnn ann, LiteralInt ann x]
 quoteExpression quoteAnn (LiteralString ann x) =

src/Axel/Pretty.hs

@@ -74,6 +74,7 @@ privilegedFormToAxelPretty xs = sexp $ map toAxelPretty xs
 
 toAxelPretty :: Expression ann -> P.Doc a
 toAxelPretty (LiteralChar _ x) = "#\\" <> P.pretty x
+toAxelPretty (LiteralFloat _ x) = P.pretty x
 toAxelPretty (LiteralInt _ x) = P.pretty x
 toAxelPretty (LiteralString _ x) =
   P.dquotes $ P.pretty (under unpacked handleCharEscapes x)

test/Axel/Test/ASTGen.hs

@@ -22,6 +22,7 @@ genLiteral :: (MonadGen m) => m (AST.Literal (Maybe SM.Expression))
 genLiteral =
   Gen.choice
     [ AST.LChar Nothing <$> Gen.unicode
+    , AST.LFloat Nothing <$> Gen.float (Range.exponentialFloat (-10000) 10000)
     , AST.LInt Nothing <$> Gen.int Range.constantBounded
     , AST.LString Nothing <$> Gen.text (Range.linear 0 5) Gen.unicode
     ]