{-# LANGUAGE LambdaCase #-}

{-| Simple module to provide functions that read Fortran literals -}
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

-- | Convert a Fortran literal Real into a Haskell Double.
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
'_')

-- | Convert a Fortran literal Integer into a Haskell Integer.
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

--------------------------------------------------------------------------------

-- TODO limitation
-- Kind params allow 'Name's as well (which are checked at compile time to be a
-- special type of constant expression). We limit ourselves to integer kind
-- params only, because currently we don't handle full kind params in the later
-- stages anyway.
type KindParam = Kind

-- | A REAL literal may have an optional exponent and kind.
--
-- The value can be retrieved as a 'Double' by using these parts.
data RealLit = RealLit
  { RealLit -> String
realLitValue     :: String -- xyz.abc, xyz, xyz., .abc
  , 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)

-- | An exponent is an exponent letter (E, D) and a value (with an optional
-- sign).
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)

-- Note: Some Fortran language references include extensions here. HP's F90
-- reference provides a Q exponent letter which sets kind to 16.
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)

-- | Parse a Fortran literal real to its constituent parts.
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
    -- slightly ugly: we add the signs in here to allow -1.0 easily
    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'  -> -- TODO: want to locally scope cs' but unsure how to??
                    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