From f59ea9a578f4c01fd561c590bdb313041cb400c8 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 27 May 2017 21:04:27 +0100 Subject: [PATCH] Add a newtype for package names (#29) Part of #21; this does not fully fix #21 as it only addresses package names. --- app/Main.hs | 63 ++++++++++++++++++++++------------- app/Types.hs | 85 +++++++++++++++++++++++++++++++++++++++++++++++ psc-package.cabal | 1 + 3 files changed, 126 insertions(+), 23 deletions(-) create mode 100644 app/Types.hs diff --git a/app/Main.hs b/app/Main.hs index 364cda1..28438f4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -35,6 +35,7 @@ import qualified System.Process as Process import qualified Text.ParserCombinators.ReadP as Read import Turtle hiding (echo, fold, s, x) import qualified Turtle +import Types (PackageName, mkPackageName, runPackageName, untitledPackageName, preludePackageName) echoT :: Text -> IO () echoT = Turtle.printf (Turtle.s % "\n") @@ -43,8 +44,8 @@ packageFile :: Path.FilePath packageFile = "psc-package.json" data PackageConfig = PackageConfig - { name :: Text - , depends :: [Text] + { name :: PackageName + , depends :: [PackageName] , set :: Text , source :: Text } deriving (Show, Generic, Aeson.FromJSON, Aeson.ToJSON) @@ -52,10 +53,10 @@ data PackageConfig = PackageConfig pathToTextUnsafe :: Turtle.FilePath -> Text pathToTextUnsafe = either (error "Path.toText failed") id . Path.toText -defaultPackage :: Version -> Text -> PackageConfig +defaultPackage :: Version -> PackageName -> PackageConfig defaultPackage pursVersion pkgName = PackageConfig { name = pkgName - , depends = [ "prelude" ] + , depends = [ preludePackageName ] , set = "psc-" <> pack (showVersion pursVersion) , source = "https://github.com/purescript/package-sets.git" } @@ -104,10 +105,10 @@ writePackageFile = data PackageInfo = PackageInfo { repo :: Text , version :: Text - , dependencies :: [Text] + , dependencies :: [PackageName] } deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON) -type PackageSet = Map.Map Text PackageInfo +type PackageSet = Map.Map PackageName PackageInfo cloneShallow :: Text @@ -165,20 +166,20 @@ writePackageSet PackageConfig{ set } = let dbFile = ".psc-package" fromText set ".set" "packages.json" in writeTextFile dbFile . packageSetToJSON -installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath +installOrUpdate :: Text -> PackageName -> PackageInfo -> IO Turtle.FilePath installOrUpdate set pkgName PackageInfo{ repo, version } = do - echoT ("Updating " <> pkgName) - let pkgDir = ".psc-package" fromText set fromText pkgName fromText version + echoT ("Updating " <> runPackageName pkgName) + let pkgDir = ".psc-package" fromText set fromText (runPackageName pkgName) fromText version exists <- testdir pkgDir unless exists . void $ cloneShallow repo version pkgDir pure pkgDir -getTransitiveDeps :: PackageSet -> [Text] -> IO [(Text, PackageInfo)] +getTransitiveDeps :: PackageSet -> [PackageName] -> IO [(PackageName, PackageInfo)] getTransitiveDeps db depends = do pkgs <- for depends $ \pkg -> case Map.lookup pkg db of Nothing -> do - echoT ("Package " <> pkg <> " does not exist in package set") + echoT ("Package " <> runPackageName pkg <> " does not exist in package set") exit (ExitFailure 1) Just PackageInfo{ dependencies } -> return (pkg : dependencies) let unique = Set.toList (foldMap Set.fromList pkgs) @@ -211,7 +212,7 @@ initialize = do echoT "psc-package.json already exists" exit (ExitFailure 1) echoT "Initializing new project in current directory" - pkgName <- pathToTextUnsafe . Path.filename <$> pwd + pkgName <- packageNameFromPWD . pathToTextUnsafe . Path.filename <$> pwd pursVersion <- getPureScriptVersion echoT ("Using the default package set for PureScript compiler version " <> fromString (showVersion pursVersion)) @@ -219,6 +220,10 @@ initialize = do writePackageFile pkg updateImpl pkg + where + packageNameFromPWD = + either (const untitledPackageName) id . mkPackageName + update :: IO () update = do pkg <- readPackageFile @@ -226,27 +231,38 @@ update = do echoT "Update complete" install :: String -> IO () -install pkgName = do +install pkgName' = do pkg <- readPackageFile - let pkg' = pkg { depends = nub (pack pkgName : depends pkg) } + pkgName <- packageNameFromString pkgName' + let pkg' = pkg { depends = nub (pkgName : depends pkg) } updateImpl pkg' writePackageFile pkg' echoT "psc-package.json file was updated" uninstall :: String -> IO () -uninstall pkgName = do +uninstall pkgName' = do pkg <- readPackageFile - let pkg' = pkg { depends = filter (/= pack pkgName) $ depends pkg } + pkgName <- packageNameFromString pkgName' + let pkg' = pkg { depends = filter (/= pkgName) $ depends pkg } updateImpl pkg' writePackageFile pkg' echoT "psc-package.json file was updated" +packageNameFromString :: String -> IO PackageName +packageNameFromString str = + case mkPackageName (pack str) of + Right pkgName -> + pure pkgName + Left _ -> do + echoT ("Invalid package name: " <> pack (show str)) + exit (ExitFailure 1) + listDependencies :: IO () listDependencies = do pkg@PackageConfig{ depends } <- readPackageFile db <- readPackageSet pkg trans <- getTransitiveDeps db depends - traverse_ (echoT . fst) trans + traverse_ (echoT . runPackageName . fst) trans listPackages :: Bool -> IO () listPackages sorted = do @@ -256,8 +272,9 @@ listPackages sorted = do then traverse_ echoT (fmt <$> inOrder (Map.assocs db)) else traverse_ echoT (fmt <$> Map.assocs db) where - fmt :: (Text, PackageInfo) -> Text - fmt (name, PackageInfo{ version, repo }) = name <> " (" <> version <> ", " <> repo <> ")" + fmt :: (PackageName, PackageInfo) -> Text + fmt (name, PackageInfo{ version, repo }) = + runPackageName name <> " (" <> version <> ", " <> repo <> ")" inOrder xs = fromNode . fromVertex <$> vs where (gr, fromVertex) = @@ -267,12 +284,12 @@ listPackages sorted = do vs = G.topSort (G.transposeG gr) fromNode (pkg, name, _) = (name, pkg) -getSourcePaths :: PackageConfig -> PackageSet -> [Text] -> IO [Turtle.FilePath] +getSourcePaths :: PackageConfig -> PackageSet -> [PackageName] -> IO [Turtle.FilePath] getSourcePaths PackageConfig{..} db pkgNames = do trans <- getTransitiveDeps db pkgNames let paths = [ ".psc-package" fromText set - fromText pkgName + fromText (runPackageName pkgName) fromText version "src" "**" "*.purs" | (pkgName, PackageInfo{ version }) <- trans @@ -315,7 +332,7 @@ checkForUpdates applyMinorUpdates applyMajorUpdates = do echoT "Warning: this could take some time!" newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do - echoT ("Checking package " <> name) + echoT ("Checking package " <> runPackageName name) tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list let tags = mapMaybe parseTag tagLines newVersion <- case parsePackageVersion version of @@ -397,7 +414,7 @@ verifyPackageSet = do for_ (Map.toList db) $ \(name, PackageInfo{..}) -> do let dirFor pkgName = fromMaybe (error ("verifyPackageSet: no directory for " <> show pkgName)) (Map.lookup pkgName paths) - echoT ("Verifying package " <> name) + echoT ("Verifying package " <> runPackageName name) let srcGlobs = map (pathToTextUnsafe . ( ("src" "**" "*.purs")) . dirFor) (name : dependencies) procs "purs" ("compile" : srcGlobs) empty diff --git a/app/Types.hs b/app/Types.hs new file mode 100644 index 0000000..bb448d0 --- /dev/null +++ b/app/Types.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Types + ( PackageName + , mkPackageName + , runPackageName + , preludePackageName + , untitledPackageName + ) where + +import Control.Category ((>>>)) +import Data.Aeson (FromJSON, ToJSON, FromJSONKey(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSONKeyFunction(..), parseJSON, toJSON, withText) +import qualified Data.Aeson.Encoding as AesonEncoding +import Data.Char (isAscii, isLower, isDigit) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T + +newtype PackageName + = PackageName Text + deriving (Show, Eq, Ord) + +instance ToJSON PackageName where + toJSON (PackageName t) = toJSON t + +instance FromJSON PackageName where + parseJSON = + withText "package name" fromText + +fromText :: Monad m => Text -> m PackageName +fromText t = + case mkPackageName t of + Right pkgName -> pure pkgName + Left errs -> fail $ "Invalid package name: " <> show errs + +instance ToJSONKey PackageName where + toJSONKey = + ToJSONKeyText + runPackageName + (AesonEncoding.text . runPackageName) + +instance FromJSONKey PackageName where + fromJSONKey = + FromJSONKeyTextParser fromText + +data PackageNameError + = NotEmpty + | TooLong Int + | InvalidChars [Char] + | RepeatedSeparators + | MustNotBeginSeparator + | MustNotEndSeparator + deriving (Show, Eq, Ord) + +-- | Smart constructor for package names. Based on Bower's requirements for +-- | package names. +mkPackageName :: Text -> Either PackageNameError PackageName +mkPackageName = fmap PackageName . validateAll validators + where + dashOrDot = ['-', '.'] + validateAll vs x = mapM_ (validateWith x) vs >> return x + validateWith x (p, err) + | p x = Right x + | otherwise = Left (err x) + validChar c = isAscii c && (isLower c || isDigit c || c `elem` dashOrDot) + validators = + [ (not . T.null, const NotEmpty) + , (T.all validChar, InvalidChars . T.unpack . T.filter (not . validChar)) + , (firstChar (`notElem` dashOrDot), const MustNotBeginSeparator) + , (lastChar (`notElem` dashOrDot), const MustNotEndSeparator) + , (not . T.isInfixOf "--", const RepeatedSeparators) + , (not . T.isInfixOf "..", const RepeatedSeparators) + , (T.length >>> (<= 50), TooLong . T.length) + ] + firstChar p str = not (T.null str) && p (T.index str 0) + lastChar p = firstChar p . T.reverse + +runPackageName :: PackageName -> Text +runPackageName (PackageName t) = t + +preludePackageName :: PackageName +preludePackageName = PackageName "prelude" + +untitledPackageName :: PackageName +untitledPackageName = PackageName "untitled" diff --git a/psc-package.cabal b/psc-package.cabal index 30e9ec0..8000936 100644 --- a/psc-package.cabal +++ b/psc-package.cabal @@ -27,6 +27,7 @@ executable psc-package turtle ==1.3.* main-is: Main.hs other-modules: Paths_psc_package + Types buildable: True hs-source-dirs: app ghc-options: -Wall -O2