-
Notifications
You must be signed in to change notification settings - Fork 1
/
Main.hs
143 lines (132 loc) · 4.25 KB
/
Main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
module Main where
import Data.Foldable (find, traverse_)
import qualified Data.List.Split as S
import Data.Maybe (catMaybes, fromMaybe, maybe)
import Data.Semigroup ((<>))
import Options.Applicative
import System.Directory
import System.FilePath
import qualified System.Posix.Escape as Posix
import System.Posix.Process (executeFile)
data Command
= Ghci GhciOpts
| Exec [String]
| Path
| IdeTargets
deriving (Show)
data GhciOpts = GhciOpts
{ withGhc :: Maybe String
, ghcOptions :: [String]
, targets :: [String]
} deriving (Show)
main :: IO ()
main = run =<< execParser (info (parse <**> helper) fullDesc)
run :: Command -> IO ()
run (Exec cmd) = nixExec $ ["cabal", "exec", "--verbose=0", "--"] ++ cmd -- TODO: do these really need to be run inside Cabal’s context?
run (Ghci opt) =
nixExec $
["cabal", "repl", "--verbose=0"] ++
maybe [] (\p -> ["--with-ghc", p]) (withGhc opt) ++
((\o -> ["--ghc-options", o]) =<< ghcOptions opt) ++ targets opt
run Path = putStrLn =<< rootDir
run IdeTargets = traverse_ putStrLn =<< ideTargets <$> (readFile =<< cabalFile)
nixExec :: [String] -> IO ()
nixExec cmd = do
setCurrentDirectory =<< rootDir
executeFile
"nix-shell"
True
["--pure", "--quiet", "--run", "exec " ++ Posix.escapeMany cmd]
Nothing
rootDir :: IO FilePath
rootDir = takeDirectory <$> cabalFile
cabalFile :: IO FilePath
cabalFile = do
searchDirs <- ancestors <$> getCurrentDirectory
results <- catMaybes <$> traverse findCabal searchDirs -- FIXME: suboptimal…
case results of
cabal:_ -> return cabal
_ -> error "No *.cabal file found."
where
ancestors d = d : iterateUntilRepeated takeDirectory d
findCabal :: FilePath -> IO (Maybe FilePath)
findCabal dir = do
mf <-
find
(\f -> takeExtension f == ".cabal" && (not . null $ takeBaseName f)) <$>
listDirectory dir
return $ combine dir <$> mf
iterateUntilRepeated
:: Eq a
=> (a -> a) -> a -> [a]
iterateUntilRepeated f a0 = reverse $ loop a0 []
where
loop an acc =
let an1 = f an
in if an == an1
then acc
else loop an1 (an1 : acc)
-- FIXME: yaml/regex/attoparsec?
ideTargets :: String -> [String]
ideTargets cabal =
let lns = lines cabal
splits = S.split (S.condense . S.dropDelims $ S.oneOf " :") <$> lns
kvs =
splits >>= \case
k:v:_ -> [(k, v)]
_ -> []
name = fromMaybe "_" $ snd <$> find (\(k, _) -> k == "name") kvs
lib = ["lib" | "library" `elem` lns]
tpe s l = (++) (s ++ ":") . snd <$> filter (\(k, _) -> k == l) kvs
exe = tpe "exe" "executable"
test = tpe "test" "test-suite"
in (++) (name ++ ":") <$> (lib ++ exe ++ test)
parse :: Parser Command
parse =
hsubparser
(command
"ghci"
(info
(Ghci <$>
(GhciOpts <$> optional (strOption (long "with-ghc")) <*>
((++) <$> many (strOption (long "ghci-options")) <*>
many (strOption (long "ghc-options"))) <*
optional (strOption (long "docker-run-args")) <*
optional (switch (long "no-build")) <*
optional (switch (long "no-load")) <*
verbosity <*>
many (argument str (metavar "TARGET…"))))
fullDesc) <>
command
"exec"
(info
(Exec <$ verbosity <*> some (argument str (metavar "CMD…")))
fullDesc) <>
command
"path"
(info (Path <$ flag' () (long "project-root") <* verbosity) fullDesc) <>
command
"ghc"
(info
(Exec <$> ((:) "ghc" <$> many (argument str (metavar "ARG…"))) <*
verbosity)
fullDesc) <>
command
"ide"
(info
(hsubparser
(command "targets" (info (IdeTargets <$ verbosity) fullDesc)))
fullDesc) <>
command
"hoogle"
(info
(Exec <$>
((:) "hoogle" <$ verbosity <* optional (switch (long "no-setup")) <*>
((\xs ->
if null xs
then ["--help"]
else xs) <$>
many (argument str (metavar "ARG…")))))
fullDesc))
where
verbosity = optional (strOption (long "verbosity"))