{-# LANGUAGE LambdaCase #-}
module Language.Fortran.Parser.Utils
( readReal
, readInteger
, parseRealLiteral
, RealLit(..)
, Exponent(..)
, NumSign(..)
, ExponentLetter(..)
) where
import Language.Fortran.AST (Kind)
import Data.Char
import Numeric
import Text.Read (readMaybe)
breakAtDot :: String -> (String, String)
replaceDwithE :: Char -> Char
readsToMaybe :: [(a, b)] -> Maybe a
fixAtDot :: (String, String) -> (String, String)
fixAtDot' :: (String, String) -> (String, String)
combineAtDot :: (String, String) -> String
readReal :: String -> Maybe Double
readReal :: String -> Maybe Double
readReal = [(Double, String)] -> Maybe Double
forall a b. [(a, b)] -> Maybe a
readsToMaybe ([(Double, String)] -> Maybe Double)
-> (String -> [(Double, String)]) -> String -> Maybe Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(Double, String)]
forall a. Read a => ReadS a
reads (String -> [(Double, String)])
-> (String -> String) -> String -> [(Double, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'+') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
combineAtDot ((String, String) -> String)
-> (String -> (String, String)) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> (String, String)
fixAtDot ((String, String) -> (String, String))
-> (String -> (String, String)) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, String)
breakAtDot (String -> (String, String))
-> (String -> String) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replaceDwithE (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_')
readInteger :: String -> Maybe Integer
readInteger :: String -> Maybe Integer
readInteger String
s = [(Integer, String)] -> Maybe Integer
forall a b. [(a, b)] -> Maybe a
readsToMaybe ([(Integer, String)] -> Maybe Integer)
-> [(Integer, String)] -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ case String
s' of
Char
'b':String
_ -> Integer -> (Char -> Bool) -> (Char -> Int) -> ReadS Integer
forall a. Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt Integer
2 (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"01") Char -> Int
digitToInt (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 String
s')
Char
'o':String
_ -> Integer -> (Char -> Bool) -> (Char -> Int) -> ReadS Integer
forall a. Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt Integer
8 (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'0'..Char
'7']) Char -> Int
digitToInt (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 String
s')
Char
'z':String
_ -> Integer -> (Char -> Bool) -> (Char -> Int) -> ReadS Integer
forall a. Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt Integer
16 (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char
'0'..Char
'9'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'F'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'f'])) Char -> Int
digitToInt (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 String
s')
String
_ -> ReadS Integer -> ReadS Integer
forall a. Real a => ReadS a -> ReadS a
readSigned ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readDec String
s'
where
s' :: String
s' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'+') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
s
fixAtDot' :: (String, String) -> (String, String)
fixAtDot' (String
"", String
r) = (String
"0", String
r)
fixAtDot' (String
"-", String
r) = (String
"-0", String
r)
fixAtDot' (String
l, String
"") = (String
l, String
"0")
fixAtDot' (String
l, Char
r0:String
r) | Bool -> Bool
not (Char -> Bool
isDigit Char
r0) = (String
l, Char
'0'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
r0Char -> String -> String
forall a. a -> [a] -> [a]
:String
r)
fixAtDot' (String, String)
x = (String, String)
x
combineAtDot :: (String, String) -> String
combineAtDot (String
a, String
b) = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b
fixAtDot :: (String, String) -> (String, String)
fixAtDot (String, String)
x
| (String, String)
x (String, String) -> (String, String) -> Bool
forall a. Eq a => a -> a -> Bool
== (String, String)
x' = (String, String)
x
| Bool
otherwise = (String, String) -> (String, String)
fixAtDot (String, String)
x' where x' :: (String, String)
x' = (String, String) -> (String, String)
fixAtDot' (String, String)
x
breakAtDot :: String -> (String, String)
breakAtDot = (String -> String) -> (String, String) -> (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1) ((String, String) -> (String, String))
-> (String -> (String, String)) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.')
replaceDwithE :: Char -> Char
replaceDwithE Char
'd' = Char
'e'
replaceDwithE Char
c = Char
c
readsToMaybe :: [(a, b)] -> Maybe a
readsToMaybe [(a, b)]
r = case [(a, b)]
r of
(a
x, b
_):[(a, b)]
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
[(a, b)]
_ -> Maybe a
forall a. Maybe a
Nothing
type KindParam = Kind
data RealLit = RealLit
{ RealLit -> String
realLitValue :: String
, RealLit -> Maybe Exponent
realLitExponent :: Maybe Exponent
, RealLit -> Maybe Int
realLitKindParam :: Maybe KindParam
} deriving (RealLit -> RealLit -> Bool
(RealLit -> RealLit -> Bool)
-> (RealLit -> RealLit -> Bool) -> Eq RealLit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RealLit -> RealLit -> Bool
$c/= :: RealLit -> RealLit -> Bool
== :: RealLit -> RealLit -> Bool
$c== :: RealLit -> RealLit -> Bool
Eq, Eq RealLit
Eq RealLit
-> (RealLit -> RealLit -> Ordering)
-> (RealLit -> RealLit -> Bool)
-> (RealLit -> RealLit -> Bool)
-> (RealLit -> RealLit -> Bool)
-> (RealLit -> RealLit -> Bool)
-> (RealLit -> RealLit -> RealLit)
-> (RealLit -> RealLit -> RealLit)
-> Ord RealLit
RealLit -> RealLit -> Bool
RealLit -> RealLit -> Ordering
RealLit -> RealLit -> RealLit
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RealLit -> RealLit -> RealLit
$cmin :: RealLit -> RealLit -> RealLit
max :: RealLit -> RealLit -> RealLit
$cmax :: RealLit -> RealLit -> RealLit
>= :: RealLit -> RealLit -> Bool
$c>= :: RealLit -> RealLit -> Bool
> :: RealLit -> RealLit -> Bool
$c> :: RealLit -> RealLit -> Bool
<= :: RealLit -> RealLit -> Bool
$c<= :: RealLit -> RealLit -> Bool
< :: RealLit -> RealLit -> Bool
$c< :: RealLit -> RealLit -> Bool
compare :: RealLit -> RealLit -> Ordering
$ccompare :: RealLit -> RealLit -> Ordering
$cp1Ord :: Eq RealLit
Ord, Int -> RealLit -> String -> String
[RealLit] -> String -> String
RealLit -> String
(Int -> RealLit -> String -> String)
-> (RealLit -> String)
-> ([RealLit] -> String -> String)
-> Show RealLit
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [RealLit] -> String -> String
$cshowList :: [RealLit] -> String -> String
show :: RealLit -> String
$cshow :: RealLit -> String
showsPrec :: Int -> RealLit -> String -> String
$cshowsPrec :: Int -> RealLit -> String -> String
Show)
data Exponent = Exponent
{ Exponent -> ExponentLetter
expLetter :: ExponentLetter
, Exponent -> Maybe NumSign
expSign :: Maybe NumSign
, Exponent -> Int
expNum :: Int
} deriving (Exponent -> Exponent -> Bool
(Exponent -> Exponent -> Bool)
-> (Exponent -> Exponent -> Bool) -> Eq Exponent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exponent -> Exponent -> Bool
$c/= :: Exponent -> Exponent -> Bool
== :: Exponent -> Exponent -> Bool
$c== :: Exponent -> Exponent -> Bool
Eq, Eq Exponent
Eq Exponent
-> (Exponent -> Exponent -> Ordering)
-> (Exponent -> Exponent -> Bool)
-> (Exponent -> Exponent -> Bool)
-> (Exponent -> Exponent -> Bool)
-> (Exponent -> Exponent -> Bool)
-> (Exponent -> Exponent -> Exponent)
-> (Exponent -> Exponent -> Exponent)
-> Ord Exponent
Exponent -> Exponent -> Bool
Exponent -> Exponent -> Ordering
Exponent -> Exponent -> Exponent
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Exponent -> Exponent -> Exponent
$cmin :: Exponent -> Exponent -> Exponent
max :: Exponent -> Exponent -> Exponent
$cmax :: Exponent -> Exponent -> Exponent
>= :: Exponent -> Exponent -> Bool
$c>= :: Exponent -> Exponent -> Bool
> :: Exponent -> Exponent -> Bool
$c> :: Exponent -> Exponent -> Bool
<= :: Exponent -> Exponent -> Bool
$c<= :: Exponent -> Exponent -> Bool
< :: Exponent -> Exponent -> Bool
$c< :: Exponent -> Exponent -> Bool
compare :: Exponent -> Exponent -> Ordering
$ccompare :: Exponent -> Exponent -> Ordering
$cp1Ord :: Eq Exponent
Ord, Int -> Exponent -> String -> String
[Exponent] -> String -> String
Exponent -> String
(Int -> Exponent -> String -> String)
-> (Exponent -> String)
-> ([Exponent] -> String -> String)
-> Show Exponent
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Exponent] -> String -> String
$cshowList :: [Exponent] -> String -> String
show :: Exponent -> String
$cshow :: Exponent -> String
showsPrec :: Int -> Exponent -> String -> String
$cshowsPrec :: Int -> Exponent -> String -> String
Show)
data ExponentLetter
= ExpLetterD
| ExpLetterE
deriving (ExponentLetter -> ExponentLetter -> Bool
(ExponentLetter -> ExponentLetter -> Bool)
-> (ExponentLetter -> ExponentLetter -> Bool) -> Eq ExponentLetter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExponentLetter -> ExponentLetter -> Bool
$c/= :: ExponentLetter -> ExponentLetter -> Bool
== :: ExponentLetter -> ExponentLetter -> Bool
$c== :: ExponentLetter -> ExponentLetter -> Bool
Eq, Eq ExponentLetter
Eq ExponentLetter
-> (ExponentLetter -> ExponentLetter -> Ordering)
-> (ExponentLetter -> ExponentLetter -> Bool)
-> (ExponentLetter -> ExponentLetter -> Bool)
-> (ExponentLetter -> ExponentLetter -> Bool)
-> (ExponentLetter -> ExponentLetter -> Bool)
-> (ExponentLetter -> ExponentLetter -> ExponentLetter)
-> (ExponentLetter -> ExponentLetter -> ExponentLetter)
-> Ord ExponentLetter
ExponentLetter -> ExponentLetter -> Bool
ExponentLetter -> ExponentLetter -> Ordering
ExponentLetter -> ExponentLetter -> ExponentLetter
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ExponentLetter -> ExponentLetter -> ExponentLetter
$cmin :: ExponentLetter -> ExponentLetter -> ExponentLetter
max :: ExponentLetter -> ExponentLetter -> ExponentLetter
$cmax :: ExponentLetter -> ExponentLetter -> ExponentLetter
>= :: ExponentLetter -> ExponentLetter -> Bool
$c>= :: ExponentLetter -> ExponentLetter -> Bool
> :: ExponentLetter -> ExponentLetter -> Bool
$c> :: ExponentLetter -> ExponentLetter -> Bool
<= :: ExponentLetter -> ExponentLetter -> Bool
$c<= :: ExponentLetter -> ExponentLetter -> Bool
< :: ExponentLetter -> ExponentLetter -> Bool
$c< :: ExponentLetter -> ExponentLetter -> Bool
compare :: ExponentLetter -> ExponentLetter -> Ordering
$ccompare :: ExponentLetter -> ExponentLetter -> Ordering
$cp1Ord :: Eq ExponentLetter
Ord, Int -> ExponentLetter -> String -> String
[ExponentLetter] -> String -> String
ExponentLetter -> String
(Int -> ExponentLetter -> String -> String)
-> (ExponentLetter -> String)
-> ([ExponentLetter] -> String -> String)
-> Show ExponentLetter
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ExponentLetter] -> String -> String
$cshowList :: [ExponentLetter] -> String -> String
show :: ExponentLetter -> String
$cshow :: ExponentLetter -> String
showsPrec :: Int -> ExponentLetter -> String -> String
$cshowsPrec :: Int -> ExponentLetter -> String -> String
Show)
data NumSign
= SignPos
| SignNeg
deriving (NumSign -> NumSign -> Bool
(NumSign -> NumSign -> Bool)
-> (NumSign -> NumSign -> Bool) -> Eq NumSign
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NumSign -> NumSign -> Bool
$c/= :: NumSign -> NumSign -> Bool
== :: NumSign -> NumSign -> Bool
$c== :: NumSign -> NumSign -> Bool
Eq, Eq NumSign
Eq NumSign
-> (NumSign -> NumSign -> Ordering)
-> (NumSign -> NumSign -> Bool)
-> (NumSign -> NumSign -> Bool)
-> (NumSign -> NumSign -> Bool)
-> (NumSign -> NumSign -> Bool)
-> (NumSign -> NumSign -> NumSign)
-> (NumSign -> NumSign -> NumSign)
-> Ord NumSign
NumSign -> NumSign -> Bool
NumSign -> NumSign -> Ordering
NumSign -> NumSign -> NumSign
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NumSign -> NumSign -> NumSign
$cmin :: NumSign -> NumSign -> NumSign
max :: NumSign -> NumSign -> NumSign
$cmax :: NumSign -> NumSign -> NumSign
>= :: NumSign -> NumSign -> Bool
$c>= :: NumSign -> NumSign -> Bool
> :: NumSign -> NumSign -> Bool
$c> :: NumSign -> NumSign -> Bool
<= :: NumSign -> NumSign -> Bool
$c<= :: NumSign -> NumSign -> Bool
< :: NumSign -> NumSign -> Bool
$c< :: NumSign -> NumSign -> Bool
compare :: NumSign -> NumSign -> Ordering
$ccompare :: NumSign -> NumSign -> Ordering
$cp1Ord :: Eq NumSign
Ord, Int -> NumSign -> String -> String
[NumSign] -> String -> String
NumSign -> String
(Int -> NumSign -> String -> String)
-> (NumSign -> String)
-> ([NumSign] -> String -> String)
-> Show NumSign
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [NumSign] -> String -> String
$cshowList :: [NumSign] -> String -> String
show :: NumSign -> String
$cshow :: NumSign -> String
showsPrec :: Int -> NumSign -> String -> String
$cshowsPrec :: Int -> NumSign -> String -> String
Show)
parseRealLiteral :: String -> RealLit
parseRealLiteral :: String -> RealLit
parseRealLiteral String
r =
RealLit :: String -> Maybe Exponent -> Maybe Int -> RealLit
RealLit { realLitValue :: String
realLitValue = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isValuePart String
r
, realLitExponent :: Maybe Exponent
realLitExponent = String -> Maybe Exponent
parseRealLitExponent ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isValuePart String
r)
, realLitKindParam :: Maybe Int
realLitKindParam = String -> Maybe Int
parseRealLitKindInt ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') String
r)
}
where
isValuePart :: Char -> Bool
isValuePart :: Char -> Bool
isValuePart Char
ch
| Char -> Bool
isDigit Char
ch = Bool
True
| Char
ch Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'.', Char
'-', Char
'+'] = Bool
True
| Bool
otherwise = Bool
False
parseRealLitKindInt :: String -> Maybe Kind
parseRealLitKindInt :: String -> Maybe Int
parseRealLitKindInt = \case
Char
'_':String
chs -> String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
chs
String
_ -> Maybe Int
forall a. Maybe a
Nothing
parseRealLitExponent :: String -> Maybe Exponent
parseRealLitExponent :: String -> Maybe Exponent
parseRealLitExponent String
"" = Maybe Exponent
forall a. Maybe a
Nothing
parseRealLitExponent (Char
c:String
cs) = do
ExponentLetter
letter <-
case Char -> Char
toLower Char
c of
Char
'e' -> ExponentLetter -> Maybe ExponentLetter
forall a. a -> Maybe a
Just ExponentLetter
ExpLetterE
Char
'd' -> ExponentLetter -> Maybe ExponentLetter
forall a. a -> Maybe a
Just ExponentLetter
ExpLetterD
Char
_ -> Maybe ExponentLetter
forall a. Maybe a
Nothing
let (Maybe NumSign
sign, String
cs'') =
case String
cs of
String
"" -> (Maybe NumSign
forall a. Maybe a
Nothing, String
cs)
Char
c':String
cs' ->
case Char
c' of
Char
'-' -> (NumSign -> Maybe NumSign
forall a. a -> Maybe a
Just NumSign
SignNeg, String
cs')
Char
'+' -> (NumSign -> Maybe NumSign
forall a. a -> Maybe a
Just NumSign
SignPos, String
cs')
Char
_ -> (Maybe NumSign
forall a. Maybe a
Nothing , String
cs)
digitStr :: Int
digitStr = String -> Int
forall a. Read a => String -> a
read ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDigit String
cs'')
Exponent -> Maybe Exponent
forall (m :: * -> *) a. Monad m => a -> m a
return (Exponent -> Maybe Exponent) -> Exponent -> Maybe Exponent
forall a b. (a -> b) -> a -> b
$ ExponentLetter -> Maybe NumSign -> Int -> Exponent
Exponent ExponentLetter
letter Maybe NumSign
sign Int
digitStr