@@ -0,0 +1,259 @@
1+{-# LANGUAGE DeriveAnyClass #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE NamedFieldPuns #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RecordWildCards #-}
6+{-# LANGUAGE TupleSections #-}
10+import qualified Data.Aeson as Aeson
11+import Data.Aeson.Encode.Pretty
12+import Data.Foldable (fold, for_, traverse_)
13+import Data.List (nub)
14+import qualified Data.Map as Map
15+import Data.Maybe (mapMaybe)
16+import qualified Data.Set as Set
17+import Data.Text (pack)
18+import qualified Data.Text.Lazy as TL
19+import qualified Data.Text.Lazy.Builder as TB
20+import Data.Text.Encoding (encodeUtf8)
21+import Data.Traversable (for)
22+import Data.Version (showVersion)
23+import qualified Filesystem.Path.CurrentOS as Path
24+import GHC.Generics (Generic)
25+import qualified Options.Applicative as Opts
26+import qualified Paths_purescript as Paths
27+import qualified System.IO as IO
28+import Turtle hiding (fold)
30+packageFile :: Path.FilePath
31+packageFile = "psc-package.json"
33+data PackageConfig = PackageConfig
38+ } deriving (Show, Generic, Aeson.FromJSON, Aeson.ToJSON)
40+pathToTextUnsafe :: Turtle.FilePath -> Text
41+pathToTextUnsafe = either (error "Path.toText failed") id . Path.toText
43+defaultPackage :: Text -> PackageConfig
44+defaultPackage pkgName =
45+ PackageConfig { name = pkgName
46+ , depends = [ "prelude" ]
47+ , set = "psc-" <> pack (showVersion Paths.version)
48+ , source = "https://github.com/purescript/package-sets.git"
51+readPackageFile :: IO PackageConfig
53+ exists <- testfile packageFile
55+ echo "psc-package.json does not exist"
57+ mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile
60+ echo "Unable to parse psc-package.json"
62+ Just pkg -> return pkg
64+encodePrettyToText :: Aeson.ToJSON json => json -> Text
68+ . encodePrettyToTextBuilder' config
79+writePackageFile :: PackageConfig -> IO ()
81+ writeTextFile packageFile
84+data PackageInfo = PackageInfo
87+ , dependencies :: [Text]
88+ } deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON)
90+type PackageSet = Map.Map Text PackageInfo
98+ -- ^ target directory
100+cloneShallow from ref into =
104+ , "-c", "advice.detachedHead=false"
108+ , pathToTextUnsafe into
109+ ] empty .||. exit (ExitFailure 1)
111+getPackageSet :: PackageConfig -> IO ()
112+getPackageSet PackageConfig{ source, set } = do
113+ let pkgDir = ".psc-package" </> fromText set </> ".set"
114+ exists <- testdir pkgDir
115+ unless exists . void $ cloneShallow source set pkgDir
117+readPackageSet :: PackageConfig -> IO PackageSet
118+readPackageSet PackageConfig{ set } = do
119+ let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"
120+ exists <- testfile dbFile
122+ echo "packages.json does not exist"
123+ exit (ExitFailure 1)
124+ mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile
127+ echo "Unable to parse packages.json"
128+ exit (ExitFailure 1)
129+ Just db -> return db
131+installOrUpdate :: PackageConfig -> Text -> PackageInfo -> IO ()
132+installOrUpdate PackageConfig{ set } pkgName PackageInfo{ repo, version } = do
133+ let pkgDir = ".psc-package" </> fromText set </> fromText pkgName </> fromText version
134+ exists <- testdir pkgDir
135+ unless exists . void $ cloneShallow repo version pkgDir
137+getTransitiveDeps :: PackageSet -> [Text] -> IO [(Text, PackageInfo)]
138+getTransitiveDeps db depends = do
139+ pkgs <- for depends $ \pkg ->
140+ case Map.lookup pkg db of
142+ echo ("Package " <> pkg <> " does not exist in package set")
143+ exit (ExitFailure 1)
144+ Just PackageInfo{ dependencies } -> return (pkg : dependencies)
145+ let unique = Set.toList (foldMap Set.fromList pkgs)
146+ return (mapMaybe (\name -> fmap (name, ) (Map.lookup name db)) unique)
148+updateImpl :: PackageConfig -> IO ()
149+updateImpl config@PackageConfig{ depends } = do
150+ getPackageSet config
151+ db <- readPackageSet config
152+ trans <- getTransitiveDeps db depends
153+ echo ("Updating " <> pack (show (length trans)) <> " packages...")
154+ for_ trans $ \(pkgName, pkg) -> do
155+ echo ("Updating " <> pkgName)
156+ installOrUpdate config pkgName pkg
160+ exists <- testfile "psc-package.json"
162+ echo "psc-package.json already exists"
163+ exit (ExitFailure 1)
164+ echo "Initializing new project in current directory"
165+ pkgName <- pathToTextUnsafe . Path.filename <$> pwd
166+ let pkg = defaultPackage pkgName
167+ writePackageFile pkg
172+ pkg <- readPackageFile
174+ echo "Update complete"
176+install :: String -> IO ()
178+ pkg <- readPackageFile
179+ let pkg' = pkg { depends = nub (pack pkgName : depends pkg) }
181+ writePackageFile pkg'
182+ echo "psc-package.json file was updated"
184+listDependencies :: IO ()
185+listDependencies = do
186+ pkg@PackageConfig{ depends } <- readPackageFile
187+ db <- readPackageSet pkg
188+ trans <- getTransitiveDeps db depends
189+ traverse_ (echo . fst) trans
191+getSourcePaths :: PackageConfig -> PackageSet -> [Text] -> IO [Turtle.FilePath]
192+getSourcePaths PackageConfig{..} db pkgNames = do
193+ trans <- getTransitiveDeps db pkgNames
194+ let paths = [ ".psc-package"
196+ </> fromText pkgName
197+ </> fromText version
198+ </> "src" </> "**" </> "*.purs"
199+ | (pkgName, PackageInfo{ version }) <- trans
203+listSourcePaths :: IO ()
205+ pkg@PackageConfig{ depends } <- readPackageFile
206+ db <- readPackageSet pkg
207+ paths <- getSourcePaths pkg db depends
208+ traverse_ (echo . pathToTextUnsafe) paths
210+exec :: Text -> IO ()
212+ pkg@PackageConfig{..} <- readPackageFile
213+ db <- readPackageSet pkg
214+ paths <- getSourcePaths pkg db depends
216+ (map pathToTextUnsafe ("src" </> "**" </> "*.purs" : paths))
221+ IO.hSetEncoding IO.stdout IO.utf8
222+ IO.hSetEncoding IO.stderr IO.utf8
223+ cmd <- Opts.execParser opts
226+ opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList
227+ infoModList = Opts.fullDesc <> headerInfo <> footerInfo
228+ headerInfo = Opts.progDesc "Manage package dependencies"
229+ footerInfo = Opts.footer $ "psc-package " ++ showVersion Paths.version
231+ versionInfo :: Parser (a -> a)
232+ versionInfo = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $
233+ Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden
235+ commands :: Parser (IO ())
236+ commands = (Opts.subparser . fold)
237+ [ Opts.command "init"
238+ (Opts.info (pure initialize)
239+ (Opts.progDesc "Initialize a new package"))
240+ , Opts.command "update"
241+ (Opts.info (pure update)
242+ (Opts.progDesc "Update dependencies"))
243+ , Opts.command "install"
244+ (Opts.info (install <$> pkg)
245+ (Opts.progDesc "Install the named package"))
246+ , Opts.command "build"
247+ (Opts.info (pure (exec "psc"))
248+ (Opts.progDesc "Build the current package and dependencies"))
249+ , Opts.command "dependencies"
250+ (Opts.info (pure listDependencies)
251+ (Opts.progDesc "List all (transitive) dependencies for the current package"))
252+ , Opts.command "sources"
253+ (Opts.info (pure listSourcePaths)
254+ (Opts.progDesc "List all (active) source paths for dependencies"))
257+ pkg = Opts.strArgument $
258+ Opts.metavar "PACKAGE"
259+ <> Opts.help "The name of the package to install"