{- © 2022 Serokell <hi@serokell.io>
 - © 2022 Lars Jellema <lars.jellema@gmail.com>
 -
 - SPDX-License-Identifier: MPL-2.0
 -}

{-# LANGUAGE TypeFamilies, TypeApplications, ScopedTypeVariables, TypeOperators #-}

module Nixfmt.Parser.Float (floatParse) where

import "base" Data.Foldable (foldl')
import "base" Data.Proxy (Proxy (..))
import qualified "base" Data.Char as Char

import "base" Control.Monad (void)
import "megaparsec" Text.Megaparsec (
    option, chunkToTokens, takeWhile1P, try, notFollowedBy,
    (<|>), (<?>), MonadParsec, Token,
  )
import "megaparsec" Text.Megaparsec.Char.Lexer (decimal, signed)
import "megaparsec" Text.Megaparsec.Char (char, char', digitChar)

import "scientific" Data.Scientific (toRealFloat, scientific)

-- copied (and modified) from Text.Megaparsec.Char.Lexer
data SP = SP !Integer {-# UNPACK #-} !Int
floatParse :: (MonadParsec e s m, Token s ~ Char, RealFloat a) => m a
floatParse :: forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, RealFloat a) =>
m a
floatParse = do
  m Char -> m ()
forall a. m a -> m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (m Char -> m ()) -> m Char -> m ()
forall a b. (a -> b) -> a -> b
$ (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'0') m Char -> m Char -> m Char
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m Char
m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
  m Char -> m ()
forall a. m a -> m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (m Char -> m ()) -> m Char -> m ()
forall a b. (a -> b) -> a -> b
$ (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char' Char
Token s
'e')
  Integer
c' <- (m Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal m Integer -> String -> m Integer
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"decimal") m Integer -> m Integer -> m Integer
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> m Integer
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
  Scientific -> a
forall a. RealFloat a => Scientific -> a
toRealFloat
    (Scientific -> a) -> m Scientific -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (( do
              SP Integer
c Int
e' <- Integer -> m SP
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Integer -> m SP
dotDecimal_ Integer
c'
              Int
e <- Int -> m Int -> m Int
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Int
e' (m Int -> m Int
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (m Int -> m Int) -> m Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int -> m Int
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Int -> m Int
exponent_ Int
e')
              Scientific -> m Scientific
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int -> Scientific
scientific Integer
c Int
e)
         )
            m Scientific -> m Scientific -> m Scientific
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Integer -> Int -> Scientific
scientific Integer
c' (Int -> Scientific) -> m Int -> m Scientific
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m Int
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Int -> m Int
exponent_ Int
0)
        )
{-# INLINE floatParse #-}

-- copied from Text.Megaparsec.Char.Lexer
dotDecimal_ :: forall e s m.
  (MonadParsec e s m, Token s ~ Char) => Integer -> m SP
dotDecimal_ :: forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Integer -> m SP
dotDecimal_ Integer
c' = do
  m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'.')
  let mkNum :: Tokens s -> SP
mkNum = (SP -> Char -> SP) -> SP -> String -> SP
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SP -> Char -> SP
step (Integer -> Int -> SP
SP Integer
c' Int
0) (String -> SP) -> (Tokens s -> String) -> Tokens s -> SP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Stream s => Proxy s -> Tokens s -> [Token s]
chunkToTokens @s Proxy s
forall {k} (t :: k). Proxy t
Proxy
      step :: SP -> Char -> SP
step (SP Integer
a Int
e') Char
c =
        Integer -> Int -> SP
SP
          (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
Char.digitToInt Char
c))
          (Int
e' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  Tokens s -> SP
mkNum (Tokens s -> SP) -> m (Tokens s) -> m SP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String -> (Token s -> Bool) -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"digit") Char -> Bool
Token s -> Bool
Char.isDigit
{-# INLINE dotDecimal_ #-}

-- copied from Text.Megaparsec.Char.Lexer
exponent_ :: (MonadParsec e s m, Token s ~ Char) => Int -> m Int
exponent_ :: forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Int -> m Int
exponent_ Int
e' = do
  m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char' Char
Token s
'e')
  (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
e') (Int -> Int) -> m Int -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m () -> m Int -> m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
signed (() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
{-# INLINE exponent_ #-}