Add integer literals with bases (#2746)

- Closes #2735 

Allow integer literals to be expressed in different bases:
1. binary, with prefix `0b`.
2. octal, with prefix `0o`.
3. decimal, with no prefix.
4. hexadecimal, with prefix `0x`. Both capital and lower case letters
are parsed. They are always printed as lower case letters.

This applies to all languages that use integer literals, but only in the
concrete language the base will be preserved when pretty printing.

src/Juvix/Compiler/Asm/Translation/FromSource.hs

@@ -172,12 +172,12 @@ instrAllocClosure ::
   ParsecS r InstrAllocClosure
 instrAllocClosure = do
   sym <- funSymbol @Code @(Maybe FunctionInfoExtra) @DirectRef
-  (argsNum, _) <- integer
+  argsNum <- (^. withLocParam) <$> integer
   return $ InstrAllocClosure sym (fromInteger argsNum)
 
 instrExtendClosure :: ParsecS r InstrExtendClosure
 instrExtendClosure = do
-  (argsNum, _) <- integer
+  argsNum <- (^. withLocParam) <$> integer
   return $ InstrExtendClosure (fromInteger argsNum)
 
 instrCall ::
@@ -190,7 +190,7 @@ instrCall = do
       fi <- lift $ getFunctionInfo sym
       return (fi ^. functionArgsNum)
     CallClosure -> do
-      (n, _) <- integer
+      n <- (^. withLocParam) <$> integer
       return (fromInteger n)
   return (InstrCall ct argsNum)
 
@@ -201,7 +201,7 @@ parseCallType = (kw kwDollar $> CallClosure) <|> (CallFun <$> funSymbol @Code @(
 
 instrCallClosures :: ParsecS r InstrCallClosures
 instrCallClosures = do
-  (argsNum, _) <- integer
+  argsNum <- (^. withLocParam) <$> integer
   return (InstrCallClosures (fromInteger argsNum))
 
 branchCode ::

src/Juvix/Compiler/Backend/Cairo/Extra/Deserialization.hs

@@ -3,7 +3,6 @@ module Juvix.Compiler.Backend.Cairo.Extra.Deserialization where
 import Data.Bits
 import Juvix.Compiler.Backend.Cairo.Data.Result
 import Juvix.Compiler.Backend.Cairo.Language
-import Numeric
 
 deserialize :: Result -> [Element]
 deserialize Result {..} = go [] (map (fromHexText . unpack) _resultData)

src/Juvix/Compiler/Backend/Cairo/Extra/Serialization.hs

@@ -3,7 +3,6 @@ module Juvix.Compiler.Backend.Cairo.Extra.Serialization where
 import Data.Bits
 import Juvix.Compiler.Backend.Cairo.Data.Result
 import Juvix.Compiler.Backend.Cairo.Language
-import Numeric
 
 serialize :: [Text] -> [Element] -> Result
 serialize builtins elems =

src/Juvix/Compiler/Backend/Geb/Translation/FromSource/Lexer.hs

@@ -30,13 +30,10 @@ symbol = void . L.symbol space
 kw :: Keyword -> ParsecS r ()
 kw = void . lexeme . kw'
 
-decimal :: (Num n) => ParsecS r (n, Interval)
-decimal = lexemeInterval L.decimal
+integer :: ParsecS r (WithLoc Integer)
+integer = lexeme integer'
 
-integer :: ParsecS r (Integer, Interval)
-integer = integer' decimal
-
-number :: Int -> Int -> ParsecS r (Int, Interval)
+number :: Int -> Int -> ParsecS r (WithLoc Int)
 number = number' integer
 
 string :: ParsecS r (Text, Interval)

src/Juvix/Compiler/Casm/Translation/FromSource.hs

@@ -93,7 +93,7 @@ parseHintInput = do
 parseHintAlloc :: ParsecS r Hint
 parseHintAlloc = do
   symbol "Alloc"
-  (size, _) <- parens integer
+  size <- (^. withLocParam) <$> parens integer
   return $ HintAlloc (fromInteger size)
 
 parseHintRandomEcPoint :: ParsecS r Hint
@@ -169,7 +169,7 @@ parseValue :: (Member LabelInfoBuilder r) => ParsecS r Value
 parseValue = (Imm <$> parseImm) <|> (Ref <$> parseMemRef) <|> (Lab <$> parseLabel)
 
 parseImm :: ParsecS r Immediate
-parseImm = fst <$> integer
+parseImm = (^. withLocParam) <$> integer
 
 parseOffset :: ParsecS r Offset
 parseOffset =

src/Juvix/Compiler/Casm/Translation/FromSource/Lexer.hs

@@ -10,10 +10,10 @@ import Juvix.Compiler.Tree.Translation.FromSource.Lexer.Base
 import Juvix.Prelude
 
 offset :: ParsecS r Int16
-offset = fromIntegral . fst <$> number (-(2 ^ (15 :: Int16))) (2 ^ (15 :: Int16))
+offset = fromIntegral . (^. withLocParam) <$> number (-(2 ^ (15 :: Int16))) (2 ^ (15 :: Int16))
 
 int :: ParsecS r Int
-int = fst <$> number (-(2 ^ (31 :: Int))) (2 ^ (31 :: Int))
+int = (^. withLocParam) <$> number (-(2 ^ (31 :: Int))) (2 ^ (31 :: Int))
 
 identifier :: ParsecS r Text
 identifier = lexeme bareIdentifier

src/Juvix/Compiler/Concrete/Data/Literal.hs

@@ -2,28 +2,78 @@ module Juvix.Compiler.Concrete.Data.Literal where
 
 import Juvix.Data.Fixity
 import Juvix.Extra.Serialize
+import Juvix.Extra.Strings qualified as Str
 import Juvix.Prelude
 import Prettyprinter
 
-type LiteralLoc = WithLoc Literal
+data IntegerWithBase = IntegerWithBase
+  { _integerWithBaseBase :: IntegerBase,
+    _integerWithBaseValue :: Integer
+  }
+  deriving stock (Show, Eq, Ord, Generic, Data)
+
+data IntegerBase
+  = IntegerBaseBinary
+  | IntegerBaseOctal
+  | IntegerBaseDecimal
+  | IntegerBaseHexadecimal
+  deriving stock (Bounded, Enum, Show, Eq, Ord, Generic, Data)
+
+makeLenses ''IntegerWithBase
 
 data Literal
   = LitString Text
-  | LitInteger Integer
+  | LitIntegerWithBase IntegerWithBase
   deriving stock (Show, Eq, Ord, Generic, Data)
 
+type LiteralLoc = WithLoc Literal
+
+instance Hashable IntegerBase
+
+instance Serialize IntegerBase
+
+instance Hashable IntegerWithBase
+
+instance Serialize IntegerWithBase
+
 instance Hashable Literal
 
 instance Serialize Literal
 
+instance HasAtomicity IntegerWithBase where
+  atomicity = const Atom
+
 instance HasAtomicity Literal where
   atomicity = \case
-    LitInteger {} -> Atom
     LitString {} -> Atom
+    LitIntegerWithBase h -> atomicity h
+
+integerBasePrefix :: IntegerBase -> Text
+integerBasePrefix = \case
+  IntegerBaseBinary -> Str.binaryPrefix
+  IntegerBaseOctal -> Str.octalPrefix
+  IntegerBaseDecimal -> ""
+  IntegerBaseHexadecimal -> Str.hexadecimalPrefix
+
+instance Pretty IntegerWithBase where
+  pretty IntegerWithBase {..} =
+    let sign
+          | _integerWithBaseValue < 0 = "-"
+          | otherwise = ""
+     in sign
+          <> pretty (integerBasePrefix _integerWithBaseBase)
+          <> pretty (showNum (fromIntegral (abs _integerWithBaseValue)))
+    where
+      showNum :: Natural -> String
+      showNum n = case _integerWithBaseBase of
+        IntegerBaseBinary -> showBin n ""
+        IntegerBaseOctal -> showOct n ""
+        IntegerBaseDecimal -> showInt n ""
+        IntegerBaseHexadecimal -> showHex n ""
 
 instance Pretty Literal where
   pretty = \case
-    LitInteger n -> pretty n
+    LitIntegerWithBase n -> pretty n
     LitString s -> ppStringLit s
       where
         ppStringLit :: Text -> Doc a

src/Juvix/Compiler/Concrete/Gen.hs

@@ -93,7 +93,7 @@ namedApplication n as =
 literalInteger :: (Member (Reader Interval) r, Integral a) => a -> Sem r (ExpressionAtom 'Parsed)
 literalInteger a = do
   l <- ask
-  return (AtomLiteral (WithLoc l (LitInteger (toInteger a))))
+  return (AtomLiteral (WithLoc l (LitIntegerWithBase (IntegerWithBase IntegerBaseDecimal (toInteger a)))))
 
 mkList :: (Member (Reader Interval) r) => [NonEmpty (ExpressionAtom 'Parsed)] -> Sem r (ExpressionAtom 'Parsed)
 mkList as = do

src/Juvix/Compiler/Concrete/Print/Base.hs

@@ -483,7 +483,7 @@ instance PrettyPrint Literal where
 
 ppLiteral :: Literal -> Doc Ann
 ppLiteral = \case
-  LitInteger n -> annotate AnnLiteralInteger (pretty n)
+  LitIntegerWithBase n -> annotate AnnLiteralInteger (pretty n)
   LitString s -> ppStringLit s
 
 instance (SingI s) => PrettyPrint (LambdaClause s) where

src/Juvix/Compiler/Concrete/Translation/FromSource.hs

@@ -1115,7 +1115,7 @@ parseList = do
 --------------------------------------------------------------------------------
 
 literalInteger :: (Members '[ParserResultBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r LiteralLoc
-literalInteger = fmap LitInteger <$> integer
+literalInteger = fmap LitIntegerWithBase <$> integerWithBase
 
 literalString :: (Members '[ParserResultBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r LiteralLoc
 literalString = do

src/Juvix/Compiler/Concrete/Translation/FromSource/Lexer.hs

@@ -8,6 +8,7 @@ where
 
 import Data.Text qualified as Text
 import GHC.Unicode
+import Juvix.Compiler.Concrete.Data.Literal
 import Juvix.Compiler.Concrete.Extra hiding (Pos, hspace, space, string')
 import Juvix.Compiler.Concrete.Extra qualified as P
 import Juvix.Compiler.Concrete.Keywords
@@ -49,10 +50,11 @@ identifier = fmap fst identifierL
 identifierL :: (Members '[ParserResultBuilder] r) => ParsecS r (Text, Interval)
 identifierL = lexeme bareIdentifier
 
+integerWithBase :: (Members '[ParserResultBuilder] r) => ParsecS r (WithLoc IntegerWithBase)
+integerWithBase = lexeme integerWithBase'
+
 integer :: (Members '[ParserResultBuilder] r) => ParsecS r (WithLoc Integer)
-integer = do
-  (num, i) <- integer' decimal
-  return (WithLoc i num)
+integer = lexeme integer'
 
 bracedString :: forall e m. (MonadParsec e Text m) => m Text
 bracedString =

src/Juvix/Compiler/Concrete/Translation/FromSource/ParserResultBuilder.hs

@@ -62,7 +62,7 @@ registerLiteral l =
   where
     tag = case l ^. withLocParam of
       LitString {} -> ParsedTagLiteralString
-      LitInteger {} -> ParsedTagLiteralInt
+      LitIntegerWithBase {} -> ParsedTagLiteralInt
     loc = getLoc l
 
 registerItem' :: (Member (State ParserState) r) => ParsedItem -> Sem r ()

src/Juvix/Compiler/Core/Translation/FromSource.hs

@@ -610,7 +610,7 @@ atom varsNum vars =
 
 exprConstInt :: ParsecS r Node
 exprConstInt = P.try $ do
-  (n, i) <- integer
+  WithLoc i n <- integer
   return $ mkConstant (Info.singleton (LocationInfo i)) (ConstInteger n)
 
 exprConstString :: ParsecS r Node
@@ -627,7 +627,7 @@ exprUniverse :: ParsecS r Type
 exprUniverse = do
   kw kwType
   level <- optional (number 0 128) -- TODO: global Limits.hs file
-  return $ mkUniv' (maybe 0 fst level)
+  return $ mkUniv' (maybe 0 (^. withLocParam) level)
 
 exprDynamic :: ParsecS r Type
 exprDynamic = kw kwAny $> mkDynamic'

src/Juvix/Compiler/Core/Translation/FromSource/Lexer.hs

@@ -27,16 +27,13 @@ symbol = void . L.symbol space
 kw :: Keyword -> ParsecS r ()
 kw = void . lexeme . kw'
 
-decimal :: (Num n) => ParsecS r (n, Interval)
-decimal = lexemeInterval L.decimal
-
 field :: ParsecS r (Integer, Interval)
 field = lexemeInterval field'
 
-integer :: ParsecS r (Integer, Interval)
-integer = integer' decimal
+integer :: ParsecS r (WithLoc Integer)
+integer = lexeme integer'
 
-number :: Int -> Int -> ParsecS r (Int, Interval)
+number :: Int -> Int -> ParsecS r (WithLoc Int)
 number = number' integer
 
 string :: ParsecS r (Text, Interval)

src/Juvix/Compiler/Internal/Translation/FromConcrete.hs

@@ -674,7 +674,7 @@ goLiteral = fmap go
     go :: Literal -> Internal.Literal
     go = \case
       LitString s -> Internal.LitString s
-      LitInteger i -> Internal.LitNumeric i
+      LitIntegerWithBase i -> Internal.LitNumeric (i ^. integerWithBaseValue)
 
 goListPattern :: (Members '[Builtins, Error ScoperError, NameIdGen, Reader S.InfoTable] r) => Concrete.ListPattern 'Scoped -> Sem r Internal.Pattern
 goListPattern l = do

src/Juvix/Compiler/Reg/Translation/FromSource/Lexer.hs

@@ -10,10 +10,10 @@ import Juvix.Compiler.Tree.Translation.FromSource.Lexer.Base
 import Juvix.Prelude
 
 int :: ParsecS r Int
-int = fst <$> number (-(2 ^ (31 :: Int))) (2 ^ (31 :: Int))
+int = (^. withLocParam) <$> number (-(2 ^ (31 :: Int))) (2 ^ (31 :: Int))
 
 smallnat :: ParsecS r Int
-smallnat = fst <$> number 0 256
+smallnat = (^. withLocParam) <$> number 0 256
 
 identifier :: ParsecS r Text
 identifier = lexeme bareIdentifier

src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs

@@ -325,7 +325,7 @@ fieldValue = P.try $ do
 
 integerValue :: ParsecS r Constant
 integerValue = do
-  (i, _) <- integer
+  i <- (^. withLocParam) <$> integer
   return $ ConstInt i
 
 boolValue :: ParsecS r Constant
@@ -376,13 +376,13 @@ directRef = argRef <|> tempRef <|> namedRef @t @e
 argRef :: ParsecS r DirectRef
 argRef = do
   kw kwArg
-  (off, _) <- brackets integer
+  off <- (^. withLocParam) <$> brackets integer
   return $ ArgRef (OffsetRef (fromInteger off) Nothing)
 
 tempRef :: ParsecS r DirectRef
 tempRef = do
   kw kwTmp
-  (off, _) <- brackets integer
+  off <- (^. withLocParam) <$> brackets integer
   return $ mkTempRef (OffsetRef (fromInteger off) Nothing)
 
 namedRef' :: forall t e d r. (Members '[Reader (ParserSig t e d), State (LocalParams' d)] r) => (Int -> Text -> ParsecS r d) -> ParsecS r d
@@ -405,7 +405,7 @@ parseField ::
 parseField dref = do
   dot
   tag <- constrTag @t @e @d
-  (off, _) <- brackets integer
+  off <- (^. withLocParam) <$> brackets integer
   return $ ConstrRef (Field Nothing tag dref (fromInteger off))
 
 constrTag ::

src/Juvix/Compiler/Tree/Translation/FromSource/Lexer/Base.hs

@@ -22,13 +22,10 @@ lexemeInterval = lexeme . interval
 symbol :: Text -> ParsecS r ()
 symbol = void . L.symbol space
 
-decimal :: (Num n) => ParsecS r (n, Interval)
-decimal = lexemeInterval L.decimal
+integer :: ParsecS r (WithLoc Integer)
+integer = lexeme integer'
 
-integer :: ParsecS r (Integer, Interval)
-integer = integer' decimal
-
-number :: Int -> Int -> ParsecS r (Int, Interval)
+number :: Int -> Int -> ParsecS r (WithLoc Int)
 number = number' integer
 
 field :: ParsecS r (Integer, Interval)

src/Juvix/Extra/Strings.hs

@@ -2,6 +2,15 @@ module Juvix.Extra.Strings where
 
 import Juvix.Prelude.Base
 
+binaryPrefix :: (IsString s) => s
+binaryPrefix = "0b"
+
+hexadecimalPrefix :: (IsString s) => s
+hexadecimalPrefix = "0x"
+
+octalPrefix :: (IsString s) => s
+octalPrefix = "0o"
+
 module_ :: (IsString s) => s
 module_ = "module"