@@ -0,0 +1,259 @@
1+{-# LANGUAGE DeriveAnyClass #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE NamedFieldPuns #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RecordWildCards #-}
6+{-# LANGUAGE TupleSections #-}
7+
8+module Main where
9+
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)
29+
30+packageFile :: Path.FilePath
31+packageFile = "psc-package.json"
32+
33+data PackageConfig = PackageConfig
34+ { name :: Text
35+ , depends :: [Text]
36+ , set :: Text
37+ , source :: Text
38+ } deriving (Show, Generic, Aeson.FromJSON, Aeson.ToJSON)
39+
40+pathToTextUnsafe :: Turtle.FilePath -> Text
41+pathToTextUnsafe = either (error "Path.toText failed") id . Path.toText
42+
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"
49+ }
50+
51+readPackageFile :: IO PackageConfig
52+readPackageFile = do
53+ exists <- testfile packageFile
54+ unless exists $ do
55+ echo "psc-package.json does not exist"
56+ exit (ExitFailure 1)
57+ mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile
58+ case mpkg of
59+ Nothing -> do
60+ echo "Unable to parse psc-package.json"
61+ exit (ExitFailure 1)
62+ Just pkg -> return pkg
63+
64+encodePrettyToText :: Aeson.ToJSON json => json -> Text
65+encodePrettyToText =
66+ TL.toStrict
67+ . TB.toLazyText
68+ . encodePrettyToTextBuilder' config
69+ where
70+ config = defConfig
71+ { confCompare =
72+ keyOrder [ "name"
73+ , "set"
74+ , "source"
75+ , "depends"
76+ ]
77+ }
78+
79+writePackageFile :: PackageConfig -> IO ()
80+writePackageFile =
81+ writeTextFile packageFile
82+ . encodePrettyToText
83+
84+data PackageInfo = PackageInfo
85+ { repo :: Text
86+ , version :: Text
87+ , dependencies :: [Text]
88+ } deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON)
89+
90+type PackageSet = Map.Map Text PackageInfo
91+
92+cloneShallow
93+ :: Text
94+ -- ^ repo
95+ -> Text
96+ -- ^ branch/tag
97+ -> Turtle.FilePath
98+ -- ^ target directory
99+ -> IO ExitCode
100+cloneShallow from ref into =
101+ proc "git"
102+ [ "clone"
103+ , "-q"
104+ , "-c", "advice.detachedHead=false"
105+ , "--depth", "1"
106+ , "-b", ref
107+ , from
108+ , pathToTextUnsafe into
109+ ] empty .||. exit (ExitFailure 1)
110+
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
116+
117+readPackageSet :: PackageConfig -> IO PackageSet
118+readPackageSet PackageConfig{ set } = do
119+ let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"
120+ exists <- testfile dbFile
121+ unless exists $ do
122+ echo "packages.json does not exist"
123+ exit (ExitFailure 1)
124+ mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile
125+ case mdb of
126+ Nothing -> do
127+ echo "Unable to parse packages.json"
128+ exit (ExitFailure 1)
129+ Just db -> return db
130+
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
136+
137+getTransitiveDeps :: PackageSet -> [Text] -> IO [(Text, PackageInfo)]
138+getTransitiveDeps db depends = do
139+ pkgs <- for depends $ \pkg ->
140+ case Map.lookup pkg db of
141+ Nothing -> do
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)
147+
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
157+
158+initialize :: IO ()
159+initialize = do
160+ exists <- testfile "psc-package.json"
161+ when exists $ do
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
168+ updateImpl pkg
169+
170+update :: IO ()
171+update = do
172+ pkg <- readPackageFile
173+ updateImpl pkg
174+ echo "Update complete"
175+
176+install :: String -> IO ()
177+install pkgName = do
178+ pkg <- readPackageFile
179+ let pkg' = pkg { depends = nub (pack pkgName : depends pkg) }
180+ updateImpl pkg'
181+ writePackageFile pkg'
182+ echo "psc-package.json file was updated"
183+
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
190+
191+getSourcePaths :: PackageConfig -> PackageSet -> [Text] -> IO [Turtle.FilePath]
192+getSourcePaths PackageConfig{..} db pkgNames = do
193+ trans <- getTransitiveDeps db pkgNames
194+ let paths = [ ".psc-package"
195+ </> fromText set
196+ </> fromText pkgName
197+ </> fromText version
198+ </> "src" </> "**" </> "*.purs"
199+ | (pkgName, PackageInfo{ version }) <- trans
200+ ]
201+ return paths
202+
203+listSourcePaths :: IO ()
204+listSourcePaths = do
205+ pkg@PackageConfig{ depends } <- readPackageFile
206+ db <- readPackageSet pkg
207+ paths <- getSourcePaths pkg db depends
208+ traverse_ (echo . pathToTextUnsafe) paths
209+
210+exec :: Text -> IO ()
211+exec exeName = do
212+ pkg@PackageConfig{..} <- readPackageFile
213+ db <- readPackageSet pkg
214+ paths <- getSourcePaths pkg db depends
215+ procs exeName
216+ (map pathToTextUnsafe ("src" </> "**" </> "*.purs" : paths))
217+ empty
218+
219+main :: IO ()
220+main = do
221+ IO.hSetEncoding IO.stdout IO.utf8
222+ IO.hSetEncoding IO.stderr IO.utf8
223+ cmd <- Opts.execParser opts
224+ cmd
225+ where
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
230+
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
234+
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"))
255+ ]
256+ where
257+ pkg = Opts.strArgument $
258+ Opts.metavar "PACKAGE"
259+ <> Opts.help "The name of the package to install"