#!/usr/bin/env stack
-- stack runghc --package libyaml --package aeson --package unordered-containers --package text

{-# LANGUAGE OverloadedStrings
           , LambdaCase
           , PackageImports
           , NamedFieldPuns
           , RecordWildCards
  #-}

import "libyaml" Text.Libyaml
import Control.Monad.Trans.Resource
import Data.Conduit
import qualified Data.Conduit.List as C

import qualified Data.Aeson as JSON

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as CBS
import qualified Data.ByteString.Lazy as LBS

import qualified Data.HashMap.Lazy as HashMap

import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Text.Encoding as Text

import Text.Printf
import System.IO (stderr)

main :: IO ()
main = do
  Just packageJSON <- JSON.decode <$> LBS.readFile "package.json"
  let
    newVersion :: Text
    Just (JSON.String newVersion) = HashMap.lookup ("version" :: Text) packageJSON

  updatePackageYaml newVersion


updatePackageYaml :: Text -> IO ()
updatePackageYaml newVersion = do
  (oldVersion, start, end) <- runResourceT . runConduit . (.|) (decodeFileMarked "package.yaml") $ do
    awaitUntil $ \case
      MarkedEvent{ yamlEvent = EventMappingStart _ _ _ } -> True
      _ -> False
    awaitUntil $ \case
      MarkedEvent{ yamlEvent = EventScalar s _ _ _ }
        | s == "version" -> True
      _ -> False
    _ <- await -- Throw away "version: "
    Just MarkedEvent{ yamlEvent = EventScalar oldVersion' _ _ _, .. } <- await
    let oldVersion = Text.decodeUtf8 oldVersion'
    return (oldVersion, yamlStartMark, yamlEndMark)

  encNewVersion <- runResourceT . runConduit . (.| encode) $ C.sourceList
    [ EventStreamStart
    , EventDocumentStart
    , EventScalar (Text.encodeUtf8 newVersion) NoTag Any Nothing
    , EventDocumentEnd
    , EventStreamEnd
    ]

  hPrintf stderr "package.yaml: %s -> %s\n" oldVersion newVersion

  packageYaml <- BS.readFile "package.yaml"
  BS.writeFile "package.yaml" . mconcat $
    [ BS.take (fromIntegral $ yamlIndex start) packageYaml
    , Text.encodeUtf8 . Text.strip $ Text.decodeUtf8 encNewVersion
    , BS.drop (fromIntegral $ yamlIndex end) packageYaml
    ]
  where
    awaitUntil :: Monad m => (i -> Bool) -> ConduitM i o m ()
    awaitUntil pred = do
      nextIn <- await
      case nextIn of
        Nothing -> error "Ran out of input in awaitUntil"
        Just inp
          | pred inp -> leftover inp
        Just _ -> awaitUntil pred