clash-lib-1.10.0: tools/v16-upgrade-primitives.hs

{- Utility executable to convert "old-style" JSON primitives to "new-style"
   YAML ones. See https://github.com/clash-lang/clash-compiler/pull/2009.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

module Main where

import qualified Data.Aeson.KeyMap as Aeson
import Data.String (IsString)
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Encoding as LazyText

import qualified Data.Aeson.Extra as AesonExtra
import qualified Data.Aeson as Aeson
import qualified Data.Yaml as Yaml
import qualified Data.ByteString.Lazy as ByteString
import qualified Data.Set as Set

import Control.Monad (forM_, when)
import Data.ByteString.Lazy (ByteString)
import System.Directory (removeFile)
import System.Environment (getArgs)
import System.FilePath.Glob (glob)

help :: String
help = unlines
  [ "Convert JSON primitive files into YAML ones. YAML files will be written to "
  , "the original filename with '.yaml' appended."
  , ""
  , "Usage:"
  , "  v16-upgrade-primitives [options]... <file>..."
  , ""
  , "Options:"
  , "  --dry-run        Do not write YAML files."
  , "  --delete         Delete JSON files after writing."
  , "  --help | -h      Show this screen."
  , ""
  , "Example:"
  , "  v16-upgrade-primitives --dry-run prims/**/*.primitives"
  ]

-- | Same as 'glob', but errors on patterns matching no files.
globOrErr :: FilePath -> IO [FilePath]
globOrErr pattern = do
  files <- glob pattern
  when (null files) (error ("Pattern does not match any files: " <> pattern))
  pure files

-- | 'concatMap', but its monadic cousin
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM f = fmap concat . mapM f

-- | Read file and output YAML ByteString
jsonToYaml :: FilePath -> IO ByteString
jsonToYaml path = do
  contents <- ByteString.readFile path
  let decoded = AesonExtra.decodeOrErrJson path contents
  pure . removeTempKey . ByteString.fromStrict . Yaml.encode . customSortOutput $ decoded

{- NOTE [Sorting YAML object keys]

'Yaml.encode' encodes object with their keys in alphabetical order.
For readability we like `name` to be at the top, and `type` to be just above `template`.

We accomplice this here by renaming those keys to something there sorts where
we like them to be. And find-and-replace those temporary names back
in the resulting ByteString.
-}
keySortingRenames :: IsString str => [(str,str)]
keySortingRenames =
  [ ("name", "aaaa_really_should_be_name_but_renamed_to_get_the_sorting_we_like")
  , ("type", "really_should_be_type_but_renamed_to_get_the_sorting_we_like")
  ]

customSortOutput :: Aeson.Value -> Aeson.Value
customSortOutput x = case x of
  Aeson.Object o -> Aeson.Object $ fmap customSortOutput $ renameKeys $ o
  Aeson.Array xs -> Aeson.Array $ fmap customSortOutput xs
  _ -> x
 where
  renameKeys obj = foldl renameKey obj keySortingRenames
  renameKey obj (kOld,kNew) =
    case Aeson.lookup kOld obj of
      Nothing -> obj
      Just val -> Aeson.insert kNew val (Aeson.delete kOld obj)

removeTempKey :: ByteString -> ByteString
removeTempKey inp =
  LazyText.encodeUtf8 (foldl go (LazyText.decodeUtf8 inp) keySortingRenames)
 where
  go txt (orig,temp) = LazyText.replace temp orig txt

main :: IO ()
main = do
  args0 <- Set.fromList <$> getArgs

  let
    doDryRun = Set.member "--dry-run" args0
    doWrite = not doDryRun
    doDelete = Set.member "--delete" args0 && doWrite
    doHelp = Set.member "-h" args0 || Set.member "--help" args0 || Set.null args1
    args1 = foldr Set.delete args0 ["--dry-run", "--delete", "--help", "-h"]

  if doHelp then
    putStrLn help
  else do
    files <- concatMapM globOrErr (Set.toList args1)
    forM_ files $ \path -> do
      let newPath = path <> ".yaml"
      putStrLn $ "Converting " <> path <> ".."
      decoded <- jsonToYaml path
      when doWrite $ ByteString.writeFile newPath decoded
      when doDelete $ removeFile path