Main.curry 47.8 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
25

import Boxes (table, render)
import OptParse
import CPM.ErrorLogger
import CPM.FileUtil ( fileInPath, joinSearchPath, safeReadFile, whenFileExists
                    , ifFileExists, inDirectory, removeDirectoryComplete )
26
import CPM.Config   ( Config ( packageInstallDir, binInstallDir
Michael Hanus's avatar
Michael Hanus committed
27
                             , appPackageDir, curryExec )
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
35
36
37
38
39
import CPM.Repository ( Repository, readRepository, findVersion, listPackages
                      , findLatestVersion, updateRepository, searchPackages )
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
40
import CPM.ConfigPackage (packagePath)
Michael Hanus's avatar
Michael Hanus committed
41
42
43
44
45
46

-- Banner of this tool:
cpmBanner :: String
cpmBanner = unlines [bannerLine,bannerText,bannerLine]
 where
 bannerText =
Michael Hanus's avatar
Michael Hanus committed
47
  "Curry Package Manager <curry-language.org/tools/cpm> (version of 04/05/2017)"
Michael Hanus's avatar
Michael Hanus committed
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
 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
  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'
  let getGC   = getGlobalCache config
  let getRepo = getRepository config
  setLogLevel $ optLogLevel opts
  (msgs, result) <- case optCommand opts of
    NoCommand   -> failIO "NoCommand"
    Update      -> updateRepository config
    Compiler o  -> compiler o config getRepo getGC
    Exec o      -> exec     o config getRepo getGC
87
    Doc  o      -> docCmd   o config getRepo getGC
Michael Hanus's avatar
Michael Hanus committed
88
89
    Test o      -> test     o config getRepo getGC
    Clean       -> cleanPackage Info
Michael Hanus's avatar
Michael Hanus committed
90
    New o       -> newPackage o
Michael Hanus's avatar
Michael Hanus committed
91
92
93
94
95
96
97
98
99
    _ -> do repo <- getRepo
            case optCommand opts of
              List   o -> listCmd o config repo
              Search o -> search  o config repo
              _ -> do globalCache <- getGC
                      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
100
                        InstallApp o -> installapp o config repo globalCache
Michael Hanus's avatar
Michael Hanus committed
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
                        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
                        Link o       -> link       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)

getGlobalCache :: Config -> IO GlobalCache
getGlobalCache config = do
  maybeGC <- readInstalledPackagesFromDir $ packageInstallDir config
  case maybeGC of
    Left err -> do putStrLn $ "Error reading global package cache: " ++ err
                   exitWith 1
    Right gc -> return gc

getRepository :: Config -> IO Repository
getRepository config = do
  (repo, repoErrors) <- readRepository config
  if null repoErrors
    then return repo
    else do putStrLn "Problems while reading the package index:"
            mapIO putStrLn repoErrors
            exitWith 1

data Options = Options
  { optLogLevel  :: LogLevel
  , optDefConfig :: [(String,String)]
  , optCommand   :: Command }

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

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
165
166
  , instPrerelease :: Bool
  , instExecutable :: Bool }
Michael Hanus's avatar
Michael Hanus committed
167
168
169
170
171
172
173
174

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
175
176
177
  , infoAll     :: Bool
  , infoPlain   :: Bool  -- plain output, no bold/color
  }
Michael Hanus's avatar
Michael Hanus committed
178
179

data ListOptions = ListOptions
Michael Hanus's avatar
Michael Hanus committed
180
  { listVers :: Bool   -- list all versions of each package
Michael Hanus's avatar
Michael Hanus committed
181
182
  , listCSV  :: Bool   -- list in CSV format
  , listCat  :: Bool   -- list all categories
183
  }
Michael Hanus's avatar
Michael Hanus committed
184
185

data SearchOptions = SearchOptions
Michael Hanus's avatar
Michael Hanus committed
186
187
188
  { searchQuery  :: String
  , searchModule :: Bool
  }
Michael Hanus's avatar
Michael Hanus committed
189
190
191
192
193
194
195

data UpgradeOptions = UpgradeOptions
  { upgrTarget :: Maybe String }

data LinkOptions = LinkOptions
  { lnkSource :: String }

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

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

data CompilerOptions = CompilerOptions
  { comCommand :: String }

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

Michael Hanus's avatar
Michael Hanus committed
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
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
230
  _            -> InstallOptions Nothing Nothing False True
Michael Hanus's avatar
Michael Hanus committed
231
232
233
234
235
236
237
238
239

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
240
  _            -> InfoOptions Nothing Nothing False False
Michael Hanus's avatar
Michael Hanus committed
241
242
243
244

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

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

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
262
263
264
265
266
newOpts :: Options -> NewOptions
newOpts s = case optCommand s of
  New opts -> opts
  _        -> NewOptions ""

Michael Hanus's avatar
Michael Hanus committed
267
268
269
270
271
272
273
274
275
276
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 ""

277
278
279
280
281
docOpts :: Options -> DocOptions
docOpts s = case optCommand s of
  Doc opts -> opts
  _        -> DocOptions Nothing Nothing

Michael Hanus's avatar
Michael Hanus committed
282
283
284
285
286
287
288
289
290
291
292
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
293
294
295
296
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
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339

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
  defaultOpts = Options Info [] NoCommand

(>.>) :: 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'." )
  <.> commands (metavar "COMMAND")
        (   command "checkout" (help "Checkout a package.") Right
Michael Hanus's avatar
Michael Hanus committed
340
341
342
                    (checkoutArgs Checkout)
        <|> command "installapp"
                     (help "Install the application provided by a package.") 
Michael Hanus's avatar
Michael Hanus committed
343
                     Right
Michael Hanus's avatar
Michael Hanus committed
344
                     (checkoutArgs InstallApp)
Michael Hanus's avatar
Michael Hanus committed
345
346
        <|> command "install" (help "Install a package.")
                     (\a -> Right $ a { optCommand = Install (installOpts a) })
Michael Hanus's avatar
Michael Hanus committed
347
                     installArgs
Michael Hanus's avatar
Michael Hanus committed
348
        <|> command "uninstall" (help "Uninstall package")
Michael Hanus's avatar
Michael Hanus committed
349
350
                 (\a -> Right $ a { optCommand = Uninstall (uninstallOpts a) })
                 uninstallArgs
Michael Hanus's avatar
Michael Hanus committed
351
352
353
354
        <|> 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
355
        <|> command "new" (help "Create a new package") Right newArgs
Michael Hanus's avatar
Michael Hanus committed
356
357
        <|> command "update" (help "Update the package index")
                             (\a -> Right $ a { optCommand = Update }) []
Michael Hanus's avatar
Michael Hanus committed
358
359
360
361
362
363
364
365
        <|> 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
366
        <|> command "info" (help "Print package information")
Michael Hanus's avatar
Michael Hanus committed
367
368
                    (\a -> Right $ a { optCommand = PkgInfo (infoOpts a) })
                    infoArgs
369
370
371
372
        <|> 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
373
374
        <|> command "test" (help "Test the current package (with CurryCheck)")
                    (\a -> Right $ a { optCommand = Test (testOpts a) })
Michael Hanus's avatar
Michael Hanus committed
375
                    testArgs
Michael Hanus's avatar
Michael Hanus committed
376
377
378
        <|> command "diff"
                    (help "Diff the current package against another version")
                    (\a -> Right $ a { optCommand = Diff (diffOpts a) })
Michael Hanus's avatar
Michael Hanus committed
379
                    diffArgs
Michael Hanus's avatar
Michael Hanus committed
380
        <|> command "list" (help "List all packages of the repository")
Michael Hanus's avatar
Michael Hanus committed
381
382
                    (\a -> Right $ a { optCommand = List (listOpts a) })
                    listArgs
Michael Hanus's avatar
Michael Hanus committed
383
        <|> command "search" (help "Search the package repository") Right
Michael Hanus's avatar
Michael Hanus committed
384
                    searchArgs
Michael Hanus's avatar
Michael Hanus committed
385
386
        <|> command "upgrade" (help "Upgrade one or more packages")
                    (\a -> Right $ a { optCommand = Upgrade (upgradeOpts a) })
Michael Hanus's avatar
Michael Hanus committed
387
                    upgradeArgs
Michael Hanus's avatar
Michael Hanus committed
388
        <|> command "link" (help "Link a package to the local cache") Right
Michael Hanus's avatar
Michael Hanus committed
389
390
391
392
393
394
395
396
397
398
399
400
401
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
                    linkArgs ) )
 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
481
482
483
484
485
486
          <> 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
487
488
          <> optional )

489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
  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
505
506
507
508
509
510
511
512
513
514
515
516
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
  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
544
        flag (\a -> Right $ a { optCommand =
Michael Hanus's avatar
Michael Hanus committed
545
546
547
                                  List (listOpts a) { listVers = True } })
          (  short "v"
          <> long "versions"
Michael Hanus's avatar
Michael Hanus committed
548
          <> help "Show all versions" ) 
Michael Hanus's avatar
Michael Hanus committed
549
550
    <.> flag (\a -> Right $ a { optCommand =
                                  List (listOpts a) { listCSV = True } })
Michael Hanus's avatar
Michael Hanus committed
551
552
553
          (  short "t"
          <> long "csv"
          <> help "Show in CSV table format" )
Michael Hanus's avatar
Michael Hanus committed
554
555
    <.> flag (\a -> Right $ a { optCommand =
                                  List (listOpts a) { listCat = True } })
Michael Hanus's avatar
Michael Hanus committed
556
557
558
559
560
          (  short "c"
          <> long "category"
          <> help "Show all categories" )

  searchArgs =
Michael Hanus's avatar
Michael Hanus committed
561
562
563
564
565
566
567
568
569
        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
570
571
572
573
574
575
576
577
578
579
580
581

  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
582

Michael Hanus's avatar
Michael Hanus committed
583
584
-- Check if operating system executables we depend on are present on the
-- current system.
Michael Hanus's avatar
Michael Hanus committed
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
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
607
info (InfoOptions Nothing Nothing allinfos plain) _ _ gc =
Michael Hanus's avatar
Michael Hanus committed
608
  tryFindLocalPackageSpec "." |>= \specDir ->
Michael Hanus's avatar
Michael Hanus committed
609
610
  loadPackageSpec specDir |>= printInfo allinfos plain gc
info (InfoOptions (Just pkg) Nothing allinfos plain) cfg repo gc =
611
  case findLatestVersion cfg repo pkg False of
Michael Hanus's avatar
Michael Hanus committed
612
613
   Nothing -> failIO $
                "Package '" ++ pkg ++ "' not found in package repository."
Michael Hanus's avatar
Michael Hanus committed
614
615
   Just p  -> printInfo allinfos plain gc p
info (InfoOptions (Just pkg) (Just v) allinfos plain) _ repo gc =
Michael Hanus's avatar
Michael Hanus committed
616
617
618
 case findVersion repo pkg v of
   Nothing -> failIO $ "Package '" ++ pkg ++ "-" ++ (showVersion v) ++
                       "' not found in package repository."
Michael Hanus's avatar
Michael Hanus committed
619
620
621
   Just p  -> printInfo allinfos plain gc p
info (InfoOptions Nothing (Just _) _ _) _ _ _ =
  failIO "Must specify package name"
Michael Hanus's avatar
Michael Hanus committed
622

Michael Hanus's avatar
Michael Hanus committed
623
624
625
626
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
627
628
629
630
631


compiler :: CompilerOptions -> Config -> IO Repository -> IO GlobalCache
         -> IO (ErrorLogger ())
compiler o cfg getRepo getGC =
632
633
634
635
636
  tryFindLocalPackageSpec "." |>= \pkgdir ->
  loadPackageSpec pkgdir |>= \pkg ->
  checkCompiler cfg pkg >>
  loadCurryPathFromCache pkgdir |>=
  maybe (computePackageLoadPath pkgdir pkg) succeedIO |>= \currypath ->
Michael Hanus's avatar
Michael Hanus committed
637
638
  log Info ("Starting '" ++ currybin ++ "' with") |>
  log Info ("CURRYPATH=" ++ currypath) |>
Michael Hanus's avatar
Michael Hanus committed
639
  do setEnviron "CURRYPATH" $ currypath
Michael Hanus's avatar
Michael Hanus committed
640
     ecode <- showExecCmd $ currybin ++ " " ++ comCommand o
Michael Hanus's avatar
Michael Hanus committed
641
642
643
644
     unsetEnviron "CURRYPATH"
     unless (ecode==0) (exitWith ecode)
     succeedIO ()
 where
Michael Hanus's avatar
Michael Hanus committed
645
646
  currybin = curryExec cfg

647
648
649
  computePackageLoadPath pkgdir pkg =
    getRepo >>= \repo ->
    getGC >>= \gc ->
Michael Hanus's avatar
Michael Hanus committed
650
    resolveAndCopyDependenciesForPackage cfg repo gc pkgdir pkg |>= \pkgs ->
Michael Hanus's avatar
Michael Hanus committed
651
    getAbsolutePath pkgdir >>= \abs -> succeedIO () |>
Michael Hanus's avatar
Michael Hanus committed
652
653
    let srcdirs = map (abs </>) (sourceDirsOf pkg)
        currypath = joinSearchPath (srcdirs ++ dependencyPathsSeparate pkgs abs)
Michael Hanus's avatar
Michael Hanus committed
654
655
656
657
658
659
    in saveCurryPathToCache pkgdir currypath >> succeedIO currypath


checkout :: CheckoutOptions -> Config -> Repository -> GlobalCache
         -> IO (ErrorLogger ())
checkout (CheckoutOptions pkg Nothing pre) cfg repo gc =
660
 case findLatestVersion cfg repo pkg pre of
Michael Hanus's avatar
Michael Hanus committed
661
662
663
664
665
666
667
668
669
670
671
  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
672
--- Installs the application (i.e., binary) provided by a package.
673
674
675
676
--- 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
677
--- Internal note: the installed package should not be cleaned or removed
678
679
--- 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
680
installapp :: CheckoutOptions -> Config -> Repository -> GlobalCache
Michael Hanus's avatar
Michael Hanus committed
681
           -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
682
installapp opts cfg repo gc = do
Michael Hanus's avatar
Michael Hanus committed
683
  removeDirectoryComplete copkgdir
Michael Hanus's avatar
Michael Hanus committed
684
685
  debugMessage ("Change into directory " ++ apppkgdir)
  inDirectory apppkgdir
Michael Hanus's avatar
Michael Hanus committed
686
687
688
    (checkout opts cfg repo gc |>
     log Debug ("Change into directory " ++ copkgdir) |>
     (setCurrentDirectory copkgdir >> succeedIO ()) |>
689
     install (InstallOptions Nothing Nothing False True) cfg repo gc )
Michael Hanus's avatar
Michael Hanus committed
690
 where
Michael Hanus's avatar
Michael Hanus committed
691
692
  apppkgdir = appPackageDir cfg
  copkgdir  = apppkgdir </> coPackage opts
Michael Hanus's avatar
Michael Hanus committed
693
694
695

install :: InstallOptions -> Config -> Repository -> GlobalCache
        -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
696
install (InstallOptions Nothing Nothing _ instexec) cfg repo gc =
697
698
699
  tryFindLocalPackageSpec "." |>= \pkgdir ->
  cleanCurryPathCache pkgdir |>
  installLocalDependencies cfg repo gc pkgdir |>= \ (pkg,_) ->
700
  writePackageConfig cfg pkgdir pkg |>
Michael Hanus's avatar
Michael Hanus committed
701
  if instexec then installExecutable cfg repo pkg else succeedIO ()
Michael Hanus's avatar
Michael Hanus committed
702
install (InstallOptions (Just pkg) Nothing pre _) cfg repo gc = do
Michael Hanus's avatar
Michael Hanus committed
703
704
705
  fileExists <- doesFileExist pkg
  if fileExists
    then installFromZip cfg pkg
706
    else case findLatestVersion cfg repo pkg pre of
Michael Hanus's avatar
Michael Hanus committed
707
708
709
      Nothing -> failIO $ "Package '" ++ pkg ++
                          "' not found in package repository."
      Just  p -> acquireAndInstallPackageWithDependencies cfg repo gc p
Michael Hanus's avatar
Michael Hanus committed
710
install (InstallOptions (Just pkg) (Just ver) _ _) cfg repo gc =
Michael Hanus's avatar
Michael Hanus committed
711
712
713
714
 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
715
install (InstallOptions Nothing (Just _) _ _) _ _ _ =
Michael Hanus's avatar
Michael Hanus committed
716
717
  failIO "Must specify package name"

718
719
720
721
722
723
--- 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
724
725
--- Installs the executable specified in the package in the
--- bin directory of CPM (compare .cpmrc).
Michael Hanus's avatar
Michael Hanus committed
726
727
installExecutable :: Config -> Repository -> Package -> IO (ErrorLogger ())
installExecutable cfg repo pkg =
728
  checkCompiler cfg pkg >>
Michael Hanus's avatar
Michael Hanus committed
729
730
731
732
733
734
735
736
737
  -- we read the global cache again since it might be modified by
  -- the installation of the package:
  getGlobalCache cfg >>= \gc ->
  maybe (succeedIO ())
        (\ (PackageExecutable name mainmod) ->
           getLogLevel >>= \lvl ->
           getEnviron "PATH" >>= \path ->
           log Info ("Compiling main module: " ++ mainmod) |>
           let cmd = unwords $
Michael Hanus's avatar
Michael Hanus committed
738
739
                       [":set", if levelGte Debug lvl then "v1" else "v0",
                        ":load", mainmod, ":save", ":quit"]
Michael Hanus's avatar
Michael Hanus committed
740
741
               bindir     = binInstallDir cfg
               binexec    = bindir </> name
742
           in compiler CompilerOptions { comCommand = cmd }
Michael Hanus's avatar
Michael Hanus committed
743
744
745
746
                       cfg (return repo) (return gc) |>
              log Info ("Installing executable '" ++ name ++ "' into '" ++
                        bindir ++ "'") |>
              (whenFileExists binexec (backupExistingBin binexec) >>
Michael Hanus's avatar
Michael Hanus committed
747
               -- renaming might not work across file systems, hence we move:
Michael Hanus's avatar
Michael Hanus committed
748
               showExecCmd (unwords ["mv", mainmod, binexec]) >>
Michael Hanus's avatar
Michael Hanus committed
749
750
751
752
753
               checkPath path bindir))
        (executableSpec pkg)
 where
  backupExistingBin binexec = do
    let binexecbak = binexec ++ ".bak"
Michael Hanus's avatar
Michael Hanus committed
754
    showExecCmd $ "rm -f " ++ binexecbak
Michael Hanus's avatar
Michael Hanus committed
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
    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 _ _ =
774
775
  tryFindLocalPackageSpec "." |>= \pkgdir ->
  loadPackageSpec pkgdir |>= \pkg ->
Michael Hanus's avatar
Michael Hanus committed
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
  maybe (succeedIO ())
        (\ (PackageExecutable name _) ->
           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
791
792
--- Lists all (compiler-compatible if `lall` is false) packages
--- in the given repository.
Michael Hanus's avatar
Michael Hanus committed
793
listCmd :: ListOptions -> Config -> Repository -> IO (ErrorLogger ())
794
listCmd (ListOptions lv csv cat) cfg repo =
Michael Hanus's avatar
Michael Hanus committed
795
  let listresult = if cat then renderCats catgroups
796
                          else renderPkgs allpkgs
Michael Hanus's avatar
Michael Hanus committed
797
  in putStr listresult >> succeedIO ()
Michael Hanus's avatar
Michael Hanus committed
798
 where
Michael Hanus's avatar
Michael Hanus committed
799
800
801
802
803
804
  -- 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

805
  -- all packages (and versions if `lv`)
Michael Hanus's avatar
Michael Hanus committed
806
  allpkgs = concatMap (if lv then id else ((:[]) . head . filterCompatPkgs))
Michael Hanus's avatar
Michael Hanus committed
807
                      (sortBy (\ps1 ps2 -> name (head ps1) <= name (head ps2))
Michael Hanus's avatar
Michael Hanus committed
808
                              (listPackages repo))
Michael Hanus's avatar
Michael Hanus committed
809

810
811
  -- all categories together with their package names:
  catgroups =
Michael Hanus's avatar
Michael Hanus committed
812
813
    let pkgid p = name p ++ '-' : showVersionIfCompatible cfg p
        newpkgs = map (head . filterCompatPkgs) (listPackages repo)
Michael Hanus's avatar
Michael Hanus committed
814
815
816
        catpkgs = concatMap (\p -> map (\c -> (c, pkgid p)) (category p))
                            newpkgs
        nocatps = map pkgid (filter (null . category) newpkgs)
817
818
819
820
821
822
    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
823
    let (colsizes,rows) = packageVersionAsTable cfg pkgs
Michael Hanus's avatar
Michael Hanus committed
824
    in renderTable colsizes rows
825
826

  renderCats catgrps =
Michael Hanus's avatar
Michael Hanus committed
827
    let namelen = foldl max 8 $ map (length . fst) catgrps
828
829
        header = [ ["Category", "Packages"]
                 , ["--------", "--------"]]
Michael Hanus's avatar
Michael Hanus committed
830
        rows   = header ++ map (\ (c,ns) -> [c, unwords ns]) catgrps
Michael Hanus's avatar
Michael Hanus committed
831
    in renderTable [namelen + 2, 78 - namelen] rows
832
  
Michael Hanus's avatar
Michael Hanus committed
833
834
835
836
837
838
  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
839
840
packageVersionAsTable :: Config -> [Package] -> ([Int],[[String]])
packageVersionAsTable cfg pkgs = (colsizes, rows)
Michael Hanus's avatar
Michael Hanus committed
841
 where
Michael Hanus's avatar
Michael Hanus committed
842
  namelen = foldl max 4 $ map (length . name) pkgs
Michael Hanus's avatar
Michael Hanus committed
843
  colsizes = [namelen + 2, 68 - namelen, 10]
Michael Hanus's avatar
Michael Hanus committed
844
845
846
  header  = [ ["Name", "Synopsis", "Version"]
            , ["----", "--------", "-------"]]
  rows    = header ++ map formatPkg pkgs
Michael Hanus's avatar
Michael Hanus committed
847
848
849
  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
850
--- current compiler, otherwise shows the version in brackets.
Michael Hanus's avatar
Michael Hanus committed
851
852
showVersionIfCompatible :: Config -> Package -> String
showVersionIfCompatible cfg p =
Michael Hanus's avatar
Michael Hanus committed
853
854
  let s = showVersion (version p)
  in if isCompatibleToCompiler cfg p then s else '(' : s ++ ")"
Michael Hanus's avatar
Michael Hanus committed
855

Michael Hanus's avatar
Michael Hanus committed
856
857
cpmInfo :: String
cpmInfo = "Use 'cpm info PACKAGE' for more information about a package."
Michael Hanus's avatar
Michael Hanus committed
858

Michael Hanus's avatar
Michael Hanus committed
859
860
cpmUpdate :: String
cpmUpdate = "Use 'cpm update' to download the newest package index."
Michael Hanus's avatar
Michael Hanus committed
861
862


Michael Hanus's avatar
Michael Hanus committed
863
--- Search in all (compiler-compatible) packages in the given repository.
Michael Hanus's avatar
Michael Hanus committed
864
search :: SearchOptions -> Config -> Repository -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
865
search (SearchOptions q smod) cfg repo = putStr rendered >> succeedIO ()
Michael Hanus's avatar
Michael Hanus committed
866
 where
Michael Hanus's avatar
Michael Hanus committed
867
868
  results = sortBy (\p1 p2 -> name p1 <= name p2) (searchPackages repo smod q)
  (colsizes,rows) = packageVersionAsTable cfg results
Michael Hanus's avatar
Michael Hanus committed
869
870
  rendered = unlines $
               if null results
Michael Hanus's avatar
Michael Hanus committed
871
                 then ["No packages found for '" ++ q, "'", cpmUpdate]
Michael Hanus's avatar
Michael Hanus committed
872
                 else [ render (table rows colsizes), cpmInfo, cpmUpdate ]
Michael Hanus's avatar
Michael Hanus committed
873
874
875

upgrade :: UpgradeOptions -> Config -> Repository -> GlobalCache
        -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
876
877
878
879
upgrade (UpgradeOptions Nothing) cfg repo gc =
  tryFindLocalPackageSpec "." |>= \specDir ->
  cleanCurryPathCache specDir |>
  log Info "Upgrading all packages" |>
Michael Hanus's avatar
Michael Hanus committed
880
881
  upgradeAllPackages cfg repo gc specDir
upgrade (UpgradeOptions (Just pkg)) cfg repo gc =
Michael Hanus's avatar
Michael Hanus committed
882
883
  tryFindLocalPackageSpec "." |>= \specDir ->
  log Info ("Upgrade " ++ pkg) |>
Michael Hanus's avatar
Michael Hanus committed
884
885
886
887
888
  upgradeSinglePackage cfg repo gc specDir pkg


link :: LinkOptions -> Config -> Repository -> GlobalCache
     -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
889
890
891
892
link (LinkOptions src) _ _ _ =
  tryFindLocalPackageSpec "." |>= \specDir ->
  cleanCurryPathCache specDir |>
  log Info ("Linking '" ++ src ++ "' into local package cache") |>
Michael Hanus's avatar
Michael Hanus committed
893
894
  linkToLocalCache src specDir

895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
--- `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.
docCmd :: DocOptions -> Config -> IO Repository -> IO GlobalCache
       -> IO (ErrorLogger ())
docCmd opts cfg getRepo getGC =
  tryFindLocalPackageSpec "." |>= \specDir ->
  loadPackageSpec specDir |>= \pkg -> do
    checkCompiler cfg pkg
    let docdir  = maybe "cdoc" id (docDir opts)
        exports = exportedModules pkg
        mainmod = maybe Nothing
                        (\ (PackageExecutable _ emain) -> Just emain)
                        (executableSpec pkg)
Michael Hanus's avatar
Michael Hanus committed
910
911
912
913
914
915
916
917
918
    (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)
919
920
921
    if null docmods
      then putStrLn "No modules to be documented!" >> succeedIO ()
      else
Michael Hanus's avatar
Michael Hanus committed
922
923
        if apidoc
          then foldEL (\_ -> docModule specDir docdir) () docmods |>
924
               runDocCmd specDir
Michael Hanus's avatar
Michael Hanus committed
925
926
                         ([currydoc, "--title", apititle pkg, "--onlyindexhtml",
                           docdir] ++ docmods) |>
927
               log Info ("Documentation generated in '"++docdir++"'")
Michael Hanus's avatar
Michael Hanus committed
928
          else runDocCmd specDir [currydoc, docdir, head docmods]
929
 where
Michael Hanus's avatar
Michael Hanus committed
930
931
  apititle pkg = "\"API Documentation of Package '" ++ name pkg ++ "'\""

932
933
934
935
936
937
938
939
940
941
942
943
944
  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
    execWithPkgDir (ExecOptions cmd []) cfg getRepo getGC pkgdir

--- `test` command: run `curry check` on the modules provided as an argument
--- or, if they are not provided, on the exported (if specified)
--- or all source modules of the package.
Michael Hanus's avatar
Michael Hanus committed
945
946
947
948
test :: TestOptions -> Config -> IO Repository -> IO GlobalCache
     -> IO (ErrorLogger ())
test opts cfg getRepo getGC =
  tryFindLocalPackageSpec "." |>= \specDir ->
949
950
  loadPackageSpec specDir |>= \pkg -> do
    checkCompiler cfg pkg
Michael Hanus's avatar
Michael Hanus committed
951
952
    aspecDir <- getAbsolutePath specDir
    mainprogs <- curryModulesInDir (aspecDir </> "src")
953
    let tests = testsuites pkg mainprogs
Michael Hanus's avatar
Michael Hanus committed
954
955
956
957
    if null tests
      then putStrLn "No modules to be tested!" >> succeedIO ()
      else foldEL (\_ -> execTest aspecDir) () tests
 where
Michael Hanus's avatar
Michael Hanus committed
958
959
  currycheck = curryExec cfg ++ " check"
  
Michael Hanus's avatar
Michael Hanus committed
960
  execTest apkgdir (PackageTest dir mods ccopts script) = do
961
962
    let scriptcmd = "CURRYBIN=" ++ curryExec cfg ++ " && export CURRYBIN && " ++
                    "." </> script ++ if null ccopts then "" else ' ' : ccopts
Michael Hanus's avatar
Michael Hanus committed
963
964
965
966
967
968
        checkcmd  = currycheck ++ if null ccopts then "" else ' ' : ccopts
    unless (null mods) $ putStrLn $
      "Running CurryCheck (" ++ checkcmd ++ ")\n" ++
      "(in directory '" ++ dir ++ "', showing raw output) on modules:\n" ++
      unwords mods ++ "\n"
    unless (null script) $ putStrLn $
969
      "Executing test script with command:\n" ++ scriptcmd ++ "\n" ++
Michael Hanus's avatar
Michael Hanus committed
970
      "(in directory '" ++ dir ++ "', showing raw output):\n"
Michael Hanus's avatar
Michael Hanus committed
971
    let currysubdir = apkgdir </> addCurrySubdir dir
Michael Hanus's avatar
Michael Hanus committed
972
973
974
        testcmd = if not (null mods)
                    then unwords (checkcmd : mods)
                    else scriptcmd
Michael Hanus's avatar
Michael Hanus committed
975
    debugMessage $ "Removing directory: " ++ currysubdir
Michael Hanus's avatar
Michael Hanus committed
976
    showExecCmd (unwords ["rm", "-rf", currysubdir])
Michael Hanus's avatar
Michael Hanus committed
977
    inDirectory (apkgdir </> dir) $
Michael Hanus's avatar
Michael Hanus committed
978
      execWithPkgDir (ExecOptions testcmd []) cfg getRepo getGC apkgdir
Michael Hanus's avatar
Michael Hanus committed
979
980
981
982
983
984

  testsuites spec mainprogs = case testModules opts of
    Nothing -> maybe (let exports = exportedModules spec
                      in if null exports
                           then if null mainprogs
                                  then []
Michael Hanus's avatar
Michael Hanus committed
985
986
                                  else [PackageTest "src" mainprogs "" ""]
                           else [PackageTest "src" exports "" ""])
Michael Hanus's avatar
Michael Hanus committed
987
                     id
Michael Hanus's avatar
Michael Hanus committed
988
                     (testSuite spec)
Michael Hanus's avatar
Michael Hanus committed
989
    Just ms -> [PackageTest "src" ms "" ""]
Michael Hanus's avatar
Michael Hanus committed
990

991
--- Get the names of all Curry modules contained in a directory.
Michael Hanus's avatar
Michael Hanus committed
992
993
994
995
996
997
998
999
1000
--- Modules in subdirectories are returned as hierarchical modules.
curryModulesInDir :: String -> IO [String]
curryModulesInDir dir = getModules "" dir
 where
  getModules p d = do
    entries <- getDirectoryContents d
    let realentries = filter (\f -> length f >= 1 && head f /= '.') entries
        newprogs    = filter (\f -> takeExtension f == ".curry") realentries
    subdirs <- mapIO (\e -> doesDirectoryExist (d </> e) >>=
For faster browsing, not all history is shown. View entire blame