module Language.Fortran.Vars.BozConstant
  ( resolveBozConstant
  , bozToInt
  , bozToInt2
  , bozToInt4
  , bozToInt8
  )
where

import           Data.Char                      ( digitToInt
                                                , intToDigit
                                                , toLower
                                                )
import qualified Data.Map                      as M
import           Numeric                        ( readInt
                                                , showIntAtBase
                                                )
import           Text.Read                      ( ReadS )

import           Language.Fortran.Vars.Types
                                                ( SymbolTableEntry(..)
                                                , Type(..)
                                                , SemType(..)
                                                , Kind
                                                , ExpVal(..)
                                                , SymbolTable
                                                )

-- | BozDecomposed is constructed with:
--   - String that represents the BOZ constant as it is in code, e.g. "'1111'x"
--   - String that represents digits without number system and lowercased, i.e. "ff1e" in "'Ff1E'x"
--   - Char that represents number system, i.e. 'x' in "'1111'x"
--   - Integer that represents number system, i.e. 16 in "'1111'x"
--   - String that represents binary translation of BOZ constant as it is.
--     It doesn't take into account any truncations nor overflows
data BozDecomposed = BozDecomposed String String Char Int String
  deriving Int -> BozDecomposed -> ShowS
[BozDecomposed] -> ShowS
BozDecomposed -> String
(Int -> BozDecomposed -> ShowS)
-> (BozDecomposed -> String)
-> ([BozDecomposed] -> ShowS)
-> Show BozDecomposed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BozDecomposed] -> ShowS
$cshowList :: [BozDecomposed] -> ShowS
show :: BozDecomposed -> String
$cshow :: BozDecomposed -> String
showsPrec :: Int -> BozDecomposed -> ShowS
$cshowsPrec :: Int -> BozDecomposed -> ShowS
Show

parseBozDecomposed :: ExpVal -> BozDecomposed
parseBozDecomposed :: ExpVal -> BozDecomposed
parseBozDecomposed (Boz String
bozStr) = String -> String -> Char -> Int -> String -> BozDecomposed
BozDecomposed String
bozStr
                                                String
digits
                                                Char
numsysChar
                                                Int
numsysInt
                                                String
binary
 where
  digits :: String
digits     = ShowS
getDigits String
bozStr
  numsysChar :: Char
numsysChar = if String -> Char
forall a. [a] -> a
head String
bozStr Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"boxz" then String -> Char
forall a. [a] -> a
head String
bozStr else String -> Char
forall a. [a] -> a
last String
bozStr
  numsysInt :: Int
numsysInt  = case Char
numsysChar of
    Char
'b' -> Int
2
    Char
'o' -> Int
8
    Char
'x' -> Int
16
    Char
'z' -> Int
16
    Char
_   -> String -> Int
forall a. HasCallStack => String -> a
error
      (Char
numsysChar
      Char -> ShowS
forall a. a -> [a] -> [a]
: String
" is not supported BOZ specifier.\
                                                \ Invalid fortran syntax"
      )
  binary :: String
binary = String -> Int -> String
toBinaryString String
digits Int
numsysInt
parseBozDecomposed ExpVal
_ = String -> BozDecomposed
forall a. HasCallStack => String -> a
error String
"ExpVal is not a BOZ constant"

resolveBozConstant' :: SymbolTable -> String -> BozDecomposed -> ExpVal
resolveBozConstant' :: SymbolTable -> String -> BozDecomposed -> ExpVal
resolveBozConstant' SymbolTable
symTable String
assignSymbol BozDecomposed
bozDecomposed =
  let entry :: Maybe SymbolTableEntry
entry = String -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
assignSymbol SymbolTable
symTable
  in
    case Maybe SymbolTableEntry
entry of
      Just (SVariable (TInteger Int
kind) Location
_) ->
        BozDecomposed -> Int -> ExpVal
resolveBozConstantInContext BozDecomposed
bozDecomposed Int
kind
      Just (SVariable SemType
ty Location
_) ->
        String -> ExpVal
forall a. HasCallStack => String -> a
error
          (String -> ExpVal) -> String -> ExpVal
forall a b. (a -> b) -> a -> b
$  String
assignSymbol
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is a "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SemType -> String
forall a. Show a => a -> String
show SemType
ty
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\nBOZ constants can only be resolved in an INTEGER context"
      Just SymbolTableEntry
_ -> String -> ExpVal
forall a. HasCallStack => String -> a
error
        (String
assignSymbol
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not a scalar variable. \
                                          \Invalid fortran sytax"
        )
      Maybe SymbolTableEntry
Nothing -> String -> ExpVal
forall a. HasCallStack => String -> a
error
        (String
assignSymbol
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" could not be found. \
                                          \Invalid fortran syntax"
        )

resolveBozConstantInContext :: BozDecomposed -> Kind -> ExpVal
resolveBozConstantInContext :: BozDecomposed -> Int -> ExpVal
resolveBozConstantInContext (BozDecomposed String
_ String
_ Char
_ Int
_ String
binary) Int
kind =
  let allowedBinaryLength :: Int
allowedBinaryLength = Int
kind Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
      maxBinaryValue :: Int
maxBinaryValue      = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
allowedBinaryLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      minBinaryValue :: Int
minBinaryValue      = (-Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
allowedBinaryLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      truncatedBinary :: String
truncatedBinary = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
allowedBinaryLength ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
binary
      decimal :: Int
decimal             = String -> Int -> Int
numsysStringToDecimal String
truncatedBinary Int
2
      overflow :: Int
overflow            = Int
decimal Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
maxBinaryValue
  in  if Int
overflow Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> ExpVal
Int (Int
minBinaryValue Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
overflow Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) else Int -> ExpVal
Int Int
decimal

getDigits :: String -> String
getDigits :: ShowS
getDigits String
bozStr = [ Char -> Char
toLower Char
c | Char
c <- String
digits ]
 where
  digits :: String
digits =
    (Char -> ShowS) -> String -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Char
l String
acc -> if Char
l Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"'boxz" then String
acc else Char
l Char -> ShowS
forall a. a -> [a] -> [a]
: String
acc) [] String
bozStr

toBinaryString :: String -> Int -> String
toBinaryString :: String -> Int -> String
toBinaryString String
digits Int
fromNumsys = Int -> String
decimalToBinaryString Int
decimal
  where decimal :: Int
decimal = String -> Int -> Int
numsysStringToDecimal String
digits Int
fromNumsys

numsysStringToDecimal :: String -> Int -> Int
numsysStringToDecimal :: String -> Int -> Int
numsysStringToDecimal String
digits Int
numsys = Int
decimal
 where
  numsysValidFunction :: Char -> Bool
numsysValidFunction = (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
intToDigit [Int
0 .. (Int
numsys Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)])
  numsysReader :: ReadS Int
numsysReader = Int -> (Char -> Bool) -> (Char -> Int) -> ReadS Int
forall a. Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt Int
numsys Char -> Bool
numsysValidFunction Char -> Int
digitToInt :: ReadS Int
  ((Int
decimal, String
_) : [(Int, String)]
_) = ReadS Int
numsysReader String
digits

decimalToBinaryString :: Int -> String
decimalToBinaryString :: Int -> String
decimalToBinaryString Int
decimal = Int -> (Int -> Char) -> Int -> ShowS
forall a. (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS
showIntAtBase Int
2 Int -> Char
intToDigit Int
decimal String
""

-- | Given 'SymbolTable', contextual symbol name and BOZ Constant
-- ('ExpVal' constructed with Boz String), resolve BOZ Constant considering
-- contextual symbol.
--
-- Currently, it only resolves BOZ Constants in context of INTEGER.
resolveBozConstant :: SymbolTable -> String -> ExpVal -> ExpVal
resolveBozConstant :: SymbolTable -> String -> ExpVal -> ExpVal
resolveBozConstant SymbolTable
symTable String
assignSymbol boz :: ExpVal
boz@(Boz String
_) =
  SymbolTable -> String -> BozDecomposed -> ExpVal
resolveBozConstant' SymbolTable
symTable String
assignSymbol (ExpVal -> BozDecomposed
parseBozDecomposed ExpVal
boz)
resolveBozConstant SymbolTable
_ String
_ ExpVal
_ = String -> ExpVal
forall a. HasCallStack => String -> a
error String
"Can only resolve ExpVal Boz"


-- Convert BOZ string to integer of specific kind
bozToInt :: Int -> ExpVal -> ExpVal
bozToInt :: Int -> ExpVal -> ExpVal
bozToInt Int
kind ExpVal
boz = BozDecomposed -> Int -> ExpVal
resolveBozConstantInContext (ExpVal -> BozDecomposed
parseBozDecomposed ExpVal
boz) Int
kind

-- Convert BOZ string to integer*2
bozToInt2 :: ExpVal -> ExpVal
bozToInt2 :: ExpVal -> ExpVal
bozToInt2 = Int -> ExpVal -> ExpVal
bozToInt Int
2

-- Convert BOZ string to integer*4
bozToInt4 :: ExpVal -> ExpVal
bozToInt4 :: ExpVal -> ExpVal
bozToInt4 = Int -> ExpVal -> ExpVal
bozToInt Int
4

-- Convert BOZ string to integer*8
bozToInt8 :: ExpVal -> ExpVal
bozToInt8 :: ExpVal -> ExpVal
bozToInt8 = Int -> ExpVal -> ExpVal
bozToInt Int
8