Skip to content
Merged
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
65 changes: 62 additions & 3 deletions app/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,14 +5,17 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import qualified Control.Foldl as Foldl
import Control.Concurrent.Async (forConcurrently_)
import qualified Data.Aeson as Aeson
import Data.Aeson.Types (fieldLabelModifier)
import Data.Aeson.Encode.Pretty
import Data.Foldable (fold, foldMap, traverse_)
import qualified Data.Bifunctor as Bifunctor
import qualified Data.Graph as G
import Data.List (maximumBy, nub)
import qualified Data.List as List
Expand All @@ -36,7 +39,7 @@ import System.Environment (getArgs)
import qualified System.IO as IO
import qualified System.Process as Process
import qualified Text.ParserCombinators.ReadP as Read
import Turtle hiding (arg, echo, fold, prefix, s, x)
import Turtle hiding (arg, fold, s, x)
import qualified Turtle
import Types (PackageName, mkPackageName, runPackageName, untitledPackageName, preludePackageName)

Expand All @@ -60,6 +63,9 @@ data PackageConfig = PackageConfig
pathToTextUnsafe :: Turtle.FilePath -> Text
pathToTextUnsafe = either (error "Path.toText failed") id . Path.toText

shellToIOText :: Turtle.Shell Line -> IO [Text]
shellToIOText shellLines = Turtle.fold (fmap lineToText shellLines) Foldl.list

readPackageFile :: IO PackageConfig
readPackageFile = do
exists <- testfile packageFile
Expand All @@ -82,6 +88,7 @@ packageConfigToJSON =
, "source"
, "depends"
]
, confIndent = Spaces 2
}

packageSetToJSON :: PackageSet -> Text
Expand All @@ -90,7 +97,7 @@ packageSetToJSON =
. TB.toLazyText
. encodePrettyToTextBuilder' config
where
config = defConfig { confCompare = compare }
config = defConfig { confCompare = compare, confIndent = Spaces 2 }

writePackageFile :: PackageConfig -> IO ()
writePackageFile =
Expand Down Expand Up @@ -203,7 +210,7 @@ installImpl config@PackageConfig{ depends } = do
getPureScriptVersion :: IO Version
getPureScriptVersion = do
let pursProc = inproc "purs" [ "--version" ] empty
outputLines <- Turtle.fold (fmap lineToText pursProc) Foldl.list
outputLines <- shellToIOText pursProc
case outputLines of
[onlyLine]
| results@(_ : _) <- Read.readP_to_S parseVersion (T.unpack onlyLine) ->
Expand Down Expand Up @@ -462,6 +469,55 @@ verify arg = do
let srcGlobs = map (pathToTextUnsafe . (</> ("src" </> "**" </> "*.purs")) . dirFor) dependencies
procs "purs" ("compile" : srcGlobs) empty

data BowerInfoRepo = BowerInfoRepo
{ url :: Text
} deriving (Show, Eq, Generic, Aeson.FromJSON)

data BowerInfo = BowerInfo
{ bower_name :: Text
, bower_repository :: BowerInfoRepo
, bower_dependencies :: Map.Map Text Text
, bower_version :: Text
} deriving (Show, Eq, Generic)
instance Aeson.FromJSON BowerInfo where
parseJSON = Aeson.genericParseJSON Aeson.defaultOptions
{ fieldLabelModifier = drop 6
}

data BowerOutput = BowerOutput
{ latest :: BowerInfo
} deriving (Show, Eq, Generic, Aeson.FromJSON)

addFromBower :: String -> IO ()
addFromBower name = do
let bowerProc = inproc "bower" [ "info", T.pack name, "--json", "-l=error" ] empty
Copy link

@damncabbage damncabbage Dec 22, 2017

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think this is good as a first pass, but that we'd want to either emulate the bits of Bower that we need, or make it more obvious that having bower installed as a dependency is a requirement for this feature.

(My personal preference is doing the emulating; as far as I can tell, that means pulling down the JSON registry blob and then looking through it for the package, but fortunately not much else.)

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't want to reimplement anything from Bower personally. I doubt parsing the registry would be anywhere near as fast as using a user's existing Bower setup and all.

Could be better documented that you need Bower though, yeah.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The registry is super simple - it's just a case of hitting a URL like http://bower.herokuapp.com/packages/purescript-halogen, the registry doesn't actually contain any of the information about the package though, so it means fetching the bower.json from the location the registry returns after that... which is less simple. 😉

I don't love the idea of depending on bower either, but I understand not wanting to reimplement half of it too, so, just thought I'd throw that info in. I did quite a bit of work around this stuff for my bower-replacement-but-still-using-the-registry project that hasn't seen the light of day yet.

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

FWIW, the old registry URL is deprecated, so it would be better to use this format: https://registry.bower.io/packages/purescript-halogen

(see https://twitter.com/bower/status/918073147789889536)

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Uh yes, I actually meant to use that one, must have copied it from some old code and just didn't look at it 😄

result <- fold <$> shellToIOText bowerProc
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Instead of shelling out to bower, you could let the user run the info command and pipe it in here. We already try to use some of the Bower JSON formats in purs publish for example, so I think this approach makes sense here too.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

But in the end the user wants what happens here right? I wouldn't like to have to look up how to awkwardly use this, and at best, many users would be copy pasting an example command to their terminal and changing it.

if T.null result
then exitWithErr "Error: Does the package exist on Bower?"
else do
let result' = do
bowerOutput <- Aeson.eitherDecodeStrict $ encodeUtf8 result
let bowerInfo = latest bowerOutput
pkgName <- mkPackageName' $ bower_name bowerInfo
packageNames <- traverse mkPackageName' $ Map.keys (bower_dependencies bowerInfo)
pure $
( pkgName
, PackageInfo
(url $ bower_repository bowerInfo)
("v" <> bower_version bowerInfo)
packageNames
)
case result' of
Right (pkgName, info) -> do
pkg <- readPackageFile
db <- readPackageSet pkg
writePackageSet pkg $ Map.insert pkgName info db
echoT $ "Successfully wrote " <> runPackageName pkgName <> " to package set."
Left errors -> echoT $ "Errors processing Bower Info: " <> (T.pack errors)
where
stripBowerNamePrefix s = fromMaybe s $ T.stripPrefix "purescript-" s
mkPackageName' = Bifunctor.first show . mkPackageName . stripBowerNamePrefix

main :: IO ()
main = do
IO.hSetEncoding IO.stdout IO.utf8
Expand Down Expand Up @@ -526,6 +582,9 @@ main = do
<|> (VerifyAll <$> optional (fromString <$> after)))
Opts.<**> Opts.helper)
(Opts.progDesc "Verify that the named package builds correctly. If no package is specified, verify that all packages in the package set build correctly."))
, Opts.command "add-from-bower"
(Opts.info (addFromBower <$> pkg Opts.<**> Opts.helper)
(Opts.progDesc "Add a package from the Bower registry to the package set. This requires Bower to be installed on your system."))
]
where
pkg = Opts.strArgument $
Expand Down