liquidhaskell-0.8.10.1: mirror-modules/Main.hs

module Main where

import           CLI
import           Options.Applicative

import           Control.Monad

import qualified Data.Text                               as T
import qualified Data.Set                                as S
import qualified Data.Map.Strict                         as M
import           Data.Set                                 ( Set )
import           Data.Function                            ( (&) )

import           System.FilePath
import           Shelly                                  as Sh hiding ((</>))

import           Text.Mustache                           (substitute, automaticCompile)

import Paths_liquidhaskell

--
-- Utility functions
--

findExistingModules :: CLI -> Sh (Set T.Text)
findExistingModules cli = do
  allFiles <- Sh.findWhen (\f -> pure $ takeExtension f == ".hs") (moduleHierarchyRoot cli)
  pure . S.fromList . map transform $ allFiles
  where
    -- Transform an input file by:
    -- * Stripping the path;
    -- * Replacing slashes with dots;
    -- * Remove the final \".hs"\ extension.
    transform :: FilePath -> T.Text
    transform f = f & dropExtension
                    & T.pack
                    & T.replace (T.pack $ moduleHierarchyRoot cli) mempty
                    & T.replace "/" "."
                    & T.replace "/" "."

-- Extracts the name of the mirrored package by dropping the \"liquid-\" prefix.
mirroredPackage :: CLI -> T.Text
mirroredPackage = T.tail . snd . T.breakOn "-" . mirrorPackageName

--
-- The main workhorse
--

mirrorModules :: CLI -> IO ()
mirrorModules cli@CLI{..} = shelly $ silently $ do
  dataDir         <- liftIO getDataDir
  inputModules    <- S.fromList . map T.strip . T.words <$> readfile modulesList
  existingModules <- findExistingModules cli

  -- If the user decided to completely override existing files, simply return all the input modules.
  let notMirrored = if | unFlag overrideFiles -> inputModules
                       | otherwise            -> inputModules `S.difference` existingModules


  -- Use a template to automatically generate the module.
  let searchSpace = [dataDir </> "mirror-modules/templates"]
      templateName = "MirrorModule.mustache"

  compiled <- liftIO $ automaticCompile searchSpace templateName
  case compiled of
    Left err       -> errorExit (T.pack . show $ err)
    Right template -> do
      forM_ notMirrored $ \toMirror -> do
        let ctx = M.fromList [("packageName" :: String, mirroredPackage cli), ("moduleName", toMirror)]
        let newModule = substitute template ctx

        let pathToModule = moduleHierarchyRoot </> T.unpack (T.replace "." "/" toMirror) <> ".hs"
        parentFolder <- T.strip <$> run "dirname" [T.pack pathToModule]

        -- Create the parent folder, if necessary.
        mkdir_p (T.unpack parentFolder)

        -- Write the module.
        writefile pathToModule newModule

      echo $ "Mirrored " <> T.pack (show . length $ notMirrored) <> " modules."

main :: IO ()
main = mirrorModules =<< execParser opts
  where
    opts = info (parseCLI <**> helper)
      ( fullDesc
     <> progDesc "Create modules to be used in mirror packages."
     <> header "mirror-modules - Generate modules in mirror packages." )