module Telescope.Fits.Encoding where

import Control.Applicative ((<|>))
import Control.Exception (Exception)
import Control.Monad.Catch (MonadThrow, throwM)
import Data.ByteString qualified as BS
import Data.ByteString.Builder
import Data.ByteString.Lazy qualified as BL
import Data.Char (toUpper)
import Data.Fits qualified as Fits
import Data.Fits.MegaParser qualified as Fits
import Data.Fits.Read (FitsError (..))
import Data.List qualified as L
import Data.String (IsString (..))
import Data.Text (Text, isPrefixOf, pack, unpack)
import Telescope.Fits.Types
import Text.Megaparsec qualified as M


{- | Decode a FITS file read as a strict 'ByteString'

>  decode =<< BS.readFile "samples/simple2x3.fits"
-}
decode :: forall m. (MonadThrow m) => BS.ByteString -> m Fits
decode :: forall (m :: * -> *). MonadThrow m => ByteString -> m Fits
decode ByteString
inp = do
  [HeaderDataUnit]
hdus <- (ParseErr -> m [HeaderDataUnit])
-> ([HeaderDataUnit] -> m [HeaderDataUnit])
-> Either ParseErr [HeaderDataUnit]
-> m [HeaderDataUnit]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (HDUError -> m [HeaderDataUnit]
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HDUError -> m [HeaderDataUnit])
-> (ParseErr -> HDUError) -> ParseErr -> m [HeaderDataUnit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FitsError -> HDUError
FormatError (FitsError -> HDUError)
-> (ParseErr -> FitsError) -> ParseErr -> HDUError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErr -> FitsError
ParseError) [HeaderDataUnit] -> m [HeaderDataUnit]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParseErr [HeaderDataUnit] -> m [HeaderDataUnit])
-> Either ParseErr [HeaderDataUnit] -> m [HeaderDataUnit]
forall a b. (a -> b) -> a -> b
$ Parsec Void ByteString [HeaderDataUnit]
-> String -> ByteString -> Either ParseErr [HeaderDataUnit]
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
M.runParser Parsec Void ByteString [HeaderDataUnit]
Fits.parseHDUs String
"FITS" ByteString
inp
  case [HeaderDataUnit]
hdus of
    [] -> HDUError -> m Fits
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM HDUError
MissingPrimary
    (HeaderDataUnit
h : [HeaderDataUnit]
hs) -> do
      PrimaryHDU
primaryHDU <- HeaderDataUnit -> m PrimaryHDU
toPrimary HeaderDataUnit
h
      [Extension]
extensions <- (HeaderDataUnit -> m Extension)
-> [HeaderDataUnit] -> m [Extension]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HeaderDataUnit -> m Extension
toExtension [HeaderDataUnit]
hs
      Fits -> m Fits
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fits -> m Fits) -> Fits -> m Fits
forall a b. (a -> b) -> a -> b
$ Fits{PrimaryHDU
primaryHDU :: PrimaryHDU
$sel:primaryHDU:Fits :: PrimaryHDU
primaryHDU, [Extension]
extensions :: [Extension]
$sel:extensions:Fits :: [Extension]
extensions}
 where
  toExtension :: Fits.HeaderDataUnit -> m Extension
  toExtension :: HeaderDataUnit -> m Extension
toExtension HeaderDataUnit
hdu =
    case HeaderDataUnit
hdu._extension of
      Extension
Fits.Primary -> HDUError -> m Extension
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HDUError -> m Extension) -> HDUError -> m Extension
forall a b. (a -> b) -> a -> b
$ String -> HDUError
InvalidExtension String
"Primary, expected Extension"
      Extension
Fits.Image -> Extension -> m Extension
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Extension -> m Extension) -> Extension -> m Extension
forall a b. (a -> b) -> a -> b
$ ImageHDU -> Extension
Image (ImageHDU -> Extension) -> ImageHDU -> Extension
forall a b. (a -> b) -> a -> b
$ Header -> DataArray -> ImageHDU
ImageHDU HeaderDataUnit
hdu._header (DataArray -> ImageHDU) -> DataArray -> ImageHDU
forall a b. (a -> b) -> a -> b
$ HeaderDataUnit -> DataArray
dataArray HeaderDataUnit
hdu
      Extension
ex -> HDUError -> m Extension
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HDUError -> m Extension) -> HDUError -> m Extension
forall a b. (a -> b) -> a -> b
$ String -> HDUError
InvalidExtension (Extension -> String
forall a. Show a => a -> String
show Extension
ex)

  toPrimary :: Fits.HeaderDataUnit -> m PrimaryHDU
  toPrimary :: HeaderDataUnit -> m PrimaryHDU
toPrimary HeaderDataUnit
hdu =
    case HeaderDataUnit
hdu._extension of
      Extension
Fits.Primary -> PrimaryHDU -> m PrimaryHDU
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimaryHDU -> m PrimaryHDU) -> PrimaryHDU -> m PrimaryHDU
forall a b. (a -> b) -> a -> b
$ Header -> DataArray -> PrimaryHDU
PrimaryHDU HeaderDataUnit
hdu._header (DataArray -> PrimaryHDU) -> DataArray -> PrimaryHDU
forall a b. (a -> b) -> a -> b
$ HeaderDataUnit -> DataArray
dataArray HeaderDataUnit
hdu
      Extension
_ -> HDUError -> m PrimaryHDU
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HDUError -> m PrimaryHDU) -> HDUError -> m PrimaryHDU
forall a b. (a -> b) -> a -> b
$ String -> HDUError
InvalidExtension String
"Extension, expected Primary"

  dataArray :: Fits.HeaderDataUnit -> DataArray
  dataArray :: HeaderDataUnit -> DataArray
dataArray HeaderDataUnit
hdu =
    DataArray
      { $sel:bitpix:DataArray :: BitPix
bitpix = BitPixFormat -> BitPix
bitpix HeaderDataUnit
hdu._dimensions._bitpix
      , $sel:axes:DataArray :: Axes Column
axes = Axes -> Axes Column
axes HeaderDataUnit
hdu._dimensions._axes
      , $sel:rawData:DataArray :: ByteString
rawData = HeaderDataUnit
hdu._mainData
      }

  -- decodePrimary :: BS.ByteString -> m PrimaryHDU
  -- decodePrimary inp =
  -- toImage :: Fits.HeaderDataUnit -> m ImageHDU

  bitpix :: Fits.BitPixFormat -> BitPix
  bitpix :: BitPixFormat -> BitPix
bitpix BitPixFormat
Fits.EightBitInt = BitPix
BPInt8
  bitpix BitPixFormat
Fits.SixteenBitInt = BitPix
BPInt16
  bitpix BitPixFormat
Fits.ThirtyTwoBitInt = BitPix
BPInt32
  bitpix BitPixFormat
Fits.SixtyFourBitInt = BitPix
BPInt64
  bitpix BitPixFormat
Fits.ThirtyTwoBitFloat = BitPix
BPFloat
  bitpix BitPixFormat
Fits.SixtyFourBitFloat = BitPix
BPDouble

  axes :: Fits.Axes -> Axes Column
  axes :: Axes -> Axes Column
axes = Axes -> Axes Column
forall {k} (a :: k). Axes -> Axes a
Axes


data HDUError
  = InvalidExtension String
  | MissingPrimary
  | FormatError FitsError
  deriving (Int -> HDUError -> ShowS
[HDUError] -> ShowS
HDUError -> String
(Int -> HDUError -> ShowS)
-> (HDUError -> String) -> ([HDUError] -> ShowS) -> Show HDUError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HDUError -> ShowS
showsPrec :: Int -> HDUError -> ShowS
$cshow :: HDUError -> String
show :: HDUError -> String
$cshowList :: [HDUError] -> ShowS
showList :: [HDUError] -> ShowS
Show, Show HDUError
Typeable HDUError
Typeable HDUError
-> Show HDUError
-> (HDUError -> SomeException)
-> (SomeException -> Maybe HDUError)
-> (HDUError -> String)
-> Exception HDUError
SomeException -> Maybe HDUError
HDUError -> String
HDUError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
$ctoException :: HDUError -> SomeException
toException :: HDUError -> SomeException
$cfromException :: SomeException -> Maybe HDUError
fromException :: SomeException -> Maybe HDUError
$cdisplayException :: HDUError -> String
displayException :: HDUError -> String
Exception)


{- | Encode a FITS file to a strict 'ByteString'

> BS.writeFile $ encdoe fits
-}
encode :: Fits -> BS.ByteString
encode :: Fits -> ByteString
encode Fits
f =
  let primary :: BuilderBlock
primary = PrimaryHDU -> BuilderBlock
renderPrimaryHDU Fits
f.primaryHDU
      exts :: [BuilderBlock]
exts = (Extension -> BuilderBlock) -> [Extension] -> [BuilderBlock]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> BuilderBlock
renderExtensionHDU Fits
f.extensions
   in ByteString -> ByteString
BS.toStrict (ByteString -> ByteString)
-> (BuilderBlock -> ByteString) -> BuilderBlock -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuilderBlock -> ByteString
runRender (BuilderBlock -> ByteString) -> BuilderBlock -> ByteString
forall a b. (a -> b) -> a -> b
$ BuilderBlock
primary BuilderBlock -> BuilderBlock -> BuilderBlock
forall a. Semigroup a => a -> a -> a
<> [BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat [BuilderBlock]
exts


-- | Execute a BuilderBlock and create a bytestring
runRender :: BuilderBlock -> BL.ByteString
runRender :: BuilderBlock -> ByteString
runRender BuilderBlock
bb = Builder -> ByteString
toLazyByteString BuilderBlock
bb.builder


renderPrimaryHDU :: PrimaryHDU -> BuilderBlock
renderPrimaryHDU :: PrimaryHDU -> BuilderBlock
renderPrimaryHDU PrimaryHDU
hdu =
  [BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat
    [ BitPix -> Axes Column -> Header -> BuilderBlock
renderPrimaryHeader PrimaryHDU
hdu.dataArray.bitpix PrimaryHDU
hdu.dataArray.axes PrimaryHDU
hdu.header
    , ByteString -> BuilderBlock
renderData PrimaryHDU
hdu.dataArray.rawData
    ]


renderExtensionHDU :: Extension -> BuilderBlock
renderExtensionHDU :: Extension -> BuilderBlock
renderExtensionHDU (Image ImageHDU
hdu) = ImageHDU -> BuilderBlock
renderImageHDU ImageHDU
hdu


renderImageHDU :: ImageHDU -> BuilderBlock
renderImageHDU :: ImageHDU -> BuilderBlock
renderImageHDU ImageHDU
hdu =
  [BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat
    [ BitPix -> Axes Column -> Header -> BuilderBlock
renderImageHeader ImageHDU
hdu.dataArray.bitpix ImageHDU
hdu.dataArray.axes ImageHDU
hdu.header
    , ByteString -> BuilderBlock
renderData ImageHDU
hdu.dataArray.rawData
    ]


renderData :: BS.ByteString -> BuilderBlock
renderData :: ByteString -> BuilderBlock
renderData ByteString
s = BuilderBlock -> BuilderBlock
fillBlock (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ Int -> Builder -> BuilderBlock
BuilderBlock (ByteString -> Int
BS.length ByteString
s) (Builder -> BuilderBlock) -> Builder -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
s


renderImageHeader :: BitPix -> Axes Column -> Header -> BuilderBlock
renderImageHeader :: BitPix -> Axes Column -> Header -> BuilderBlock
renderImageHeader BitPix
bp Axes Column
as Header
h =
  BuilderBlock -> BuilderBlock
fillBlock (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$
    [BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat
      [ Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"XTENSION" (Text -> Value
String Text
"IMAGE") (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Image Extension")
      , BitPix -> Axes Column -> BuilderBlock
renderDataKeywords BitPix
bp Axes Column
as
      , Header -> BuilderBlock
renderOtherKeywords Header
h
      , BuilderBlock
renderEnd
      ]


renderPrimaryHeader :: BitPix -> Axes Column -> Header -> BuilderBlock
renderPrimaryHeader :: BitPix -> Axes Column -> Header -> BuilderBlock
renderPrimaryHeader BitPix
bp Axes Column
as Header
h =
  BuilderBlock -> BuilderBlock
fillBlock (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$
    [BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat
      [ Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"SIMPLE" (LogicalConstant -> Value
Logic LogicalConstant
T) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Conforms to the FITS standard")
      , BitPix -> Axes Column -> BuilderBlock
renderDataKeywords BitPix
bp Axes Column
as
      , Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"EXTEND" (LogicalConstant -> Value
Logic LogicalConstant
T) Maybe Text
forall a. Maybe a
Nothing
      , -- , renderKeywordLine "CHECKSUM" (String "TODO") Nothing
        -- , renderKeywordLine "DATASUM" (String "TODO") Nothing
        Header -> BuilderBlock
renderOtherKeywords Header
h
      , BuilderBlock
renderEnd
      ]


renderEnd :: BuilderBlock
renderEnd :: BuilderBlock
renderEnd = Int -> BuilderBlock -> BuilderBlock
pad Int
80 BuilderBlock
"END"


-- | Render required keywords for a data array
renderDataKeywords :: BitPix -> Axes Column -> BuilderBlock
renderDataKeywords :: BitPix -> Axes Column -> BuilderBlock
renderDataKeywords BitPix
bp (Axes Axes
as) =
  [BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat
    [ BuilderBlock
bitpix
    , BuilderBlock
naxis_
    , BuilderBlock
naxes
    ]
 where
  bitpix :: BuilderBlock
bitpix = Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"BITPIX" (Int -> Value
Integer (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ BitPix -> Int
bitPixCode BitPix
bp) (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BitPix -> Text
bitPixType BitPix
bp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") array data type")
  naxis_ :: BuilderBlock
naxis_ = Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"NAXIS" (Int -> Value
Integer (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ Axes -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Axes
as) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"number of axes in data array")
  naxes :: BuilderBlock
naxes = [BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat ([BuilderBlock] -> BuilderBlock) -> [BuilderBlock] -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith @Int Int -> Int -> BuilderBlock
forall {a}. Show a => a -> Int -> BuilderBlock
naxisN [Int
1 ..] Axes
as
  naxisN :: a -> Int -> BuilderBlock
naxisN a
n Int
a =
    let nt :: Text
nt = String -> Text
pack (a -> String
forall a. Show a => a -> String
show a
n)
     in Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine (Text
"NAXIS" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nt) (Int -> Value
Integer Int
a) (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"axis " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" length")
  bitPixType :: BitPix -> Text
bitPixType = String -> Text
pack (String -> Text) -> (BitPix -> String) -> BitPix -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
2 ShowS -> (BitPix -> String) -> BitPix -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitPix -> String
forall a. Show a => a -> String
show


-- | 'Header' contains all other keywords. Filter out any that match system keywords so they aren't rendered twice
renderOtherKeywords :: Header -> BuilderBlock
renderOtherKeywords :: Header -> BuilderBlock
renderOtherKeywords (Header [HeaderRecord]
ks) =
  [BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat ([BuilderBlock] -> BuilderBlock) -> [BuilderBlock] -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ (HeaderRecord -> BuilderBlock) -> [HeaderRecord] -> [BuilderBlock]
forall a b. (a -> b) -> [a] -> [b]
map HeaderRecord -> BuilderBlock
toLine ([HeaderRecord] -> [BuilderBlock])
-> [HeaderRecord] -> [BuilderBlock]
forall a b. (a -> b) -> a -> b
$ (HeaderRecord -> Bool) -> [HeaderRecord] -> [HeaderRecord]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (HeaderRecord -> Bool) -> HeaderRecord -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderRecord -> Bool
isSystemKeyword) [HeaderRecord]
ks
 where
  toLine :: HeaderRecord -> BuilderBlock
toLine (Keyword KeywordRecord
kr) = Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine KeywordRecord
kr._keyword KeywordRecord
kr._value KeywordRecord
kr._comment
  toLine (Comment Text
c) = Int -> BuilderBlock -> BuilderBlock
pad Int
80 (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ String -> BuilderBlock
string (String -> BuilderBlock) -> String -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ String
"COMMENT " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
c
  toLine HeaderRecord
BlankLine = Int -> BuilderBlock -> BuilderBlock
pad Int
80 BuilderBlock
""
  isSystemKeyword :: HeaderRecord -> Bool
isSystemKeyword (Keyword KeywordRecord
kr) =
    let k :: Text
k = KeywordRecord
kr._keyword
     in Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"BITPIX"
          Bool -> Bool -> Bool
|| Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"EXTEND"
          Bool -> Bool -> Bool
|| Text
"NAXIS" Text -> Text -> Bool
`isPrefixOf` Text
k
  isSystemKeyword HeaderRecord
_ = Bool
False


-- | Fill out the header or data block to the nearest 2880 bytes
fillBlock :: BuilderBlock -> BuilderBlock
fillBlock :: BuilderBlock -> BuilderBlock
fillBlock BuilderBlock
b =
  let rm :: Int
rm = Int
hduBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- BuilderBlock
b.length Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
hduBlockSize
   in BuilderBlock
b BuilderBlock -> BuilderBlock -> BuilderBlock
forall a. Semigroup a => a -> a -> a
<> Int -> BuilderBlock
extraSpaces Int
rm
 where
  extraSpaces :: Int -> BuilderBlock
extraSpaces Int
n
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
hduBlockSize = BuilderBlock
forall a. Monoid a => a
mempty
    | Bool
otherwise = Int -> BuilderBlock
spaces Int
n


bitPixCode :: BitPix -> Int
bitPixCode :: BitPix -> Int
bitPixCode BitPix
BPInt8 = Int
8
bitPixCode BitPix
BPInt16 = Int
16
bitPixCode BitPix
BPInt32 = Int
32
bitPixCode BitPix
BPInt64 = Int
64
bitPixCode BitPix
BPFloat = -Int
32
bitPixCode BitPix
BPDouble = -Int
64


-- Keyword Lines -----------------------------------------------------

renderKeywordLine :: Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine :: Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
k Value
v Maybe Text
mc =
  let kv :: BuilderBlock
kv = Text -> Value -> BuilderBlock
renderKeywordValue Text
k Value
v
   in Int -> BuilderBlock -> BuilderBlock
pad Int
80 (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ BuilderBlock -> Maybe Text -> BuilderBlock
addComment BuilderBlock
kv Maybe Text
mc
 where
  addComment :: BuilderBlock -> Maybe Text -> BuilderBlock
addComment BuilderBlock
kv Maybe Text
Nothing = BuilderBlock
kv
  addComment BuilderBlock
kv (Just Text
c) =
    let mx :: Int
mx = Int
80 Int -> Int -> Int
forall a. Num a => a -> a -> a
- BuilderBlock
kv.length
     in BuilderBlock
kv BuilderBlock -> BuilderBlock -> BuilderBlock
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> BuilderBlock
renderComment Int
mx Text
c


renderKeywordValue :: Text -> Value -> BuilderBlock
renderKeywordValue :: Text -> Value -> BuilderBlock
renderKeywordValue Text
k Value
v =
  [BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat
    [ Text -> BuilderBlock
renderKeyword Text
k
    , String -> BuilderBlock
string String
"= "
    , Int -> BuilderBlock -> BuilderBlock
pad Int
30 (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ Value -> BuilderBlock
renderValue Value
v
    ]


renderKeyword :: Text -> BuilderBlock
renderKeyword :: Text -> BuilderBlock
renderKeyword Text
k = Int -> BuilderBlock -> BuilderBlock
pad Int
8 (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ String -> BuilderBlock
string (String -> BuilderBlock) -> String -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
8 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
k


renderComment :: Int -> Text -> BuilderBlock
renderComment :: Int -> Text -> BuilderBlock
renderComment Int
mx Text
c = String -> BuilderBlock
string (String -> BuilderBlock) -> String -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
mx ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
" / " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
c


renderValue :: Value -> BuilderBlock
renderValue :: Value -> BuilderBlock
renderValue (Logic LogicalConstant
T) = Int -> BuilderBlock -> BuilderBlock
justify Int
30 BuilderBlock
"T"
renderValue (Logic LogicalConstant
F) = Int -> BuilderBlock -> BuilderBlock
justify Int
30 BuilderBlock
"F"
renderValue (Float Float
f) = Int -> BuilderBlock -> BuilderBlock
justify Int
30 (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ String -> BuilderBlock
string (String -> BuilderBlock) -> String -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Float -> String
forall a. Show a => a -> String
show Float
f
renderValue (Integer Int
n) = Int -> BuilderBlock -> BuilderBlock
justify Int
30 (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ String -> BuilderBlock
string (String -> BuilderBlock) -> String -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
n
renderValue (String Text
s) = String -> BuilderBlock
string (String -> BuilderBlock) -> String -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ String
"'" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'"


-- Builder Block ---------------------------------------------------------

-- | We need a builder that keeps track of its length so we can pad things
data BuilderBlock = BuilderBlock {BuilderBlock -> Int
length :: Int, BuilderBlock -> Builder
builder :: Builder}


-- | Smart constructor, don't allow negative lengths
builderBlock :: Int -> Builder -> BuilderBlock
builderBlock :: Int -> Builder -> BuilderBlock
builderBlock Int
n = Int -> Builder -> BuilderBlock
BuilderBlock (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n Int
0)


instance IsString BuilderBlock where
  fromString :: String -> BuilderBlock
fromString = String -> BuilderBlock
string


instance Semigroup BuilderBlock where
  BuilderBlock Int
l Builder
b <> :: BuilderBlock -> BuilderBlock -> BuilderBlock
<> BuilderBlock Int
l2 Builder
b2 = Int -> Builder -> BuilderBlock
BuilderBlock (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l2) (Builder
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b2)


instance Monoid BuilderBlock where
  mempty :: BuilderBlock
mempty = Int -> Builder -> BuilderBlock
BuilderBlock Int
0 Builder
forall a. Monoid a => a
mempty


justify :: Int -> BuilderBlock -> BuilderBlock
justify :: Int -> BuilderBlock -> BuilderBlock
justify Int
n BuilderBlock
b = Int -> BuilderBlock
spaces (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- BuilderBlock
b.length) BuilderBlock -> BuilderBlock -> BuilderBlock
forall a. Semigroup a => a -> a -> a
<> BuilderBlock
b


pad :: Int -> BuilderBlock -> BuilderBlock
pad :: Int -> BuilderBlock -> BuilderBlock
pad Int
n BuilderBlock
b = BuilderBlock
b BuilderBlock -> BuilderBlock -> BuilderBlock
forall a. Semigroup a => a -> a -> a
<> Int -> BuilderBlock
spaces (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- BuilderBlock
b.length)


spaces :: Int -> BuilderBlock
spaces :: Int -> BuilderBlock
spaces Int
n = Int -> Builder -> BuilderBlock
builderBlock Int
n (Builder -> BuilderBlock) -> Builder -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
n (Builder -> [Builder]) -> Builder -> [Builder]
forall a b. (a -> b) -> a -> b
$ Char -> Builder
charUtf8 Char
' '


string :: String -> BuilderBlock
string :: String -> BuilderBlock
string String
s = Int -> Builder -> BuilderBlock
builderBlock (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) (String -> Builder
stringUtf8 String
s)