Main.curry 50.3 KB
Newer Older
Michael Hanus's avatar
Michael Hanus committed
1
2
3
4
5
6
--------------------------------------------------------------------------------
--- This is the main module of the Curry Package Manager.
--------------------------------------------------------------------------------

module CPM.Main where

Michael Hanus's avatar
Michael Hanus committed
7
import Char         ( toLower )
Michael Hanus's avatar
Michael Hanus committed
8
9
import CSV          ( showCSV )
import Directory    ( doesFileExist, getAbsolutePath, doesDirectoryExist
Michael Hanus's avatar
Michael Hanus committed
10
                    , copyFile, createDirectory, createDirectoryIfMissing
Michael Hanus's avatar
Michael Hanus committed
11
12
                    , getDirectoryContents, getModificationTime
                    , renameFile, removeFile, setCurrentDirectory )
Michael Hanus's avatar
Michael Hanus committed
13
import Distribution ( stripCurrySuffix, addCurrySubdir )
Michael Hanus's avatar
Michael Hanus committed
14
15
16
import Either
import FilePath     ( (</>), splitSearchPath, takeExtension )
import IO           ( hFlush, stdout )
17
import List         ( groupBy, intercalate, nub, split, splitOn )
Michael Hanus's avatar
Michael Hanus committed
18
import Sort         ( sortBy )
Michael Hanus's avatar
Michael Hanus committed
19
import System       ( getArgs, getEnviron, setEnviron, unsetEnviron, exitWith )
Michael Hanus's avatar
Michael Hanus committed
20
21
22
23
24

import Boxes (table, render)
import OptParse
import CPM.ErrorLogger
import CPM.FileUtil ( fileInPath, joinSearchPath, safeReadFile, whenFileExists
Michael Hanus's avatar
Michael Hanus committed
25
26
                    , ifFileExists, inDirectory, removeDirectoryComplete
                    , copyDirectory )
Michael Hanus's avatar
Michael Hanus committed
27
import CPM.Config   ( Config (..)
28
                    , readConfigurationWithDefault, showCompilerVersion )
Michael Hanus's avatar
Michael Hanus committed
29
30
31
32
import CPM.PackageCache.Global ( GlobalCache, readInstalledPackagesFromDir
                               , installFromZip, checkoutPackage
                               , uninstallPackage )
import CPM.Package
33
import CPM.Resolution ( isCompatibleToCompiler, showResult )
Michael Hanus's avatar
Michael Hanus committed
34
import CPM.Repository ( Repository, readRepository, findVersion, listPackages
Michael Hanus's avatar
Michael Hanus committed
35
36
                      , findLatestVersion, updateRepository, searchPackages
                      , updateRepositoryCache )
Michael Hanus's avatar
Michael Hanus committed
37
38
39
40
import CPM.PackageCache.Runtime ( dependencyPathsSeparate, writePackageConfig )
import CPM.PackageCopy
import CPM.Diff.API as APIDiff
import qualified CPM.Diff.Behavior as BDiff
Michael Hanus's avatar
Michael Hanus committed
41
import CPM.ConfigPackage (packagePath)
Michael Hanus's avatar
Michael Hanus committed
42
43
44
45
46
47

-- Banner of this tool:
cpmBanner :: String
cpmBanner = unlines [bannerLine,bannerText,bannerLine]
 where
 bannerText =
Michael Hanus's avatar
Michael Hanus committed
48
  "Curry Package Manager <curry-language.org/tools/cpm> (version of 24/05/2017)"
Michael Hanus's avatar
Michael Hanus committed
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
 bannerLine = take (length bannerText) (repeat '-')

main :: IO ()
main = do
  args <- getArgs
  parseResult <- return $ parse (intercalate " " args) optionParser "cpm"
  case parseResult of
    Left err -> do putStrLn cpmBanner
                   putStrLn err
                   putStrLn "(use option -h for usage information)"
                   exitWith 1
    Right  r -> case applyParse r of
      Left err   -> do putStrLn cpmBanner
                       --printUsage "cpm" 80 optionParser
                       putStrLn err
                       exitWith 1
      Right opts -> runWithArgs opts

runWithArgs :: Options -> IO ()
runWithArgs opts = do
Michael Hanus's avatar
Michael Hanus committed
69
  setWithShowTime (optWithTime opts)
Michael Hanus's avatar
Michael Hanus committed
70
71
72
73
74
75
76
77
78
79
80
  missingExecutables <- checkExecutables
  unless (null missingExecutables) $ do
      putStrLn $ "The following programs could not be found on the PATH " ++
                 "(they are required for cpm to work):\n" ++
                 intercalate ", " missingExecutables
      exitWith 1
  config <- readConfigurationWithDefault (optDefConfig opts) >>= \c ->
   case c of
    Left err -> do putStrLn $ "Error reading .cpmrc settings: " ++ err
                   exitWith 1
    Right c' -> return c'
Michael Hanus's avatar
Michael Hanus committed
81
  let getRepoGC = readRepository config >>= \repo ->
Michael Hanus's avatar
Michael Hanus committed
82
                  getGlobalCache config repo >>= \gc -> return (repo,gc)
Michael Hanus's avatar
Michael Hanus committed
83
84
85
86
  setLogLevel $ optLogLevel opts
  (msgs, result) <- case optCommand opts of
    NoCommand   -> failIO "NoCommand"
    Update      -> updateRepository config
Michael Hanus's avatar
Michael Hanus committed
87
88
89
90
    Compiler o  -> compiler o config getRepoGC
    Exec o      -> exec     o config getRepoGC
    Doc  o      -> docCmd   o config getRepoGC
    Test o      -> test     o config getRepoGC
Michael Hanus's avatar
Michael Hanus committed
91
92
    Link o      -> linkCmd  o config
    Add  o      -> addCmd   o config
Michael Hanus's avatar
Michael Hanus committed
93
    Clean       -> cleanPackage Info
Michael Hanus's avatar
Michael Hanus committed
94
    New o       -> newPackage o
Michael Hanus's avatar
Michael Hanus committed
95
    _ -> do repo <- readRepository config
Michael Hanus's avatar
Michael Hanus committed
96
97
98
            case optCommand opts of
              List   o -> listCmd o config repo
              Search o -> search  o config repo
Michael Hanus's avatar
Michael Hanus committed
99
              _ -> do globalCache <- getGlobalCache config repo
Michael Hanus's avatar
Michael Hanus committed
100
101
102
103
                      case optCommand opts of
                        Deps         -> deps         config repo globalCache
                        PkgInfo o    -> info       o config repo globalCache
                        Checkout o   -> checkout   o config repo globalCache
Michael Hanus's avatar
Michael Hanus committed
104
                        InstallApp o -> installapp o config repo globalCache
Michael Hanus's avatar
Michael Hanus committed
105
106
107
108
109
110
111
112
113
114
115
116
                        Install o    -> install    o config repo globalCache
                        Diff o       -> diff       o config repo globalCache
                        Uninstall o  -> uninstall  o config repo globalCache
                        Upgrade o    -> upgrade    o config repo globalCache
                        _ -> error "Internal command processing error!"
  mapIO showLogEntry msgs
  let allOk =  all (levelGte Info) (map logLevelOf msgs) &&
               either (\le -> levelGte Info (logLevelOf le))
                      (const True)
                      result
  exitWith (if allOk then 0 else 1)

Michael Hanus's avatar
Michael Hanus committed
117
118
119
getGlobalCache :: Config -> Repository -> IO GlobalCache
getGlobalCache config repo = do
  maybeGC <- readInstalledPackagesFromDir repo $ packageInstallDir config
Michael Hanus's avatar
Michael Hanus committed
120
121
122
123
124
125
126
127
  case maybeGC of
    Left err -> do putStrLn $ "Error reading global package cache: " ++ err
                   exitWith 1
    Right gc -> return gc

data Options = Options
  { optLogLevel  :: LogLevel
  , optDefConfig :: [(String,String)]
Michael Hanus's avatar
Michael Hanus committed
128
  , optWithTime  :: Bool
Michael Hanus's avatar
Michael Hanus committed
129
130
131
132
133
134
  , optCommand   :: Command }

data Command 
  = Deps 
  | NoCommand
  | Checkout   CheckoutOptions
Michael Hanus's avatar
Michael Hanus committed
135
  | InstallApp CheckoutOptions
Michael Hanus's avatar
Michael Hanus committed
136
137
138
139
140
141
142
143
144
  | Install    InstallOptions
  | Uninstall  UninstallOptions
  | PkgInfo    InfoOptions
  | Compiler   CompilerOptions
  | Update
  | List       ListOptions
  | Search     SearchOptions
  | Upgrade    UpgradeOptions
  | Link       LinkOptions
Michael Hanus's avatar
Michael Hanus committed
145
  | Add        AddOptions
Michael Hanus's avatar
Michael Hanus committed
146
  | Exec       ExecOptions
147
  | Doc        DocOptions
Michael Hanus's avatar
Michael Hanus committed
148
149
  | Test       TestOptions
  | Diff       DiffOptions
Michael Hanus's avatar
Michael Hanus committed
150
  | New        NewOptions
Michael Hanus's avatar
Michael Hanus committed
151
  | Clean
Michael Hanus's avatar
Michael Hanus committed
152
153
154
155
156
157
158
159
160

data CheckoutOptions = CheckoutOptions
  { coPackage    :: String
  , coVersion    :: Maybe Version
  , coPrerelease :: Bool }

data InstallOptions = InstallOptions
  { instTarget     :: Maybe String
  , instVersion    :: Maybe Version
Michael Hanus's avatar
Michael Hanus committed
161
162
  , instPrerelease :: Bool
  , instExecutable :: Bool }
Michael Hanus's avatar
Michael Hanus committed
163
164
165
166
167
168
169
170

data UninstallOptions = UninstallOptions
  { uninstPackage :: Maybe String
  , uninstVersion :: Maybe Version }

data InfoOptions = InfoOptions
  { infoPackage :: Maybe String
  , infoVersion :: Maybe Version
Michael Hanus's avatar
Michael Hanus committed
171
172
173
  , infoAll     :: Bool
  , infoPlain   :: Bool  -- plain output, no bold/color
  }
Michael Hanus's avatar
Michael Hanus committed
174
175

data ListOptions = ListOptions
Michael Hanus's avatar
Michael Hanus committed
176
  { listVers :: Bool   -- list all versions of each package
Michael Hanus's avatar
Michael Hanus committed
177
178
  , listCSV  :: Bool   -- list in CSV format
  , listCat  :: Bool   -- list all categories
179
  }
Michael Hanus's avatar
Michael Hanus committed
180
181

data SearchOptions = SearchOptions
Michael Hanus's avatar
Michael Hanus committed
182
183
184
  { searchQuery  :: String
  , searchModule :: Bool
  }
Michael Hanus's avatar
Michael Hanus committed
185
186
187
188
189
190
191

data UpgradeOptions = UpgradeOptions
  { upgrTarget :: Maybe String }

data LinkOptions = LinkOptions
  { lnkSource :: String }

Michael Hanus's avatar
Michael Hanus committed
192
193
194
195
196
data AddOptions = AddOptions
  { addSource :: String
  , forceAdd  :: Bool
  }

Michael Hanus's avatar
Michael Hanus committed
197
198
199
data NewOptions = NewOptions
  { projectName :: String }

Michael Hanus's avatar
Michael Hanus committed
200
201
202
203
204
205
206
207
data ExecOptions = ExecOptions
  { exeCommand :: String   -- command to be executed
  , exePath    :: [String] -- additional load path
  }

data CompilerOptions = CompilerOptions
  { comCommand :: String }

208
209
210
211
212
data DocOptions = DocOptions
  { docDir     :: Maybe String     -- documentation directory
  , docModules :: Maybe [String]   -- modules to be documented
  }

Michael Hanus's avatar
Michael Hanus committed
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
data TestOptions = TestOptions
  { testModules :: Maybe [String] }

data DiffOptions = DiffOptions
  { diffVersion  :: Maybe Version
  , diffModules  :: Maybe [String]
  , diffAPI      :: Bool
  , diffBehavior :: Bool
  , diffUseAna   :: Bool }

checkoutOpts :: Options -> CheckoutOptions
checkoutOpts s = case optCommand s of
  Checkout opts -> opts
  _             -> CheckoutOptions "" Nothing False

installOpts :: Options -> InstallOptions
installOpts s = case optCommand s of
  Install opts -> opts
Michael Hanus's avatar
Michael Hanus committed
231
  _            -> InstallOptions Nothing Nothing False True
Michael Hanus's avatar
Michael Hanus committed
232
233
234
235
236
237
238
239
240

uninstallOpts :: Options -> UninstallOptions
uninstallOpts s = case optCommand s of
  Uninstall opts -> opts
  _              -> UninstallOptions Nothing Nothing

infoOpts :: Options -> InfoOptions
infoOpts s = case optCommand s of
  PkgInfo opts -> opts
Michael Hanus's avatar
Michael Hanus committed
241
  _            -> InfoOptions Nothing Nothing False False
Michael Hanus's avatar
Michael Hanus committed
242
243
244
245

listOpts :: Options -> ListOptions
listOpts s = case optCommand s of
  List opts -> opts
246
  _         -> ListOptions False False False
Michael Hanus's avatar
Michael Hanus committed
247
248
249
250

searchOpts :: Options -> SearchOptions
searchOpts s = case optCommand s of
  Search opts -> opts
Michael Hanus's avatar
Michael Hanus committed
251
  _           -> SearchOptions "" False
Michael Hanus's avatar
Michael Hanus committed
252
253
254
255
256
257
258
259
260
261
262

upgradeOpts :: Options -> UpgradeOptions
upgradeOpts s = case optCommand s of
  Upgrade opts -> opts
  _            -> UpgradeOptions Nothing

linkOpts :: Options -> LinkOptions
linkOpts s = case optCommand s of
  Link opts -> opts
  _         -> LinkOptions ""

Michael Hanus's avatar
Michael Hanus committed
263
264
265
266
267
addOpts :: Options -> AddOptions
addOpts s = case optCommand s of
  Add opts -> opts
  _        -> AddOptions "" False

Michael Hanus's avatar
Michael Hanus committed
268
269
270
271
272
newOpts :: Options -> NewOptions
newOpts s = case optCommand s of
  New opts -> opts
  _        -> NewOptions ""

Michael Hanus's avatar
Michael Hanus committed
273
274
275
276
277
278
279
280
281
282
execOpts :: Options -> ExecOptions
execOpts s = case optCommand s of
  Exec opts -> opts
  _         -> ExecOptions "" []

compOpts :: Options -> CompilerOptions
compOpts s = case optCommand s of
  Compiler opts -> opts
  _             -> CompilerOptions ""

283
284
285
286
287
docOpts :: Options -> DocOptions
docOpts s = case optCommand s of
  Doc opts -> opts
  _        -> DocOptions Nothing Nothing

Michael Hanus's avatar
Michael Hanus committed
288
289
290
291
292
293
294
295
296
297
298
testOpts :: Options -> TestOptions
testOpts s = case optCommand s of
  Test opts -> opts
  _         -> TestOptions Nothing

diffOpts :: Options -> DiffOptions
diffOpts s = case optCommand s of
  Diff opts -> opts
  _         -> DiffOptions Nothing Nothing True True True

readLogLevel :: String -> Either String LogLevel
Michael Hanus's avatar
Michael Hanus committed
299
300
301
302
readLogLevel s = case map toLower s of
  "debug" -> Right Debug
  "info"  -> Right Info
  _       -> Left $ "Illegal verbosity value: " ++ s
Michael Hanus's avatar
Michael Hanus committed
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323

readRcOption :: String -> Either String (String,String)
readRcOption s =
  let (option,value) = break (=='=') s
  in if null value then Left $ "Error in option definition: '=' missing"
                   else Right $ (option, tail value)

readVersion' :: String -> Either String Version
readVersion' s = case readVersion s of
  Nothing -> Left $ "'" ++ s ++ "' is not a valid version"
  Just  v -> Right v

applyEither :: [Options -> Either String Options] -> Options -> Either String Options
applyEither [] z = Right z
applyEither (f:fs) z = case f z of
  Left err -> Left err
  Right z' -> applyEither fs z'

applyParse :: [Options -> Either String Options] -> Either String Options
applyParse fs = applyEither fs defaultOpts
 where
Michael Hanus's avatar
Michael Hanus committed
324
  defaultOpts = Options Info [] False NoCommand
Michael Hanus's avatar
Michael Hanus committed
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343

(>.>) :: Either String a -> (a -> b) -> Either String b
a >.> f = case a of 
  Left err -> Left err
  Right  v -> Right $ f v

optionParser :: ParseSpec (Options -> Either String Options)
optionParser = optParser 
  (   option (\s a -> readLogLevel s >.> \ll -> a { optLogLevel = ll })
        (  long "verbosity"
        <> short "v"
        <> metavar "LEVEL"
        <> help "Log level for the application. Valid values are 'info' and 'debug'." )
  <.> option (\s a -> readRcOption s >.> \kv ->
                      a { optDefConfig = optDefConfig a ++ [kv] })
        (  long "define"
        <> short "d"
        <> metavar "DEFINITION"
        <> help "Overwrite definition of cpmrc file with 'option=value'." )
Michael Hanus's avatar
Michael Hanus committed
344
345
346
347
  <.> flag (\a -> Right $ a { optWithTime = True })
        (  long "time"
        <> short "t"
        <> help "Show elapsed time with every log output" )
Michael Hanus's avatar
Michael Hanus committed
348
349
  <.> commands (metavar "COMMAND")
        (   command "checkout" (help "Checkout a package.") Right
Michael Hanus's avatar
Michael Hanus committed
350
351
352
                    (checkoutArgs Checkout)
        <|> command "installapp"
                     (help "Install the application provided by a package.") 
Michael Hanus's avatar
Michael Hanus committed
353
                     Right
Michael Hanus's avatar
Michael Hanus committed
354
                     (checkoutArgs InstallApp)
Michael Hanus's avatar
Michael Hanus committed
355
356
        <|> command "install" (help "Install a package.")
                     (\a -> Right $ a { optCommand = Install (installOpts a) })
Michael Hanus's avatar
Michael Hanus committed
357
                     installArgs
Michael Hanus's avatar
Michael Hanus committed
358
        <|> command "uninstall" (help "Uninstall package")
Michael Hanus's avatar
Michael Hanus committed
359
360
                 (\a -> Right $ a { optCommand = Uninstall (uninstallOpts a) })
                 uninstallArgs
Michael Hanus's avatar
Michael Hanus committed
361
362
363
364
        <|> command "deps" (help "Calculate dependencies")
                           (\a -> Right $ a { optCommand = Deps }) [] 
        <|> command "clean" (help "Clean the current package")
                          (\a -> Right $ a { optCommand = Clean }) []
Michael Hanus's avatar
Michael Hanus committed
365
        <|> command "new" (help "Create a new package") Right newArgs
Michael Hanus's avatar
Michael Hanus committed
366
367
        <|> command "update" (help "Update the package index")
                             (\a -> Right $ a { optCommand = Update }) []
Michael Hanus's avatar
Michael Hanus committed
368
369
370
371
372
373
374
375
        <|> command "curry"
           (help "Load package spec and start Curry with correct dependencies.")
                    (\a -> Right $ a { optCommand = Compiler (compOpts a) })
                    curryArgs
        <|> command "exec"
                    (help "Execute a command with the CURRYPATH set")
                    (\a -> Right $ a { optCommand = Exec (execOpts a) })
                    execArgs
Michael Hanus's avatar
Michael Hanus committed
376
        <|> command "info" (help "Print package information")
Michael Hanus's avatar
Michael Hanus committed
377
378
                    (\a -> Right $ a { optCommand = PkgInfo (infoOpts a) })
                    infoArgs
379
380
381
382
        <|> command "doc"
           (help "Generation documentation for current package (with CurryDoc)")
                    (\a -> Right $ a { optCommand = Doc (docOpts a) })
                    docArgs
Michael Hanus's avatar
Michael Hanus committed
383
384
        <|> command "test" (help "Test the current package (with CurryCheck)")
                    (\a -> Right $ a { optCommand = Test (testOpts a) })
Michael Hanus's avatar
Michael Hanus committed
385
                    testArgs
Michael Hanus's avatar
Michael Hanus committed
386
387
388
        <|> command "diff"
                    (help "Diff the current package against another version")
                    (\a -> Right $ a { optCommand = Diff (diffOpts a) })
Michael Hanus's avatar
Michael Hanus committed
389
                    diffArgs
Michael Hanus's avatar
Michael Hanus committed
390
        <|> command "list" (help "List all packages of the repository")
Michael Hanus's avatar
Michael Hanus committed
391
392
                    (\a -> Right $ a { optCommand = List (listOpts a) })
                    listArgs
Michael Hanus's avatar
Michael Hanus committed
393
        <|> command "search" (help "Search the package repository") Right
Michael Hanus's avatar
Michael Hanus committed
394
                    searchArgs
Michael Hanus's avatar
Michael Hanus committed
395
396
        <|> command "upgrade" (help "Upgrade one or more packages")
                    (\a -> Right $ a { optCommand = Upgrade (upgradeOpts a) })
Michael Hanus's avatar
Michael Hanus committed
397
                    upgradeArgs
Michael Hanus's avatar
Michael Hanus committed
398
        <|> command "link" (help "Link a package to the local cache") Right
Michael Hanus's avatar
Michael Hanus committed
399
400
401
                    linkArgs
        <|> command "add" (help "Add a package to the local repository") Right
                    addArgs ) )
Michael Hanus's avatar
Michael Hanus committed
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
 where
  checkoutArgs cmd =
        arg (\s a -> Right $ a { optCommand = cmd (checkoutOpts a)
                                                  { coPackage = s } })
          (  metavar "PACKAGE"
          <> help "The package name" )
    <.> arg (\s a -> readVersion' s >.> \v ->
                     a { optCommand = cmd (checkoutOpts a)
                                          { coVersion = Just v } })
          (  metavar "VERSION"
          <> help "The package version"
          <> optional)
    <.> flag (\a -> Right $ a { optCommand = cmd (checkoutOpts a)
                                                 { coPrerelease = True } })
          (  short "p"
          <> long "pre"
          <> help "Try pre-release versions when searching for newest version.")

  installArgs =
        arg (\s a -> Right $ a { optCommand = Install (installOpts a)
                                                      { instTarget = Just s } })
          (  metavar "TARGET"
          <> help "A package name or the path to a file"
          <> optional)
    <.> arg (\s a -> readVersion' s >.> \v ->
             a { optCommand = Install (installOpts a) { instVersion = Just v } })
          (  metavar "VERSION"
          <> help "The package version"
          <> optional)
    <.> flag (\a -> Right $ a { optCommand = Install (installOpts a)
                                               { instPrerelease = True } })
          (  short "p"
          <> long "pre"
          <> help "Try pre-release versions when searching for newest version.")
    <.> flag (\a -> Right $ a { optCommand = Install (installOpts a)
                                               { instExecutable = False } })
          (  short "n"
          <> long "noexec"
          <> help "Do not install executable.")

  uninstallArgs =
        arg (\s a -> Right $ a { optCommand =
             Uninstall (uninstallOpts a) { uninstPackage = Just s } })
          (  metavar "PACKAGE"
          <> help "The package to be uninstalled"
          <> optional)
    <.> arg (\s a -> readVersion' s >.> \v ->
                     a { optCommand = Uninstall (uninstallOpts a)
                                                { uninstVersion = Just v } })
          (  metavar "VERSION"
          <> help "The version to be uninstalled"
          <> optional)

  newArgs =
   arg (\s a -> Right $ a { optCommand = New (newOpts a)
                                             { projectName = s } })
       (  metavar "PROJECT"
       <> help "The name of the new project" )

  curryArgs =
    rest (\s a -> Right $ a { optCommand = Compiler (compOpts a)
                                                    { comCommand = s } })
         (  metavar "ARGS"
         <> help "The options to pass to the compiler"
         <> optional )

  execArgs =
    rest (\s a -> Right $ a { optCommand = Exec (execOpts a)
                                                { exeCommand = s } })
         (  metavar "CMD"
         <> help "The command to execute. Don't forget the quotes!"
         <> optional )

  infoArgs =
        arg (\s a -> Right $ a { optCommand = PkgInfo (infoOpts a)
                                                { infoPackage = Just s } })
          (  metavar "PACKAGE"
          <> help ("The package name. If no name is specified, cpm tries " ++
                   "to read a package specification in the current directory.")
          <> optional) 
    <.> arg (\s a -> readVersion' s >.> \v -> a
                                 { optCommand = PkgInfo (infoOpts a)
                                                  { infoVersion = Just v } })
          (  metavar "VERSION"
          <> help ("The package version. If no version is specified, " ++
                   "cpm uses the latest version of the specified package.")
          <> optional )
    <.> flag (\a -> Right $ a { optCommand = PkgInfo (infoOpts a)
                                               { infoAll = True } })
          (  short "a"
          <> long "all"
Michael Hanus's avatar
Michael Hanus committed
493
494
495
496
497
498
          <> help "Show all infos" )
    <.> flag (\a -> Right $ a { optCommand = PkgInfo (infoOpts a)
                                               { infoPlain = True } })
          (  short "p"
          <> long "plain"
          <> help "Plain output (no control characters for bold or colors)"
Michael Hanus's avatar
Michael Hanus committed
499
500
          <> optional )

501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
  docArgs =
    option (\s a -> Right $ a { optCommand =
                                  Doc (docOpts a) { docDir = Just $ s } })
          (  long "docdir"
          <> short "d"
          <> help "The documentation directory (default: 'cdoc')"
          <> optional )
    <.>
    option (\s a -> Right $ a { optCommand = Doc (docOpts a)
                                      { docModules = Just $ splitOn "," s } })
          (  long "modules"
          <> short "m"
          <> help ("The modules to be documented, " ++
                   "separate multiple modules by comma")
          <> optional )

Michael Hanus's avatar
Michael Hanus committed
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
  testArgs =
    option (\s a -> Right $ a { optCommand = Test (testOpts a)
                                      { testModules = Just $ splitOn "," s } })
          (  long "modules"
          <> short "m"
          <> help "The modules to be tested, separate multiple modules by comma"
          <> optional )

  diffArgs =
       arg (\s a -> readVersion' s >.> \v ->
                 a { optCommand = Diff (diffOpts a) { diffVersion = Just v } })
           (  metavar "VERSION"
           <> help ("The other package version. If no version is specified, " ++
                    "cpm diffs against the latest repository version.")
           <> optional )
   <.> option (\s a -> Right $ a { optCommand = Diff (diffOpts a)
                                     { diffModules = Just $ splitOn "," s } })
         (  long "modules"
         <> short "m"
         <> help "The modules to compare, separate multiple modules by comma"
         <> optional )
   <.> flag (\a -> Right $ a { optCommand = Diff (diffOpts a)
                          { diffAPI = True, diffBehavior = False } })
         (  long "api-only"
         <> short "a"
         <> help "Diff only the API")
   <.> flag (\a -> Right $ a { optCommand = Diff (diffOpts a)
                          { diffAPI = False, diffBehavior = True } })
         (  long "behavior-only"
         <> short "b"
         <> help "Diff only the behavior")
   <.> flag (\a -> Right $ a { optCommand = Diff (diffOpts a)
                                            { diffUseAna = False } })
         (  long "unsafe"
         <> short "u"
         <> help
         "Do not use automatic termination analysis for safe behavior checking")

  listArgs =
Michael Hanus's avatar
Michael Hanus committed
556
        flag (\a -> Right $ a { optCommand =
Michael Hanus's avatar
Michael Hanus committed
557
558
559
                                  List (listOpts a) { listVers = True } })
          (  short "v"
          <> long "versions"
Michael Hanus's avatar
Michael Hanus committed
560
          <> help "Show all versions" ) 
Michael Hanus's avatar
Michael Hanus committed
561
562
    <.> flag (\a -> Right $ a { optCommand =
                                  List (listOpts a) { listCSV = True } })
Michael Hanus's avatar
Michael Hanus committed
563
564
565
          (  short "t"
          <> long "csv"
          <> help "Show in CSV table format" )
Michael Hanus's avatar
Michael Hanus committed
566
567
    <.> flag (\a -> Right $ a { optCommand =
                                  List (listOpts a) { listCat = True } })
Michael Hanus's avatar
Michael Hanus committed
568
569
570
571
572
          (  short "c"
          <> long "category"
          <> help "Show all categories" )

  searchArgs =
Michael Hanus's avatar
Michael Hanus committed
573
574
575
576
577
578
579
580
581
        flag (\a -> Right $ a { optCommand = Search (searchOpts a)
                                               { searchModule = True } })
             (  short "m"
             <> long "module"
             <> help "Search an exported module" )
    <.> arg (\s a -> Right $ a { optCommand = Search (searchOpts a)
                                                { searchQuery = s } }) 
            (  metavar "QUERY"
            <> help "The search term" )
Michael Hanus's avatar
Michael Hanus committed
582
583
584
585
586
587
588
589
590
591
592
593

  upgradeArgs =
    arg (\s a -> Right $ a { optCommand = Upgrade (upgradeOpts a)
                                            { upgrTarget = Just s } })
        (  metavar "PACKAGE"
        <> help "The package to upgrade" 
        <> optional )

  linkArgs =
    arg (\s a -> Right $ a { optCommand = Link (linkOpts a) { lnkSource = s } })
        (  metavar "SOURCE"
        <> help "The directory to link" )
Michael Hanus's avatar
Michael Hanus committed
594

Michael Hanus's avatar
Michael Hanus committed
595
596
597
598
599
600
601
602
603
604
605
  addArgs =
       flag (\a -> Right $ a { optCommand =
                                 Add (addOpts a) { forceAdd = True } })
            (  short "f"
            <> long "force"
            <> help "Force, i.e., overwrite existing package" )
   <.> arg (\s a -> Right $ a { optCommand =
                                  Add (addOpts a) { addSource = s } })
           (  metavar "SOURCE"
           <> help "The directory to add to the local repository" )

Michael Hanus's avatar
Michael Hanus committed
606
607
-- Check if operating system executables we depend on are present on the
-- current system.
Michael Hanus's avatar
Michael Hanus committed
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
checkExecutables :: IO [String]
checkExecutables = do
  present <- mapIO fileInPath listOfExecutables
  return $ map fst $ filter (not . snd) (zip listOfExecutables present)
 where
  listOfExecutables = 
    [ "curl"  
    , "git"   
    , "unzip" 
    , "cp"
    , "rm"
    , "ln"
    , "readlink" ]

deps :: Config -> Repository -> GlobalCache -> IO (ErrorLogger ())
deps cfg repo gc =
  tryFindLocalPackageSpec "." |>= \specDir ->
  resolveDependencies cfg repo gc specDir |>= \result ->
  putStrLn (showResult result) >> succeedIO ()

info :: InfoOptions -> Config -> Repository -> GlobalCache
     -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
630
info (InfoOptions Nothing Nothing allinfos plain) _ _ gc =
Michael Hanus's avatar
Michael Hanus committed
631
  tryFindLocalPackageSpec "." |>= \specDir ->
Michael Hanus's avatar
Michael Hanus committed
632
633
  loadPackageSpec specDir |>= printInfo allinfos plain gc
info (InfoOptions (Just pkg) Nothing allinfos plain) cfg repo gc =
634
  case findLatestVersion cfg repo pkg False of
Michael Hanus's avatar
Michael Hanus committed
635
636
   Nothing -> failIO $
                "Package '" ++ pkg ++ "' not found in package repository."
Michael Hanus's avatar
Michael Hanus committed
637
638
   Just p  -> printInfo allinfos plain gc p
info (InfoOptions (Just pkg) (Just v) allinfos plain) _ repo gc =
Michael Hanus's avatar
Michael Hanus committed
639
640
641
 case findVersion repo pkg v of
   Nothing -> failIO $ "Package '" ++ pkg ++ "-" ++ (showVersion v) ++
                       "' not found in package repository."
Michael Hanus's avatar
Michael Hanus committed
642
643
644
   Just p  -> printInfo allinfos plain gc p
info (InfoOptions Nothing (Just _) _ _) _ _ _ =
  failIO "Must specify package name"
Michael Hanus's avatar
Michael Hanus committed
645

Michael Hanus's avatar
Michael Hanus committed
646
647
648
649
printInfo :: Bool -> Bool -> GlobalCache -> Package
          -> IO (ErrorLogger ())
printInfo allinfos plain gc pkg =
  putStrLn (renderPackageInfo allinfos plain gc pkg) >> succeedIO ()
Michael Hanus's avatar
Michael Hanus committed
650
651


Michael Hanus's avatar
Michael Hanus committed
652
compiler :: CompilerOptions -> Config -> IO (Repository,GlobalCache)
Michael Hanus's avatar
Michael Hanus committed
653
         -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
654
compiler o cfg getRepoGC =
655
656
657
658
659
  tryFindLocalPackageSpec "." |>= \pkgdir ->
  loadPackageSpec pkgdir |>= \pkg ->
  checkCompiler cfg pkg >>
  loadCurryPathFromCache pkgdir |>=
  maybe (computePackageLoadPath pkgdir pkg) succeedIO |>= \currypath ->
Michael Hanus's avatar
Michael Hanus committed
660
661
  log Info ("Starting '" ++ currybin ++ "' with") |>
  log Info ("CURRYPATH=" ++ currypath) |>
Michael Hanus's avatar
Michael Hanus committed
662
  do setEnviron "CURRYPATH" $ currypath
Michael Hanus's avatar
Michael Hanus committed
663
     ecode <- showExecCmd $ currybin ++ " " ++ comCommand o
Michael Hanus's avatar
Michael Hanus committed
664
665
666
667
     unsetEnviron "CURRYPATH"
     unless (ecode==0) (exitWith ecode)
     succeedIO ()
 where
Michael Hanus's avatar
Michael Hanus committed
668
669
  currybin = curryExec cfg

670
  computePackageLoadPath pkgdir pkg =
Michael Hanus's avatar
Michael Hanus committed
671
    getRepoGC >>= \ (repo,gc) ->
Michael Hanus's avatar
Michael Hanus committed
672
    resolveAndCopyDependenciesForPackage cfg repo gc pkgdir pkg |>= \pkgs ->
Michael Hanus's avatar
Michael Hanus committed
673
    getAbsolutePath pkgdir >>= \abs -> succeedIO () |>
Michael Hanus's avatar
Michael Hanus committed
674
675
    let srcdirs = map (abs </>) (sourceDirsOf pkg)
        currypath = joinSearchPath (srcdirs ++ dependencyPathsSeparate pkgs abs)
Michael Hanus's avatar
Michael Hanus committed
676
677
678
679
680
681
    in saveCurryPathToCache pkgdir currypath >> succeedIO currypath


checkout :: CheckoutOptions -> Config -> Repository -> GlobalCache
         -> IO (ErrorLogger ())
checkout (CheckoutOptions pkg Nothing pre) cfg repo gc =
682
 case findLatestVersion cfg repo pkg pre of
Michael Hanus's avatar
Michael Hanus committed
683
684
685
686
687
688
689
690
691
692
693
  Nothing -> failIO $ "Package '" ++ pkg ++
                      "' not found in package repository."
  Just  p -> acquireAndInstallPackageWithDependencies cfg repo gc p |>
             checkoutPackage cfg repo gc p
checkout (CheckoutOptions pkg (Just ver) _) cfg repo gc =
 case findVersion repo pkg ver of
  Nothing -> failIO $ "Package '" ++ pkg ++ "-" ++ showVersion ver ++
                      "' not found in package repository."
  Just  p -> acquireAndInstallPackageWithDependencies cfg repo gc p |>
             checkoutPackage cfg repo gc p

Michael Hanus's avatar
Michael Hanus committed
694
--- Installs the application (i.e., binary) provided by a package.
695
696
697
698
--- This is done by checking out the package into CPM's bin_packages
--- cache (default: $HOME/.cpm/bin_packages, see bin_package_path
--- in .cpmrc configuration file) and then install this package.
---
Michael Hanus's avatar
Michael Hanus committed
699
--- Internal note: the installed package should not be cleaned or removed
700
701
--- after the installation since its execution might refer (via the
--- config module) to some data stored in the package.
Michael Hanus's avatar
Michael Hanus committed
702
installapp :: CheckoutOptions -> Config -> Repository -> GlobalCache
Michael Hanus's avatar
Michael Hanus committed
703
           -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
704
installapp opts cfg repo gc = do
Michael Hanus's avatar
Michael Hanus committed
705
  removeDirectoryComplete copkgdir
Michael Hanus's avatar
Michael Hanus committed
706
707
  debugMessage ("Change into directory " ++ apppkgdir)
  inDirectory apppkgdir
Michael Hanus's avatar
Michael Hanus committed
708
709
710
    (checkout opts cfg repo gc |>
     log Debug ("Change into directory " ++ copkgdir) |>
     (setCurrentDirectory copkgdir >> succeedIO ()) |>
711
     install (InstallOptions Nothing Nothing False True) cfg repo gc )
Michael Hanus's avatar
Michael Hanus committed
712
 where
Michael Hanus's avatar
Michael Hanus committed
713
714
  apppkgdir = appPackageDir cfg
  copkgdir  = apppkgdir </> coPackage opts
Michael Hanus's avatar
Michael Hanus committed
715
716
717

install :: InstallOptions -> Config -> Repository -> GlobalCache
        -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
718
install (InstallOptions Nothing Nothing _ instexec) cfg repo gc =
719
720
721
  tryFindLocalPackageSpec "." |>= \pkgdir ->
  cleanCurryPathCache pkgdir |>
  installLocalDependencies cfg repo gc pkgdir |>= \ (pkg,_) ->
722
  writePackageConfig cfg pkgdir pkg |>
Michael Hanus's avatar
Michael Hanus committed
723
  if instexec then installExecutable cfg repo pkg else succeedIO ()
Michael Hanus's avatar
Michael Hanus committed
724
install (InstallOptions (Just pkg) Nothing pre _) cfg repo gc = do
Michael Hanus's avatar
Michael Hanus committed
725
726
727
  fileExists <- doesFileExist pkg
  if fileExists
    then installFromZip cfg pkg
728
    else case findLatestVersion cfg repo pkg pre of
Michael Hanus's avatar
Michael Hanus committed
729
730
731
      Nothing -> failIO $ "Package '" ++ pkg ++
                          "' not found in package repository."
      Just  p -> acquireAndInstallPackageWithDependencies cfg repo gc p
Michael Hanus's avatar
Michael Hanus committed
732
install (InstallOptions (Just pkg) (Just ver) _ _) cfg repo gc =
Michael Hanus's avatar
Michael Hanus committed
733
734
735
736
 case findVersion repo pkg ver of
  Nothing -> failIO $ "Package '" ++ pkg ++ "-" ++ (showVersion ver) ++
                      "' not found in package repository."
  Just  p -> acquireAndInstallPackageWithDependencies cfg repo gc p
Michael Hanus's avatar
Michael Hanus committed
737
install (InstallOptions Nothing (Just _) _ _) _ _ _ =
Michael Hanus's avatar
Michael Hanus committed
738
739
  failIO "Must specify package name"

740
741
742
743
744
745
--- Checks the compiler compatibility.
checkCompiler :: Config -> Package -> IO ()
checkCompiler cfg pkg =
  unless (isCompatibleToCompiler cfg pkg)
    (error $ "Incompatible compiler: " ++ showCompilerVersion cfg)

Michael Hanus's avatar
Michael Hanus committed
746
747
--- Installs the executable specified in the package in the
--- bin directory of CPM (compare .cpmrc).
Michael Hanus's avatar
Michael Hanus committed
748
749
installExecutable :: Config -> Repository -> Package -> IO (ErrorLogger ())
installExecutable cfg repo pkg =
750
  checkCompiler cfg pkg >>
Michael Hanus's avatar
Michael Hanus committed
751
752
  -- we read the global cache again since it might be modified by
  -- the installation of the package:
Michael Hanus's avatar
Michael Hanus committed
753
  getGlobalCache cfg repo >>= \gc ->
Michael Hanus's avatar
Michael Hanus committed
754
  maybe (succeedIO ())
Michael Hanus's avatar
Michael Hanus committed
755
        (\ (PackageExecutable name mainmod eopts) ->
Michael Hanus's avatar
Michael Hanus committed
756
757
758
           getLogLevel >>= \lvl ->
           getEnviron "PATH" >>= \path ->
           log Info ("Compiling main module: " ++ mainmod) |>
Michael Hanus's avatar
Michael Hanus committed
759
760
761
762
763
           let (cmpname,_,_) = compilerVersion cfg
               cmd = unwords $
                       [":set", if levelGte Debug lvl then "v1" else "v0"
                       , maybe "" id (lookup cmpname eopts)
                       , ":load", mainmod, ":save", ":quit"]
Michael Hanus's avatar
Michael Hanus committed
764
765
               bindir     = binInstallDir cfg
               binexec    = bindir </> name
766
           in compiler CompilerOptions { comCommand = cmd }
Michael Hanus's avatar
Michael Hanus committed
767
                       cfg (return (repo,gc)) |>
Michael Hanus's avatar
Michael Hanus committed
768
769
770
              log Info ("Installing executable '" ++ name ++ "' into '" ++
                        bindir ++ "'") |>
              (whenFileExists binexec (backupExistingBin binexec) >>
Michael Hanus's avatar
Michael Hanus committed
771
               -- renaming might not work across file systems, hence we move:
Michael Hanus's avatar
Michael Hanus committed
772
               showExecCmd (unwords ["mv", mainmod, binexec]) >>
Michael Hanus's avatar
Michael Hanus committed
773
774
775
776
777
               checkPath path bindir))
        (executableSpec pkg)
 where
  backupExistingBin binexec = do
    let binexecbak = binexec ++ ".bak"
Michael Hanus's avatar
Michael Hanus committed
778
    showExecCmd $ "rm -f " ++ binexecbak
Michael Hanus's avatar
Michael Hanus committed
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
    renameFile binexec binexecbak
    infoMessage $ "Existing executable '" ++ binexec ++ "' saved to '" ++
                  binexecbak ++ "'."

  checkPath path bindir =
    if bindir `elem` splitSearchPath path
      then succeedIO ()
      else log Info $ "It is recommended to add '" ++bindir++ "' to your path!"


uninstall :: UninstallOptions -> Config -> Repository -> GlobalCache
          -> IO (ErrorLogger ())
uninstall (UninstallOptions (Just pkg) (Just ver)) cfg repo gc =
  uninstallPackage cfg repo gc pkg ver
uninstall (UninstallOptions (Just _) Nothing) _ _ _ =
  log Error "Please provide a package and version number!"
uninstall (UninstallOptions Nothing (Just _)) _ _ _ =
  log Error "Please provide a package and version number!"
uninstall (UninstallOptions Nothing Nothing) cfg _ _ =
798
799
  tryFindLocalPackageSpec "." |>= \pkgdir ->
  loadPackageSpec pkgdir |>= \pkg ->
Michael Hanus's avatar
Michael Hanus committed
800
  maybe (succeedIO ())
Michael Hanus's avatar
Michael Hanus committed
801
        (\ (PackageExecutable name _ _) ->
Michael Hanus's avatar
Michael Hanus committed
802
803
804
805
806
807
808
809
810
811
812
813
814
           let binexec = binInstallDir cfg </> name
           in ifFileExists binexec
                (removeFile binexec >>
                 log Info ("Executable '" ++ binexec ++ "' removed"))
                (log Info $ "Executable '" ++ binexec ++ "' not installed"))
        (executableSpec pkg)

tryFindVersion :: String -> Version -> Repository -> IO (ErrorLogger Package)
tryFindVersion pkg ver repo = case findVersion repo pkg ver of
  Nothing -> failIO $ "Package '" ++ pkg ++ "-" ++ (showVersion ver) ++
                      "' not found in package repository."
  Just  p -> succeedIO $ p

Michael Hanus's avatar
Michael Hanus committed
815
816
--- Lists all (compiler-compatible if `lall` is false) packages
--- in the given repository.
Michael Hanus's avatar
Michael Hanus committed
817
listCmd :: ListOptions -> Config -> Repository -> IO (ErrorLogger ())
818
listCmd (ListOptions lv csv cat) cfg repo =
Michael Hanus's avatar
Michael Hanus committed
819
  let listresult = if cat then renderCats catgroups
820
                          else renderPkgs allpkgs
Michael Hanus's avatar
Michael Hanus committed
821
  in putStr listresult >> succeedIO ()
Michael Hanus's avatar
Michael Hanus committed
822
 where
Michael Hanus's avatar
Michael Hanus committed
823
824
825
826
827
828
  -- filter all packages compatible to the current compiler but leave at least
  -- one package
  filterCompatPkgs pkgs =
    let comppkgs = filter (isCompatibleToCompiler cfg) pkgs
    in if null comppkgs then take 1 pkgs else comppkgs

829
  -- all packages (and versions if `lv`)
Michael Hanus's avatar
Michael Hanus committed
830
  allpkgs = concatMap (if lv then id else ((:[]) . head . filterCompatPkgs))
Michael Hanus's avatar
Michael Hanus committed
831
                      (sortBy (\ps1 ps2 -> name (head ps1) <= name (head ps2))
Michael Hanus's avatar
Michael Hanus committed
832
                              (listPackages repo))
Michael Hanus's avatar
Michael Hanus committed
833

834
835
  -- all categories together with their package names:
  catgroups =
Michael Hanus's avatar
Michael Hanus committed
836
837
    let pkgid p = name p ++ '-' : showVersionIfCompatible cfg p
        newpkgs = map (head . filterCompatPkgs) (listPackages repo)
Michael Hanus's avatar
Michael Hanus committed
838
839
840
        catpkgs = concatMap (\p -> map (\c -> (c, pkgid p)) (category p))
                            newpkgs
        nocatps = map pkgid (filter (null . category) newpkgs)
841
842
843
844
845
846
    in map (\cg -> (fst (head cg), map snd cg))
           (groupBy (\ (c1,_) (c2,_) -> c1==c2) (nub $ sortBy (<=) catpkgs)) ++
       if null nocatps then []
                       else [("???", nub $ sortBy (<=) nocatps)]

  renderPkgs pkgs =
Michael Hanus's avatar
Michael Hanus committed
847
    let (colsizes,rows) = packageVersionAsTable cfg pkgs
Michael Hanus's avatar
Michael Hanus committed
848
    in renderTable colsizes rows
849
850

  renderCats catgrps =
Michael Hanus's avatar
Michael Hanus committed
851
    let namelen = foldl max 8 $ map (length . fst) catgrps
852
853
        header = [ ["Category", "Packages"]
                 , ["--------", "--------"]]
Michael Hanus's avatar
Michael Hanus committed
854
        rows   = header ++ map (\ (c,ns) -> [c, unwords ns]) catgrps
Michael Hanus's avatar
Michael Hanus committed
855
    in renderTable [namelen + 2, 78 - namelen] rows
856
  
Michael Hanus's avatar
Michael Hanus committed
857
858
859
860
861
862
  renderTable colsizes rows =
    if csv then showCSV (head rows : drop 2 rows)
           else unlines [render (table rows colsizes), cpmInfo, cpmUpdate]

-- Format a list of packages by showing their names, synopsis, and versions
-- as table rows. Returns also the column sizes.
Michael Hanus's avatar
Michael Hanus committed
863
864
packageVersionAsTable :: Config -> [Package] -> ([Int],[[String]])
packageVersionAsTable cfg pkgs = (colsizes, rows)
Michael Hanus's avatar
Michael Hanus committed
865
 where
Michael Hanus's avatar
Michael Hanus committed
866
  namelen = foldl max 4 $ map (length . name) pkgs
Michael Hanus's avatar
Michael Hanus committed
867
  colsizes = [namelen + 2, 68 - namelen, 10]
Michael Hanus's avatar
Michael Hanus committed
868
869
870
  header  = [ ["Name", "Synopsis", "Version"]
            , ["----", "--------", "-------"]]
  rows    = header ++ map formatPkg pkgs
Michael Hanus's avatar
Michael Hanus committed
871
872
873
  formatPkg p = [name p, synopsis p, showVersionIfCompatible cfg p]

--- Shows the version of a package if it is compatible with the
Michael Hanus's avatar
Michael Hanus committed
874
--- current compiler, otherwise shows the version in brackets.
Michael Hanus's avatar
Michael Hanus committed
875
876
showVersionIfCompatible :: Config -> Package -> String
showVersionIfCompatible cfg p =
Michael Hanus's avatar
Michael Hanus committed
877
878
  let s = showVersion (version p)
  in if isCompatibleToCompiler cfg p then s else '(' : s ++ ")"
Michael Hanus's avatar
Michael Hanus committed
879

Michael Hanus's avatar
Michael Hanus committed
880
881
cpmInfo :: String
cpmInfo = "Use 'cpm info PACKAGE' for more information about a package."
Michael Hanus's avatar
Michael Hanus committed
882

Michael Hanus's avatar
Michael Hanus committed
883
884
cpmUpdate :: String
cpmUpdate = "Use 'cpm update' to download the newest package index."
Michael Hanus's avatar
Michael Hanus committed
885
886


Michael Hanus's avatar
Michael Hanus committed
887
--- Search in all (compiler-compatible) packages in the given repository.
Michael Hanus's avatar
Michael Hanus committed
888
search :: SearchOptions -> Config -> Repository -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
889
search (SearchOptions q smod) cfg repo = putStr rendered >> succeedIO ()
Michael Hanus's avatar
Michael Hanus committed
890
 where
Michael Hanus's avatar
Michael Hanus committed
891
892
  results = sortBy (\p1 p2 -> name p1 <= name p2) (searchPackages repo smod q)
  (colsizes,rows) = packageVersionAsTable cfg results
Michael Hanus's avatar
Michael Hanus committed
893
894
  rendered = unlines $
               if null results
Michael Hanus's avatar
Michael Hanus committed
895
                 then ["No packages found for '" ++ q, "'", cpmUpdate]
Michael Hanus's avatar
Michael Hanus committed
896
                 else [ render (table rows colsizes), cpmInfo, cpmUpdate ]
Michael Hanus's avatar
Michael Hanus committed
897
898
899

upgrade :: UpgradeOptions -> Config -> Repository -> GlobalCache
        -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
900
901
902
903
upgrade (UpgradeOptions Nothing) cfg repo gc =
  tryFindLocalPackageSpec "." |>= \specDir ->
  cleanCurryPathCache specDir |>
  log Info "Upgrading all packages" |>
Michael Hanus's avatar
Michael Hanus committed
904
905
  upgradeAllPackages cfg repo gc specDir
upgrade (UpgradeOptions (Just pkg)) cfg repo gc =
Michael Hanus's avatar
Michael Hanus committed
906
907
  tryFindLocalPackageSpec "." |>= \specDir ->
  log Info ("Upgrade " ++ pkg) |>
Michael Hanus's avatar
Michael Hanus committed
908
909
910
  upgradeSinglePackage cfg repo gc specDir pkg


Michael Hanus's avatar
Michael Hanus committed
911
912
linkCmd :: LinkOptions -> Config -> IO (ErrorLogger ())
linkCmd (LinkOptions src) _ =
Michael Hanus's avatar
Michael Hanus committed
913
914
915
  tryFindLocalPackageSpec "." |>= \specDir ->
  cleanCurryPathCache specDir |>
  log Info ("Linking '" ++ src ++ "' into local package cache") |>
Michael Hanus's avatar
Michael Hanus committed
916
917
  linkToLocalCache src specDir

Michael Hanus's avatar
Michael Hanus committed
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
--- `add` command: copy the given package to the repository index
--- and package installation directory so that it is available as
--- any other package.
addCmd :: AddOptions -> Config -> IO (ErrorLogger ())
addCmd (AddOptions pkgdir force) config = do
  dirExists <- doesDirectoryExist pkgdir
  if dirExists
    then loadPackageSpec pkgdir |>= \pkgSpec ->
         (copyPackage pkgSpec >> succeedIO ()) |>
         log Info ("Package in directory '" ++ pkgdir ++
                   "' installed into local repository")
    else log Critical ("Directory '" ++ pkgdir ++ "' does not exist.") |>
         succeedIO ()
 where
  copyPackage pkg = do
    let pkgName          = name pkg
        pkgVersion       = version pkg
        pkgIndexDir      = pkgName </> showVersion pkgVersion
        pkgRepositoryDir = repositoryDir config </> pkgIndexDir
        pkgInstallDir    = packageInstallDir config </> packageId pkg
    exrepodir <- doesDirectoryExist pkgRepositoryDir
    when (exrepodir && not force) $ error $
      "Package repository directory '" ++
      pkgRepositoryDir ++ "' already exists!\n" ++ useForce
    expkgdir <- doesDirectoryExist pkgInstallDir
    when expkgdir $
      if force then removeDirectoryComplete pkgInstallDir
               else error $ "Package installation directory '" ++
                            pkgInstallDir ++ "' already exists!\n" ++ useForce
    infoMessage $ "Create directory: " ++ pkgRepositoryDir
    createDirectoryIfMissing True pkgRepositoryDir
    copyFile (pkgdir </> "package.json") (pkgRepositoryDir </> "package.json")
    copyDirectory pkgdir pkgInstallDir
    updateRepositoryCache config

  useForce = "Use option '-f' or '--force' to overwrite it."

955
956
957
958
--- `doc` command: run `curry doc` on the modules provided as an argument
--- or, if they are not given, on exported modules (if specified in the
--- package), on the main executable (if specified in the package),
--- or on all source modules of the package.
Michael Hanus's avatar
Michael Hanus committed
959
docCmd :: DocOptions -> Config -> IO (Repository,GlobalCache)
960
       -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
961
docCmd opts cfg getRepoGC =
962
963
964
965
966
967
  tryFindLocalPackageSpec "." |>= \specDir ->
  loadPackageSpec specDir |>= \pkg -> do
    checkCompiler cfg pkg
    let docdir  = maybe "cdoc" id (docDir opts)
        exports = exportedModules pkg
        mainmod = maybe Nothing
Michael Hanus's avatar
Michael Hanus committed
968
                        (\ (PackageExecutable _ emain _) -> Just emain)
969
                        (executableSpec pkg)
Michael Hanus's avatar
Michael Hanus committed
970
971
972
973
974
975
976
977
978
    (docmods,apidoc) <-
       maybe (if null exports
                then maybe (curryModulesInDir (specDir </> "src") >>=
                            \ms -> return (ms,True))
                           (\m -> return ([m],False))
                           mainmod
                else return (exports,True))
             (\ms -> return (ms,True))
             (docModules opts)
979
980
981
    if null docmods
      then putStrLn "No modules to be documented!" >> succeedIO ()
      else
Michael Hanus's avatar
Michael Hanus committed
982
983
        if apidoc
          then foldEL (\_ -> docModule specDir docdir) () docmods |>
984
               runDocCmd specDir
Michael Hanus's avatar
Michael Hanus committed
985
986
                         ([currydoc, "--title", apititle pkg, "--onlyindexhtml",
                           docdir] ++ docmods) |>
987
               log Info ("Documentation generated in '"++docdir++"'")
Michael Hanus's avatar
Michael Hanus committed
988
          else runDocCmd specDir [currydoc, docdir, head docmods]
989
 where
Michael Hanus's avatar
Michael Hanus committed
990
991
  apititle pkg = "\"API Documentation of Package '" ++ name pkg ++ "'\""

992
993
994
995
996
997
998
999
  currydoc = curryExec cfg ++ " doc"

  docModule pkgdir docdir mod =
    runDocCmd pkgdir [currydoc, "--noindexhtml", docdir, mod]

  runDocCmd pkgdir doccmd = do
    let cmd = unwords doccmd
    infoMessage $ "Running CurryDoc: " ++ cmd
Michael Hanus's avatar
Michael Hanus committed
1000
    execWithPkgDir (ExecOptions cmd []) cfg getRepoGC pkgdir
For faster browsing, not all history is shown. View entire blame