{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main where
import Data.List (nub)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import GHC.Base (String)
import Hpack.Config (Executable, Library, Package (..),
Section (..), readPackageConfig)
import Protolude
import System.Directory (canonicalizePath, getAppUserDataDirectory)
import System.Environment (getArgs)
import System.IO.Error (userError)
genLocals :: FilePath -> Package -> [(FilePath, Text)]
genLocals f = map (second
$ (prologue <>)
. (<> "\n")
. parens
. parens
. ("haskell-mode " <>)
. parens
. ("intero-targets " <>)
. T.unwords
. map show
. Set.toList
)
. extractTargets f
where
parens :: Text -> Text
parens = ("(" <>) . (<> ")")
prologue :: Text
prologue = ";;; Directory Local Variables\n;;; For more information see (info \"(emacs) Directory Variables\")\n\n"
-- FIX these are all terrible names
extractTargets :: FilePath -> Package -> [(FilePath, Set Text)]
extractTargets root Package{..}
= collapse
[ex "exe" packageExecutables
,ex "test" packageTests
,ex "bench" packageBenchmarks
, lib]
where
lib = f ["lib"] <$> maybeToList packageLibrary
ex :: String -> Map String (Section Executable) -> [[(FilePath, [Text])]]
ex ty = map (\(target,section) -> f [ty,target] section) . Map.toList
f :: [String] -> Section a -> [(FilePath, [Text])]
f pieces Section{..} =
map (\name -> (root <> "/" <> name <> "/.dir-locals.el"
,lib <> [mkTarget pieces])) sectionSourceDirs
where lib = const (mkTarget ["lib"]) <$> maybeToList packageLibrary
collapse = Map.toList . Map.fromListWith Set.intersection
. map (second Set.fromList) . concat . concat
mkTarget = T.intercalate ":" . map T.pack . (packageName:)
abort :: String -> IO ()
abort = ioError . userError
main :: IO ()
main = getArgs >>= \case
[f1] -> do
c <- canonicalizePath f1
getAppUserDataDirectory "hpack"
>>= (`readPackageConfig` (c <> "/package.yaml"))
>>= either abort (writeFiles c . fst)
x -> abort $ "exactly one argument needed, got " <> show x
where
writeFiles f = mapM_ (uncurry writeFile) . genLocals f
-- writeFiles f = print . extractTargets f