├── README.md ├── .gitignore ├── tests ├── Tests.hs ├── ComparisonTests.hs └── SolverTests.hs ├── src ├── Diff │ ├── Magnitude.hs │ ├── Display.hs │ └── Compare.hs ├── Utils │ ├── Paths.hs │ └── Http.hs ├── Main.hs ├── Docs.hs ├── Elm │ └── Package │ │ ├── Initialize.hs │ │ ├── Paths.hs │ │ ├── Solution.hs │ │ ├── Constraint.hs │ │ └── Description.hs ├── Manager.hs ├── CommandLine │ ├── Helpers.hs │ └── Arguments.hs ├── Install │ ├── Plan.hs │ ├── Fetch.hs │ └── Solver.hs ├── GitHub.hs ├── Diff.hs ├── Publish.hs ├── Store.hs ├── Catalog.hs ├── Bump.hs ├── Install.hs └── Reporting │ └── Error.hs ├── LICENSE └── elm-package.cabal /README.md: -------------------------------------------------------------------------------- 1 | # Merged into [`elm/compiler`](https://github.com/elm/compiler) 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | log 3 | *~ 4 | .cabal-sandbox/ 5 | cabal.sandbox.config 6 | -------------------------------------------------------------------------------- /tests/Tests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Test.Framework as TF 4 | 5 | import SolverTests 6 | import ComparisonTests 7 | 8 | main = TF.defaultMain [ solverTests, comparisonTests ] 9 | -------------------------------------------------------------------------------- /src/Diff/Magnitude.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Diff.Magnitude 3 | ( Magnitude(..) 4 | ) 5 | where 6 | 7 | 8 | data Magnitude 9 | = PATCH 10 | | MINOR 11 | | MAJOR 12 | deriving (Eq, Ord, Show) 13 | 14 | -------------------------------------------------------------------------------- /src/Utils/Paths.hs: -------------------------------------------------------------------------------- 1 | module Utils.Paths where 2 | 3 | import System.FilePath 4 | 5 | import qualified Elm.Package as Package 6 | 7 | internals = "_internals" 8 | 9 | libDir = "public" "catalog" 10 | 11 | json = "docs.json" 12 | index = "index.elm" 13 | listing = "public" "libraries.json" 14 | 15 | library name = libDir N.toFilePath name 16 | 17 | libraryVersion :: Package.Name -> Package.Version -> FilePath 18 | libraryVersion name version = 19 | library name Package.versiontoString version 20 | 21 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Exit (exitFailure) 4 | import System.IO 5 | import GHC.IO.Encoding (setLocaleEncoding) 6 | 7 | import qualified CommandLine.Arguments as Arguments 8 | import qualified Manager 9 | import qualified Reporting.Error as Error 10 | 11 | 12 | main :: IO () 13 | main = 14 | do setLocaleEncoding utf8 15 | 16 | manager <- Arguments.parse 17 | result <- Manager.run manager 18 | 19 | case result of 20 | Right () -> 21 | return () 22 | 23 | Left err -> 24 | do Error.toStderr err 25 | exitFailure 26 | -------------------------------------------------------------------------------- /src/Docs.hs: -------------------------------------------------------------------------------- 1 | module Docs (generate) where 2 | 3 | import Control.Monad.Error.Class (throwError) 4 | import Control.Monad.Trans (liftIO) 5 | import qualified Data.Aeson as Json 6 | import qualified Data.ByteString.Lazy.Char8 as BS 7 | 8 | import qualified Catalog 9 | import qualified CommandLine.Helpers as Cmd 10 | import qualified Elm.Docs as Docs 11 | import qualified Elm.Package as Pkg 12 | import qualified Elm.Package.Paths as Path 13 | import qualified Manager 14 | import qualified Reporting.Error as Error 15 | 16 | 17 | 18 | -- GENERATE DOCS / CHECK PERMISSIONS 19 | 20 | 21 | generate :: Pkg.Name -> Manager.Manager [Docs.Documentation] 22 | generate name = 23 | do permissions <- Catalog.permissions name 24 | 25 | let prepublishFlag = 26 | if permissions then "--prepublish-core" else "--prepublish" 27 | 28 | Cmd.run "elm-make" [ "--yes", "--docs=" ++ Path.documentation, prepublishFlag ] 29 | json <- liftIO (BS.readFile Path.documentation) 30 | 31 | either (throwError . Error.CorruptDocumentation) return (Json.eitherDecode json) 32 | -------------------------------------------------------------------------------- /src/Elm/Package/Initialize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Elm.Package.Initialize (solution) where 3 | 4 | import Control.Monad.Except (ExceptT, MonadIO, liftIO, throwError) 5 | import qualified Data.Map as Map 6 | import System.Directory (doesFileExist) 7 | 8 | import qualified Elm.Package.Paths as Path 9 | import qualified Elm.Package.Solution as S 10 | import qualified Install 11 | import qualified Manager 12 | import qualified Reporting.Error as Error 13 | 14 | 15 | 16 | solution :: (MonadIO m) => Bool -> ExceptT String m S.Solution 17 | solution autoYes = 18 | do result <- liftIO $ Manager.run $ installEverythingAndGetSolution autoYes 19 | case result of 20 | Right solution -> 21 | return solution 22 | 23 | Left err -> 24 | throwError $ Error.toString err 25 | 26 | 27 | installEverythingAndGetSolution :: Bool -> Manager.Manager S.Solution 28 | installEverythingAndGetSolution autoYes = 29 | do () <- Install.install autoYes Install.Everything 30 | exists <- liftIO (doesFileExist Path.solvedDependencies) 31 | if exists 32 | then S.read Error.CorruptSolution Path.solvedDependencies 33 | else return Map.empty 34 | -------------------------------------------------------------------------------- /src/Elm/Package/Paths.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Elm.Package.Paths where 3 | 4 | import System.FilePath (()) 5 | import qualified Elm.Package as Package 6 | 7 | 8 | {-| Name of directory for all of a project's dependencies. -} 9 | stuffDirectory :: FilePath 10 | stuffDirectory = 11 | "elm-stuff" 12 | 13 | 14 | {-| Describes the exact versions of every package used for your project. This 15 | information is written by elm-package when it solves and installs dependencies. 16 | -} 17 | solvedDependencies :: FilePath 18 | solvedDependencies = 19 | stuffDirectory "exact-dependencies.json" 20 | 21 | 22 | {-| Documentation for all the exposed modules in this package. 23 | -} 24 | documentation :: FilePath 25 | documentation = 26 | stuffDirectory "documentation.json" 27 | 28 | 29 | {-| Name of the dependency file, specifying dependencies and other metadata 30 | for building and sharing projects. 31 | -} 32 | description :: FilePath 33 | description = 34 | "elm-package.json" 35 | 36 | 37 | {-| Directory for all packages needed to build your project. 38 | -} 39 | packagesDirectory :: FilePath 40 | packagesDirectory = 41 | stuffDirectory "packages" 42 | 43 | 44 | {-| Path to a particular package. -} 45 | package :: Package.Name -> Package.Version -> FilePath 46 | package name version = 47 | packagesDirectory Package.toFilePath name Package.versionToString version 48 | -------------------------------------------------------------------------------- /src/Manager.hs: -------------------------------------------------------------------------------- 1 | module Manager 2 | ( Manager 3 | , run 4 | , Environment(..) 5 | ) 6 | where 7 | 8 | import Control.Monad.Except (ExceptT, runExceptT) 9 | import Control.Monad.Reader (ReaderT, runReaderT) 10 | import qualified Elm.Compiler as Elm 11 | import qualified Elm.Package as Pkg 12 | import qualified Network 13 | import qualified Network.HTTP.Client as Http 14 | import qualified Network.HTTP.Client.TLS as Http 15 | import qualified System.Directory as Dir 16 | import System.FilePath (()) 17 | 18 | import qualified Reporting.Error as Error 19 | 20 | 21 | type Manager = 22 | ExceptT Error.Error (ReaderT Environment IO) 23 | 24 | 25 | run :: Manager a -> IO (Either Error.Error a) 26 | run manager = 27 | Network.withSocketsDo $ 28 | do cacheDirectory <- getCacheDirectory 29 | httpManager <- Http.newManager Http.tlsManagerSettings 30 | let env = Environment "http://package.elm-lang.org" cacheDirectory httpManager 31 | runReaderT (runExceptT manager) env 32 | 33 | 34 | data Environment = 35 | Environment 36 | { catalog :: String 37 | , cacheDirectory :: FilePath 38 | , httpManager :: Http.Manager 39 | } 40 | 41 | 42 | getCacheDirectory :: IO FilePath 43 | getCacheDirectory = 44 | do root <- Dir.getAppUserDataDirectory "elm" 45 | let dir = root Pkg.versionToString Elm.version "package" 46 | Dir.createDirectoryIfMissing True dir 47 | return dir 48 | -------------------------------------------------------------------------------- /src/CommandLine/Helpers.hs: -------------------------------------------------------------------------------- 1 | module CommandLine.Helpers where 2 | 3 | import Control.Monad.Except (liftIO, runExceptT, throwError) 4 | import System.Directory 5 | import System.IO 6 | 7 | import qualified Elm.Utils as Utils 8 | import qualified Manager 9 | import qualified Reporting.Error as Error 10 | 11 | 12 | yesOrNo :: IO Bool 13 | yesOrNo = 14 | do hFlush stdout 15 | input <- getLine 16 | case input of 17 | "" -> return True 18 | "Y" -> return True 19 | "y" -> return True 20 | "n" -> return False 21 | _ -> 22 | do putStr "Must type 'y' for yes or 'n' for no: " 23 | yesOrNo 24 | 25 | 26 | inDir :: FilePath -> Manager.Manager a -> Manager.Manager a 27 | inDir dir task = 28 | do here <- liftIO $ getCurrentDirectory 29 | liftIO $ createDirectoryIfMissing True dir 30 | liftIO $ setCurrentDirectory dir 31 | result <- task 32 | liftIO $ setCurrentDirectory here 33 | return result 34 | 35 | 36 | run :: String -> [String] -> Manager.Manager String 37 | run name args = 38 | do result <- liftIO $ runExceptT $ Utils.run name args 39 | either (throwError . Error.SystemCallFailed) return result 40 | 41 | 42 | out :: String -> Manager.Manager () 43 | out string = 44 | let 45 | formattedString = 46 | if not (null string) && last string == '\n' then 47 | init string 48 | else 49 | string 50 | in 51 | liftIO $ hPutStrLn stdout formattedString 52 | 53 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2015, Evan Czaplicki 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Evan Czaplicki nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Install/Plan.hs: -------------------------------------------------------------------------------- 1 | module Install.Plan where 2 | 3 | import qualified Data.Map as Map 4 | 5 | import qualified Elm.Package.Solution as S 6 | import qualified Elm.Package as Package 7 | 8 | 9 | data Plan = Plan 10 | { installs :: Map.Map Package.Name Package.Version 11 | , upgrades :: Map.Map Package.Name (Package.Version, Package.Version) 12 | , removals :: Map.Map Package.Name Package.Version 13 | } 14 | 15 | 16 | create :: S.Solution -> S.Solution -> Plan 17 | create old new = 18 | Plan 19 | { installs = Map.difference new old 20 | , upgrades = discardNoOps (Map.intersectionWith (,) old new) 21 | , removals = Map.difference old new 22 | } 23 | where 24 | discardNoOps updates = 25 | Map.mapMaybe isChanged updates 26 | 27 | isChanged upgrade@(oldVersion,newVersion) = 28 | if oldVersion == newVersion 29 | then Nothing 30 | else Just upgrade 31 | 32 | 33 | isEmpty :: Plan -> Bool 34 | isEmpty (Plan installs upgrades removals) = 35 | Map.null installs 36 | && Map.null upgrades 37 | && Map.null removals 38 | 39 | 40 | -- DISPLAY 41 | 42 | display :: Plan -> String 43 | display (Plan installs upgrades removals) = 44 | "\n" 45 | ++ displayCategory "Install" displayInstall installs 46 | ++ displayCategory "Upgrade" displayUpgrade upgrades 47 | ++ displayCategory "Remove" displayRemove removals 48 | where 49 | displayCategory name render category = 50 | if Map.null category then "" else 51 | " " ++ name ++ ":" 52 | ++ concatMap (\entry -> "\n " ++ render entry) (Map.toList category) 53 | ++ "\n" 54 | 55 | displayInstall (name, version) = 56 | Package.toString name ++ " " ++ Package.versionToString version 57 | 58 | displayUpgrade (name, (old, new)) = 59 | Package.toString name ++ " (" 60 | ++ Package.versionToString old ++ " => " ++ Package.versionToString new ++ ")" 61 | 62 | displayRemove (name, _version) = 63 | Package.toString name 64 | -------------------------------------------------------------------------------- /src/Utils/Http.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Utils.Http (send) where 3 | 4 | import qualified Control.Exception as E 5 | import Control.Monad.Except (throwError, liftIO) 6 | import qualified Control.Monad.Reader as Reader 7 | import qualified Data.ByteString.Char8 as BSC 8 | import qualified Data.List as List 9 | import qualified Network.HTTP.Client as Http 10 | import qualified Network.HTTP.Types as Http 11 | 12 | import qualified Reporting.Error as Error 13 | import qualified Manager 14 | 15 | 16 | 17 | -- PUBLIC API 18 | 19 | 20 | send :: String -> (Http.Request -> Http.Manager -> IO a) -> Manager.Manager a 21 | send url handler = 22 | do manager <- Reader.asks Manager.httpManager 23 | result <- liftIO (sendSafe url manager handler) 24 | either throwError return result 25 | 26 | 27 | 28 | -- ACTUALLY SEND REQUESTS 29 | 30 | 31 | sendSafe 32 | :: String 33 | -> Http.Manager 34 | -> (Http.Request -> Http.Manager -> IO a) 35 | -> IO (Either Error.Error a) 36 | sendSafe url manager handler = 37 | sendUnsafe url manager handler 38 | `E.catch` handleHttpError url 39 | `E.catch` \e -> handleAnyError url (e :: E.SomeException) 40 | 41 | 42 | sendUnsafe 43 | :: String 44 | -> Http.Manager 45 | -> (Http.Request -> Http.Manager -> IO a) 46 | -> IO (Either err a) 47 | sendUnsafe url manager handler = 48 | do request <- Http.parseUrl url 49 | result <- handler request manager 50 | return (Right result) 51 | 52 | 53 | handleHttpError :: String -> Http.HttpException -> IO (Either Error.Error b) 54 | handleHttpError url exception = 55 | case exception of 56 | Http.StatusCodeException (Http.Status _code err) headers _ -> 57 | return $ Left $ Error.HttpRequestFailed url $ BSC.unpack $ 58 | case List.lookup "X-Response-Body-Start" headers of 59 | Just msg | not (BSC.null msg) -> 60 | msg 61 | 62 | _ -> 63 | err 64 | 65 | _ -> 66 | handleAnyError url exception 67 | 68 | 69 | handleAnyError :: (E.Exception e) => String -> e -> IO (Either Error.Error b) 70 | handleAnyError url exception = 71 | return $ Left $ Error.HttpRequestFailed url (show exception) 72 | -------------------------------------------------------------------------------- /src/GitHub.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module GitHub (getVersionTags, publicGetVersionTags) where 3 | 4 | import Control.Monad.Except (throwError) 5 | import Data.Aeson ((.:)) 6 | import qualified Data.Aeson as Json 7 | import qualified Data.Aeson.Types as Json 8 | import qualified Data.Either as Either 9 | import Data.Monoid ((<>)) 10 | import qualified Data.Text as Text 11 | import qualified Data.Vector as Vector 12 | import Network.HTTP.Client 13 | 14 | import qualified Elm.Package as Package 15 | import qualified Reporting.Error as Error 16 | import qualified Manager 17 | import qualified Utils.Http as Http 18 | 19 | 20 | 21 | -- TAGS from GITHUB 22 | 23 | 24 | newtype Tags = Tags [String] 25 | 26 | 27 | getVersionTags :: Package.Name -> Manager.Manager [Package.Version] 28 | getVersionTags (Package.Name user project) = 29 | let 30 | url = 31 | Text.unpack ("https://api.github.com/repos/" <> user <> "/" <> project <> "/tags") 32 | 33 | headers = 34 | [ ("User-Agent", "elm-package") 35 | , ("Accept", "application/json") 36 | ] 37 | in 38 | do response <- 39 | Http.send url $ \request manager -> 40 | httpLbs (request {requestHeaders = headers}) manager 41 | 42 | case Json.eitherDecode (responseBody response) of 43 | Left err -> 44 | throwError $ Error.HttpRequestFailed url err 45 | 46 | Right (Tags tags) -> 47 | return (Either.rights (map Package.versionFromString tags)) 48 | 49 | 50 | instance Json.FromJSON Tags where 51 | parseJSON json = 52 | case json of 53 | Json.Array arr -> 54 | Tags <$> mapM toTag (Vector.toList arr) 55 | 56 | _ -> 57 | fail "response is not a JSON array" 58 | 59 | 60 | toTag :: Json.Value -> Json.Parser String 61 | toTag json = 62 | case json of 63 | Json.Object object -> 64 | object .: "name" 65 | 66 | _ -> 67 | fail "response is not a JSON array full of objects" 68 | 69 | 70 | 71 | -- PUBLIC VERSION 72 | 73 | 74 | publicGetVersionTags :: Package.Name -> IO (Either String [Package.Version]) 75 | publicGetVersionTags pkg = 76 | either (Left . Error.toString) Right 77 | <$> Manager.run (getVersionTags pkg) 78 | -------------------------------------------------------------------------------- /src/Diff.hs: -------------------------------------------------------------------------------- 1 | module Diff where 2 | 3 | import Control.Monad.Except (throwError) 4 | 5 | import qualified Catalog 6 | import qualified CommandLine.Helpers as Cmd 7 | import qualified Diff.Compare as Compare 8 | import qualified Diff.Display as Display 9 | import qualified Docs 10 | import qualified Elm.Docs as Docs 11 | import qualified Elm.Package.Description as Desc 12 | import qualified Elm.Package.Paths as Path 13 | import qualified Elm.Package as Package 14 | import qualified Manager 15 | import qualified Reporting.Error as Error 16 | 17 | 18 | data Range 19 | = LatestVsActual 20 | | Since Package.Version 21 | | Between Package.Name Package.Version Package.Version 22 | 23 | 24 | diff :: Range -> Manager.Manager () 25 | diff range = 26 | case range of 27 | LatestVsActual -> 28 | do name <- Desc.name `fmap` Desc.read Error.CorruptDescription Path.description 29 | newDocs <- Docs.generate name 30 | 31 | maybeVersions <- Catalog.versions name 32 | latestVersion <- 33 | maybe (throwError Error.Undiffable) (return . maximum) maybeVersions 34 | 35 | computeDiff name latestVersion newDocs Nothing 36 | 37 | Since version -> 38 | do name <- Desc.name `fmap` Desc.read Error.CorruptDescription Path.description 39 | newDocs <- Docs.generate name 40 | computeDiff name version newDocs Nothing 41 | 42 | Between name old new -> 43 | do newDocs <- Catalog.documentation name new 44 | computeDiff name old newDocs (Just new) 45 | 46 | 47 | computeDiff 48 | :: Package.Name 49 | -> Package.Version 50 | -> [Docs.Documentation] 51 | -> Maybe Package.Version 52 | -> Manager.Manager () 53 | computeDiff name oldVersion newDocs maybeNewVersion = 54 | do Cmd.out msg 55 | changes <- Compare.computeChanges newDocs name oldVersion 56 | Cmd.out (Display.packageChanges changes) 57 | where 58 | msg = 59 | "Comparing " ++ Package.toString name ++ " " ++ Package.versionToString oldVersion ++ " to " ++ newStuff ++ "..." 60 | 61 | newStuff = 62 | case maybeNewVersion of 63 | Nothing -> "local changes" 64 | Just version -> Package.versionToString version 65 | -------------------------------------------------------------------------------- /src/Elm/Package/Solution.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | module Elm.Package.Solution (Solution, write, read) where 3 | 4 | import Prelude hiding (read) 5 | import Control.Monad.Except (ExceptT, throwError, withExceptT) 6 | import Control.Monad.Trans (MonadIO, liftIO) 7 | import Data.Aeson (Value, (.=), eitherDecode, object) 8 | import Data.Aeson.Encode.Pretty (encodePretty) 9 | import qualified Data.ByteString.Lazy as BS 10 | import qualified Data.HashMap.Strict as HashMap 11 | import qualified Data.Map as Map 12 | import qualified Data.Text as Text 13 | 14 | import qualified Elm.Package as Pkg 15 | 16 | 17 | 18 | -- SOLUTION 19 | 20 | 21 | type Solution = 22 | Map.Map Pkg.Name Pkg.Version 23 | 24 | 25 | 26 | -- READING AND WRITING SOLUTIONS 27 | 28 | 29 | write :: FilePath -> Solution -> IO () 30 | write filePath solution = 31 | BS.writeFile filePath (encodePretty (toJson solution)) 32 | 33 | 34 | read :: (MonadIO m) => (String -> e) -> FilePath -> ExceptT e m Solution 35 | read toError path = 36 | do rawJson <- liftIO (BS.readFile path) 37 | case eitherDecode rawJson of 38 | Left err -> 39 | throwError $ toError err 40 | 41 | Right hashMap -> 42 | withExceptT toError $ fromJson hashMap 43 | 44 | 45 | 46 | -- TO JSON 47 | 48 | 49 | toJson :: Solution -> Value 50 | toJson solution = 51 | let 52 | toField (name, version) = 53 | Text.pack (Pkg.toString name) .= Text.pack (Pkg.versionToString version) 54 | in 55 | object (map toField (Map.toList solution)) 56 | 57 | 58 | 59 | -- FROM JSON 60 | 61 | 62 | fromJson :: (Monad m) => HashMap.HashMap String String -> ExceptT String m Solution 63 | fromJson hashMap = 64 | do pairs <- mapM parseNameAndVersion (HashMap.toList hashMap) 65 | return (Map.fromList pairs) 66 | 67 | 68 | parseNameAndVersion :: (Monad m) => (String,String) -> ExceptT String m (Pkg.Name, Pkg.Version) 69 | parseNameAndVersion (rawName, rawVersion) = 70 | (,) 71 | <$> parse rawName Pkg.fromString ("package name " ++ rawName) 72 | <*> parse rawVersion Pkg.versionFromString ("version number for package " ++ rawName) 73 | 74 | 75 | parse :: (Monad m) => String -> (String -> Either String a) -> String -> ExceptT String m a 76 | parse string fromString msg = 77 | case fromString string of 78 | Right a -> 79 | return a 80 | 81 | Left problem -> 82 | throwError $ "Could not parse " ++ msg ++ ". " ++ problem -------------------------------------------------------------------------------- /src/Publish.hs: -------------------------------------------------------------------------------- 1 | module Publish where 2 | 3 | import Control.Monad.Except (throwError) 4 | import qualified Data.Maybe as Maybe 5 | 6 | import qualified Bump 7 | import qualified Catalog 8 | import qualified CommandLine.Helpers as Cmd 9 | import qualified Docs 10 | import qualified Elm.Docs as Docs 11 | import qualified Elm.Package.Description as Desc 12 | import qualified Elm.Package as Package 13 | import qualified Elm.Package.Paths as P 14 | import qualified GitHub 15 | import qualified Manager 16 | import qualified Reporting.Error as Error 17 | 18 | 19 | 20 | publish :: Manager.Manager () 21 | publish = 22 | do description <- Desc.read Error.CorruptDescription P.description 23 | 24 | let name = Desc.name description 25 | 26 | Cmd.out $ unwords $ 27 | [ "Verifying", Package.toString name 28 | , Package.versionToString (Desc.version description), "..." 29 | ] 30 | 31 | verifyMetadata description 32 | 33 | docs <- Docs.generate name 34 | 35 | newVersion <- verifyVersion docs description 36 | 37 | verifyTag name newVersion 38 | Catalog.register name newVersion 39 | Cmd.out "Success!" 40 | 41 | 42 | 43 | verifyMetadata :: Desc.Description -> Manager.Manager () 44 | verifyMetadata deps = 45 | case problems of 46 | [] -> 47 | return () 48 | 49 | _ -> 50 | throwError $ Error.BadMetadata problems 51 | where 52 | problems = 53 | Maybe.catMaybes 54 | [ verify Desc.repo " repository - must refer to a valid repo on GitHub" 55 | , verify Desc.summary " summary - a quick summary of your project, 80 characters or less" 56 | , verify Desc.exposed " exposed-modules - list modules your project exposes to users" 57 | ] 58 | 59 | verify getField msg = 60 | if getField deps == getField Desc.defaultDescription then 61 | Just msg 62 | else 63 | Nothing 64 | 65 | 66 | verifyVersion 67 | :: [Docs.Documentation] 68 | -> Desc.Description 69 | -> Manager.Manager Package.Version 70 | verifyVersion docs description = 71 | let 72 | name = 73 | Desc.name description 74 | 75 | version = 76 | Desc.version description 77 | in 78 | do maybeVersions <- Catalog.versions name 79 | validity <- 80 | case maybeVersions of 81 | Just publishedVersions -> 82 | Bump.validateVersion docs name version publishedVersions 83 | 84 | Nothing -> 85 | Bump.validateInitialVersion description 86 | 87 | case validity of 88 | Bump.Valid -> 89 | return version 90 | 91 | Bump.Invalid -> 92 | throwError $ Error.VersionInvalid 93 | 94 | Bump.Changed _ -> 95 | throwError $ Error.VersionJustChanged 96 | 97 | 98 | verifyTag :: Package.Name -> Package.Version -> Manager.Manager () 99 | verifyTag name version = 100 | do publicVersions <- GitHub.getVersionTags name 101 | if elem version publicVersions 102 | then return () 103 | else throwError (Error.MissingTag version) -------------------------------------------------------------------------------- /src/Store.hs: -------------------------------------------------------------------------------- 1 | module Store (Store, getConstraints, getVersions, initialStore, readVersionCache) where 2 | 3 | import Control.Monad.Except (throwError) 4 | import Control.Monad.State (StateT) 5 | import Control.Monad.RWS (lift, liftIO, asks, gets, modify) 6 | import qualified Data.Binary as Binary 7 | import qualified Data.ByteString.Lazy as BS 8 | import qualified Data.Map as Map 9 | import qualified Data.Time.Clock as Time 10 | import qualified System.Directory as Dir 11 | import System.FilePath (()) 12 | 13 | import qualified Catalog 14 | import qualified Elm.Package.Constraint as C 15 | import qualified Elm.Package.Description as Desc 16 | import qualified Elm.Package as Package 17 | import qualified Manager 18 | import qualified Reporting.Error as Error 19 | 20 | 21 | 22 | -- STORE 23 | 24 | 25 | data Store = Store 26 | { constraintCache :: ConstraintCache 27 | , versionCache :: VersionCache 28 | } 29 | 30 | 31 | type ConstraintCache = 32 | Map.Map (Package.Name, Package.Version) (C.Constraint, [(Package.Name, C.Constraint)]) 33 | 34 | 35 | type VersionCache = 36 | Map.Map Package.Name [Package.Version] 37 | 38 | 39 | initialStore :: Manager.Manager Store 40 | initialStore = 41 | do versionCache <- readVersionCache 42 | return (Store Map.empty versionCache) 43 | 44 | 45 | readVersionCache :: Manager.Manager VersionCache 46 | readVersionCache = 47 | do cacheDirectory <- asks Manager.cacheDirectory 48 | let versionsFile = cacheDirectory "versions.dat" 49 | let lastUpdatedPath = cacheDirectory "last-updated" 50 | 51 | now <- liftIO Time.getCurrentTime 52 | 53 | exists <- liftIO (Dir.doesFileExist lastUpdatedPath) 54 | maybeTime <- 55 | case exists of 56 | False -> return Nothing 57 | True -> 58 | do rawTime <- liftIO (readFile lastUpdatedPath) 59 | return $ Just (read rawTime) 60 | 61 | maybePackages <- Catalog.allPackages maybeTime 62 | 63 | case maybePackages of 64 | Nothing -> 65 | do exists <- liftIO (Dir.doesFileExist versionsFile) 66 | case exists of 67 | False -> return Map.empty 68 | True -> 69 | do binary <- liftIO (BS.readFile versionsFile) 70 | return (Binary.decode binary) 71 | 72 | Just packages -> 73 | let cache :: VersionCache 74 | cache = Map.fromList packages 75 | in 76 | do liftIO $ BS.writeFile versionsFile (Binary.encode cache) 77 | liftIO $ writeFile lastUpdatedPath (show now) 78 | return cache 79 | 80 | 81 | 82 | -- CONSTRAINTS 83 | 84 | 85 | type Explorer = 86 | StateT Store.Store Manager.Manager 87 | 88 | 89 | getConstraints :: Package.Name -> Package.Version -> Explorer (C.Constraint, [(Package.Name, C.Constraint)]) 90 | getConstraints name version = 91 | do cache <- gets constraintCache 92 | case Map.lookup (name, version) cache of 93 | Just constraints -> 94 | return constraints 95 | 96 | Nothing -> 97 | do desc <- lift $ Catalog.description name version 98 | let constraints = (Desc.elmVersion desc, Desc.dependencies desc) 99 | modify $ \store -> 100 | store { 101 | constraintCache = 102 | Map.insert (name, version) constraints (constraintCache store) 103 | } 104 | return constraints 105 | 106 | 107 | 108 | -- VERSIONS 109 | 110 | 111 | getVersions :: Package.Name -> Explorer [Package.Version] 112 | getVersions name = 113 | do cache <- gets versionCache 114 | case Map.lookup name cache of 115 | Just versions -> 116 | return versions 117 | 118 | Nothing -> 119 | throwError $ Error.CorruptVersionCache name 120 | -------------------------------------------------------------------------------- /elm-package.cabal: -------------------------------------------------------------------------------- 1 | Name: elm-package 2 | Version: 0.18 3 | 4 | Synopsis: 5 | Package manager for Elm libraries 6 | Description: 7 | elm-package is a package manager that lets you install, update, and 8 | publish Elm libraries. 9 | 10 | Homepage: 11 | http://github.com/elm-lang/elm-package 12 | 13 | License: BSD3 14 | License-file: LICENSE 15 | 16 | Author: Evan Czaplicki 17 | Maintainer: info@elm-lang.org 18 | Copyright: Copyright: (c) 2013-2014 Evan Czaplicki 19 | 20 | Category: Language 21 | 22 | Build-type: Simple 23 | Cabal-version: >=1.9 24 | 25 | source-repository head 26 | type: git 27 | location: git://github.com/elm-lang/elm-package.git 28 | 29 | Library 30 | ghc-options: 31 | -threaded -O2 -W 32 | 33 | Hs-Source-Dirs: 34 | src 35 | 36 | exposed-modules: 37 | Elm.Package.Constraint, 38 | Elm.Package.Description, 39 | Elm.Package.Initialize, 40 | Elm.Package.Paths, 41 | Elm.Package.Solution, 42 | GitHub 43 | 44 | other-modules: 45 | Catalog, 46 | CommandLine.Helpers, 47 | Diff.Magnitude, 48 | Install, 49 | Install.Fetch, 50 | Install.Plan, 51 | Install.Solver, 52 | Manager, 53 | Paths_elm_package, 54 | Reporting.Error, 55 | Store, 56 | Utils.Http 57 | 58 | Build-depends: 59 | aeson >= 0.11, 60 | aeson-pretty, 61 | ansi-wl-pprint >= 0.6.7.3, 62 | base >=4.2 && <5, 63 | binary >= 0.7 && < 0.8, 64 | containers >= 0.3 && < 0.6, 65 | bytestring >= 0.9 && < 0.11, 66 | directory >= 1.0 && < 2.0, 67 | edit-distance, 68 | elm-compiler == 0.18, 69 | filepath >= 1 && < 2.0, 70 | HTTP >= 4000.2.5 && < 4000.4, 71 | http-client >= 0.4.15 && < 0.5, 72 | http-client-tls >= 0.2 && < 0.3, 73 | http-types >= 0.7 && < 0.9, 74 | mtl >= 2.2.1 && < 3, 75 | network >= 2.4 && < 2.7, 76 | parallel-io, 77 | text, 78 | time, 79 | unordered-containers, 80 | vector >= 0.10 && < 0.12, 81 | zip-archive 82 | 83 | 84 | Executable elm-package 85 | ghc-options: 86 | -threaded -O2 -W 87 | 88 | Hs-Source-Dirs: 89 | src 90 | 91 | Main-is: 92 | Main.hs 93 | 94 | other-modules: 95 | Bump, 96 | Catalog, 97 | CommandLine.Arguments, 98 | CommandLine.Helpers, 99 | Diff, 100 | Diff.Compare, 101 | Diff.Display, 102 | Diff.Magnitude, 103 | Docs, 104 | Elm.Package.Constraint, 105 | Elm.Package.Description, 106 | Elm.Package.Initialize, 107 | Elm.Package.Paths, 108 | Elm.Package.Solution, 109 | GitHub, 110 | Install, 111 | Install.Fetch, 112 | Install.Plan, 113 | Install.Solver, 114 | Manager, 115 | Publish, 116 | Reporting.Error, 117 | Store, 118 | Utils.Http, 119 | Utils.Paths, 120 | Paths_elm_package 121 | 122 | Build-depends: 123 | aeson >= 0.11, 124 | aeson-pretty, 125 | ansi-wl-pprint >= 0.6 && < 0.7, 126 | base >=4.2 && <5, 127 | binary >= 0.7 && < 0.8, 128 | bytestring >= 0.9 && < 0.11, 129 | containers >= 0.3 && < 0.6, 130 | directory >= 1.0 && < 2.0, 131 | edit-distance, 132 | elm-compiler == 0.18, 133 | filepath >= 1 && < 2.0, 134 | HTTP >= 4000.2.5 && < 4000.4, 135 | http-client >= 0.3 && < 0.5, 136 | http-client-tls >= 0.2 && < 0.3, 137 | http-types >= 0.7 && < 0.9, 138 | mtl >= 2 && < 3, 139 | network >= 2.4 && < 2.7, 140 | optparse-applicative >= 0.11 && < 0.14, 141 | parallel-io, 142 | pretty, 143 | text, 144 | time, 145 | unordered-containers, 146 | vector >= 0.10 && < 0.12, 147 | zip-archive 148 | -------------------------------------------------------------------------------- /tests/ComparisonTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module ComparisonTests (comparisonTests) where 4 | 5 | import Data.Aeson 6 | import Data.Aeson.Types 7 | import Data.Map (Map) 8 | import Data.Text (Text) 9 | import Control.Monad.Error (runErrorT) 10 | import Test.HUnit ((@?), (@?=), Assertion) 11 | import qualified Data.Map as Map 12 | import qualified Test.Framework as TF 13 | import qualified Test.Framework.Providers.HUnit as TH 14 | 15 | import qualified Utils.SemverCheck as SC 16 | 17 | -- SETUP 18 | 19 | type_const1 = function [var "a", var "b"] (var "a") 20 | type_const2 = function [var "b", var "a"] (var "b") 21 | 22 | const_renaming = Map.fromList [("a", "b"), ("b", "a")] 23 | 24 | type_int = adt "Int" [] 25 | type_string = adt "String" [] 26 | 27 | type_list ty_elem = adt "List" [ty_elem] 28 | 29 | type_map1 = function [fun1 (var "a") (var "b"), type_list (var "a")] (type_list (var "b")) 30 | type_map2 = function [fun1 (var "b") (var "c"), type_list (var "b")] (type_list (var "c")) 31 | type_map_wrong = function [fun1 (var "b") (var "c"), type_list (var "c")] (type_list (var "c")) 32 | 33 | module_1 = 34 | modul [ value "map" type_map1 35 | , value "counter" type_int 36 | ] 37 | 38 | module_2 = 39 | modul [ value "map" type_map2 40 | , value "name" type_string 41 | ] 42 | 43 | module_comparison = 44 | Map.fromList [ ("map", SC.Existing SC.Same) 45 | , ("counter", SC.Removed) 46 | , ("name", SC.Added) 47 | ] 48 | 49 | map_renaming = Map.fromList [("a", "b"), ("b", "c")] 50 | 51 | yieldsComparison :: Value -> Value -> Map String SC.BindingState -> Assertion 52 | yieldsComparison v1 v2 result = 53 | case parseEither SC.buildModuleComparison (v1, v2) of 54 | Left err -> False @? "Parsing JSON values should succeed" 55 | Right ls -> mapM_ check ls 56 | where 57 | check entry = 58 | case Map.lookup (SC.name entry) result of 59 | Nothing -> False @? ("Unexpected entry " ++ SC.name entry) 60 | Just value -> value @?= SC.state entry 61 | 62 | yieldsRenaming :: Value -> Value -> Map String String -> Assertion 63 | yieldsRenaming v1 v2 renaming = 64 | case parseEither (runErrorT . SC.buildRenaming Map.empty) (v1, v2) of 65 | Left err -> False @? "Parsing JSON values should succeed" 66 | Right (Left _) -> False @? "Non-compatibility shouldn't occur" 67 | Right (Right result) -> result @?= renaming 68 | 69 | nonCompatible :: Value -> Value -> Assertion 70 | nonCompatible v1 v2 = 71 | case parseEither (runErrorT . SC.buildRenaming Map.empty) (v1, v2) of 72 | Left err -> False @? "Parsing JSON values should succeed" 73 | Right (Left _) -> return () 74 | Right (Right _) -> False @? "Types shouldn't be compatible" 75 | 76 | 77 | -- SETUP HELPERS 78 | 79 | var :: Text -> Value 80 | var varName = 81 | object [ "tag" .= ("var" :: Text) 82 | , "name" .= varName 83 | ] 84 | 85 | function :: [Value] -> Value -> Value 86 | function args result = 87 | object [ "tag" .= ("function" :: Text) 88 | , "args" .= args 89 | , "result" .= result 90 | ] 91 | 92 | fun1 :: Value -> Value -> Value 93 | fun1 arg result = function [arg] result 94 | 95 | adt :: Text -> [Value] -> Value 96 | adt name args = 97 | object [ "tag" .= ("adt" :: Text) 98 | , "name" .= name 99 | , "args" .= args 100 | ] 101 | 102 | value :: Text -> Value -> Value 103 | value name typ = 104 | object [ "name" .= name 105 | , "raw" .= ("" :: Text) 106 | , "type" .= typ 107 | ] 108 | 109 | modul :: [Value] -> Value 110 | modul values = 111 | object [ "values" .= values 112 | ] 113 | 114 | 115 | comparisonTests = 116 | TF.testGroup "Types comparison tests" 117 | [ TH.testCase "a -> b -> a == b -> a -> b" 118 | (yieldsRenaming type_const1 type_const2 const_renaming) 119 | , TH.testCase "Int /= String" 120 | (nonCompatible type_int type_string) 121 | , TH.testCase "String /= Int" 122 | (nonCompatible type_string type_int) 123 | , TH.testCase "Renaming typevars in (a -> b) -> [a] -> [b]" 124 | (yieldsRenaming type_map1 type_map2 map_renaming) 125 | , TH.testCase "Map type /= wrong map type" 126 | (nonCompatible type_map1 type_map_wrong) 127 | , TH.testCase "Comparing two different modules" 128 | (yieldsComparison module_2 module_1 module_comparison) 129 | ] 130 | -------------------------------------------------------------------------------- /src/Install/Fetch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Install.Fetch (everything) where 3 | 4 | import Control.Concurrent (forkIO) 5 | import qualified Control.Concurrent.Chan as Chan 6 | import Control.Concurrent.ParallelIO.Local (withPool, parallel) 7 | import Control.Monad.Except (liftIO, throwError) 8 | import qualified Codec.Archive.Zip as Zip 9 | import qualified Data.List as List 10 | import Data.Monoid ((<>)) 11 | import qualified Data.Text as Text 12 | import GHC.IO.Handle (hIsTerminalDevice) 13 | import qualified Network.HTTP.Client as Client 14 | import System.Directory 15 | ( createDirectoryIfMissing, doesDirectoryExist 16 | , getDirectoryContents, renameDirectory 17 | ) 18 | import System.FilePath (()) 19 | import System.IO (stdout) 20 | import Text.PrettyPrint.ANSI.Leijen 21 | ( Doc, (<+>), displayIO, green, plain, red, renderPretty, text ) 22 | 23 | import qualified Elm.Package as Pkg 24 | import qualified Elm.Package.Paths as Path 25 | import qualified CommandLine.Helpers as Cmd 26 | import qualified Manager 27 | import qualified Reporting.Error as Error 28 | import qualified Utils.Http as Http 29 | 30 | 31 | 32 | -- PARALLEL FETCHING 33 | 34 | 35 | everything :: [(Pkg.Name, Pkg.Version)] -> Manager.Manager () 36 | everything packages = 37 | if null packages then return () else everythingHelp packages 38 | 39 | 40 | everythingHelp :: [(Pkg.Name, Pkg.Version)] -> Manager.Manager () 41 | everythingHelp packages = 42 | Cmd.inDir Path.packagesDirectory $ 43 | do eithers <- liftIO $ do 44 | startMessage (length packages) 45 | isTerminal <- hIsTerminalDevice stdout 46 | resultChan <- Chan.newChan 47 | forkIO (printLoop isTerminal resultChan) 48 | withPool 4 $ \pool -> 49 | parallel pool (map (prettyFetch resultChan) packages) 50 | 51 | case sequence eithers of 52 | Right _ -> 53 | liftIO $ putStrLn "" 54 | 55 | Left err -> 56 | throwError err 57 | 58 | 59 | data Result = 60 | Result 61 | { _name :: Pkg.Name 62 | , _vsn :: Pkg.Version 63 | , _either :: Either Error.Error () 64 | } 65 | 66 | 67 | printLoop :: Bool -> Chan.Chan Result -> IO () 68 | printLoop isTerminal resultChan = 69 | do result <- Chan.readChan resultChan 70 | let doc = toDoc result 71 | displayIO stdout $ renderPretty 1 80 $ 72 | if isTerminal then doc else plain doc 73 | printLoop isTerminal resultChan 74 | 75 | 76 | prettyFetch :: Chan.Chan Result -> (Pkg.Name, Pkg.Version) -> IO (Either Error.Error ()) 77 | prettyFetch printChan (name, version) = 78 | do either <- Manager.run $ fetch name version 79 | Chan.writeChan printChan (Result name version either) 80 | return either 81 | 82 | 83 | startMessage :: Int -> IO () 84 | startMessage n = 85 | if n > 0 then 86 | putStrLn "Starting downloads...\n" 87 | 88 | else 89 | return () 90 | 91 | 92 | toDoc :: Result -> Doc 93 | toDoc (Result name version either) = 94 | let 95 | nameDoc = 96 | text $ Pkg.toString name 97 | 98 | versionDoc = 99 | text $ Pkg.versionToString version 100 | 101 | bullet = 102 | case either of 103 | Right _ -> 104 | green (text "●") 105 | 106 | Left _ -> 107 | red (text "✗") 108 | in 109 | text " " <> bullet <+> nameDoc <+> versionDoc <> text "\n" 110 | 111 | 112 | 113 | -- FETCH A PACKAGE 114 | 115 | 116 | fetch :: Pkg.Name -> Pkg.Version -> Manager.Manager () 117 | fetch name@(Pkg.Name user project) version = 118 | ifNotExists name version $ 119 | do Http.send (toZipballUrl name version) extract 120 | files <- liftIO $ getDirectoryContents "." 121 | case List.find (List.isPrefixOf (Text.unpack (user <> "-" <> project))) files of 122 | Nothing -> 123 | throwError $ Error.ZipDownloadFailed name version 124 | 125 | Just dir -> 126 | liftIO $ do 127 | let home = Pkg.toFilePath name 128 | createDirectoryIfMissing True home 129 | renameDirectory dir (home Pkg.versionToString version) 130 | 131 | 132 | toZipballUrl :: Pkg.Name -> Pkg.Version -> String 133 | toZipballUrl name version = 134 | "https://github.com/" ++ Pkg.toUrl name 135 | ++ "/zipball/" ++ Pkg.versionToString version ++ "/" 136 | 137 | 138 | ifNotExists :: Pkg.Name -> Pkg.Version -> Manager.Manager () -> Manager.Manager () 139 | ifNotExists name version task = 140 | do let dir = Pkg.toFilePath name Pkg.versionToString version 141 | exists <- liftIO $ doesDirectoryExist dir 142 | if exists then return () else task 143 | 144 | 145 | extract :: Client.Request -> Client.Manager -> IO () 146 | extract request manager = 147 | do response <- Client.httpLbs request manager 148 | let archive = Zip.toArchive (Client.responseBody response) 149 | Zip.extractFilesFromArchive [] archive 150 | -------------------------------------------------------------------------------- /src/CommandLine/Arguments.hs: -------------------------------------------------------------------------------- 1 | module CommandLine.Arguments (parse) where 2 | 3 | import Control.Applicative ((<|>), optional) 4 | import Control.Monad.Except (throwError) 5 | import qualified Options.Applicative as Opt 6 | import qualified Options.Applicative.Builder as B 7 | import qualified Text.PrettyPrint.ANSI.Leijen as P 8 | 9 | import qualified Bump 10 | import qualified Diff 11 | import qualified Install 12 | import qualified Manager 13 | import qualified Publish 14 | import qualified Elm.Compiler as Compiler 15 | import qualified Elm.Package as Package 16 | import qualified Elm.Package.Paths as Path 17 | import qualified Reporting.Error as Error 18 | 19 | 20 | parse :: IO (Manager.Manager ()) 21 | parse = 22 | Opt.customExecParser (Opt.prefs Opt.showHelpOnError) parser 23 | 24 | 25 | parser :: Opt.ParserInfo (Manager.Manager ()) 26 | parser = 27 | B.info flagParser $ mconcat $ 28 | [ B.fullDesc 29 | , B.progDesc "install and publish elm packages" 30 | , B.header ("elm-package " ++ Package.versionToString Compiler.version) 31 | , B.footerDoc $ Just $ P.nest 2 $ P.vcat $ map P.text $ 32 | [ "To learn more about a particular command run:" 33 | , "elm-package COMMAND --help" 34 | ] 35 | ] 36 | 37 | 38 | -- COMMANDS 39 | 40 | flagParser :: Opt.Parser (Manager.Manager ()) 41 | flagParser = 42 | Opt.hsubparser $ 43 | mconcat 44 | [ Opt.command "install" installInfo 45 | , Opt.command "publish" publishInfo 46 | , Opt.command "bump" bumpInfo 47 | , Opt.command "diff" diffInfo 48 | ] 49 | 50 | 51 | -- BUMP 52 | 53 | bumpInfo :: Opt.ParserInfo (Manager.Manager ()) 54 | bumpInfo = 55 | Opt.info (pure Bump.bump) $ 56 | mconcat 57 | [ Opt.fullDesc 58 | , Opt.progDesc "Bump version numbers based on API changes" 59 | ] 60 | 61 | 62 | -- DIFF 63 | 64 | diffInfo :: Opt.ParserInfo (Manager.Manager ()) 65 | diffInfo = 66 | Opt.info (Diff.diff <$> range) $ 67 | mconcat 68 | [ Opt.fullDesc 69 | , Opt.progDesc "Get differences between two APIs" 70 | ] 71 | where 72 | range = 73 | (Diff.Between <$> package <*> version <*> version) 74 | <|> (Diff.Since <$> version) 75 | <|> (pure Diff.LatestVsActual) 76 | 77 | 78 | -- PUBLISH 79 | 80 | publishInfo :: Opt.ParserInfo (Manager.Manager ()) 81 | publishInfo = 82 | Opt.info (pure Publish.publish) $ 83 | mconcat 84 | [ Opt.fullDesc 85 | , Opt.progDesc "Publish your package to the central catalog" 86 | ] 87 | 88 | 89 | -- INSTALL 90 | 91 | installInfo :: Opt.ParserInfo (Manager.Manager ()) 92 | installInfo = 93 | Opt.info args infoModifier 94 | where 95 | args = 96 | installWith <$> optional package <*> optional version <*> yes 97 | 98 | installWith maybeName maybeVersion autoYes = 99 | case (maybeName, maybeVersion) of 100 | (Nothing, Nothing) -> 101 | Install.install autoYes Install.Everything 102 | 103 | (Just name, Nothing) -> 104 | Install.install autoYes (Install.Latest name) 105 | 106 | (Just name, Just version) -> 107 | Install.install autoYes (Install.Exactly name version) 108 | 109 | (Nothing, Just version) -> 110 | throwError $ Error.BadInstall version 111 | 112 | infoModifier = 113 | mconcat 114 | [ Opt.fullDesc 115 | , Opt.progDesc "Install packages to use locally" 116 | , Opt.footerDoc (Just examples) 117 | ] 118 | 119 | examples = 120 | P.nest 2 $ P.vcat $ map P.text $ 121 | [ "Examples:" 122 | , "elm-package install # everything needed by " ++ Path.description 123 | , "elm-package install elm-lang/html # any version" 124 | , "elm-package install elm-lang/html 1.0.0 # specific version" 125 | ] 126 | 127 | 128 | -- ARGUMENT PARSERS 129 | 130 | package :: Opt.Parser Package.Name 131 | package = 132 | Opt.argument (customReader "PACKAGE" Package.fromString) $ 133 | mconcat 134 | [ Opt.metavar "PACKAGE" 135 | , Opt.help "A specific package name (e.g. elm-lang/html)" 136 | ] 137 | 138 | 139 | version :: Opt.Parser Package.Version 140 | version = 141 | Opt.argument (customReader "VERSION" Package.versionFromString) $ 142 | mconcat 143 | [ Opt.metavar "VERSION" 144 | , Opt.help "Specific version of a package (e.g. 1.2.0)" 145 | ] 146 | 147 | 148 | yes :: Opt.Parser Bool 149 | yes = 150 | Opt.switch $ 151 | mconcat 152 | [ Opt.long "yes" 153 | , Opt.short 'y' 154 | , Opt.help "Reply 'yes' to all automated prompts." 155 | ] 156 | 157 | 158 | customReader :: String -> (String -> Either String a) -> Opt.ReadM a 159 | customReader argType fromString = 160 | let reader arg = 161 | case fromString arg of 162 | Right a -> 163 | Right a 164 | 165 | Left msg -> 166 | Left ("Uh oh, argument \"" ++ arg ++ "\" is not a valid " ++ argType ++ "\n\n" ++ msg) 167 | in 168 | Opt.eitherReader reader 169 | -------------------------------------------------------------------------------- /src/Elm/Package/Constraint.hs: -------------------------------------------------------------------------------- 1 | module Elm.Package.Constraint 2 | ( Constraint 3 | , fromString 4 | , toString 5 | , untilNextMajor 6 | , untilNextMinor 7 | , expand 8 | , defaultElmVersion 9 | , isSatisfied 10 | , check 11 | , errorMessage 12 | ) where 13 | 14 | import qualified Data.Aeson as Json 15 | import qualified Data.Text as Text 16 | 17 | import qualified Elm.Package as Package 18 | import qualified Elm.Compiler as Compiler 19 | 20 | 21 | 22 | -- CONSTRAINTS 23 | 24 | 25 | data Constraint 26 | = Range Package.Version Op Op Package.Version 27 | 28 | 29 | data Op = Less | LessOrEqual 30 | 31 | 32 | 33 | -- CREATE CONSTRAINTS 34 | 35 | 36 | untilNextMajor :: Package.Version -> Constraint 37 | untilNextMajor version = 38 | Range version LessOrEqual Less (Package.bumpMajor version) 39 | 40 | 41 | untilNextMinor :: Package.Version -> Constraint 42 | untilNextMinor version = 43 | Range version LessOrEqual Less (Package.bumpMinor version) 44 | 45 | 46 | expand :: Constraint -> Package.Version -> Constraint 47 | expand constraint@(Range lower lowerOp upperOp upper) version 48 | | version < lower = 49 | Range version LessOrEqual upperOp upper 50 | 51 | | version > upper = 52 | Range lower lowerOp Less (Package.bumpMajor version) 53 | 54 | | otherwise = 55 | constraint 56 | 57 | 58 | 59 | -- ELM CONSTRAINT 60 | 61 | 62 | defaultElmVersion :: Constraint 63 | defaultElmVersion = 64 | if Package._major Compiler.version > 0 65 | then untilNextMajor Compiler.version 66 | else untilNextMinor Compiler.version 67 | 68 | 69 | 70 | -- CHECK IF SATISFIED 71 | 72 | 73 | isSatisfied :: Constraint -> Package.Version -> Bool 74 | isSatisfied constraint version = 75 | case constraint of 76 | Range lower lowerOp upperOp upper -> 77 | isLess lowerOp lower version 78 | && 79 | isLess upperOp version upper 80 | 81 | 82 | isLess :: (Ord a) => Op -> (a -> a -> Bool) 83 | isLess op = 84 | case op of 85 | Less -> 86 | (<) 87 | 88 | LessOrEqual -> 89 | (<=) 90 | 91 | 92 | check :: Constraint -> Package.Version -> Ordering 93 | check constraint version = 94 | case constraint of 95 | Range lower lowerOp upperOp upper -> 96 | if not (isLess lowerOp lower version) then 97 | LT 98 | 99 | else if not (isLess upperOp version upper) then 100 | GT 101 | 102 | else 103 | EQ 104 | 105 | 106 | 107 | -- STRING CONVERSION 108 | 109 | 110 | toString :: Constraint -> String 111 | toString constraint = 112 | case constraint of 113 | Range lower lowerOp upperOp upper -> 114 | unwords 115 | [ Package.versionToString lower 116 | , opToString lowerOp 117 | , "v" 118 | , opToString upperOp 119 | , Package.versionToString upper 120 | ] 121 | 122 | 123 | opToString :: Op -> String 124 | opToString op = 125 | case op of 126 | Less -> "<" 127 | LessOrEqual -> "<=" 128 | 129 | 130 | fromString :: String -> Maybe Constraint 131 | fromString str = 132 | do let (lowerString, rest) = break (==' ') str 133 | lower <- versionFromString lowerString 134 | (lowerOp, rest1) <- takeOp (eatSpace rest) 135 | rest2 <- eatV (eatSpace rest1) 136 | (upperOp, rest3) <- takeOp (eatSpace rest2) 137 | upper <- versionFromString (eatSpace rest3) 138 | return (Range lower lowerOp upperOp upper) 139 | 140 | 141 | eatSpace :: String -> String 142 | eatSpace str = 143 | case str of 144 | ' ' : rest -> rest 145 | _ -> str 146 | 147 | 148 | versionFromString :: String -> Maybe Package.Version 149 | versionFromString = 150 | either (const Nothing) Just . Package.versionFromString 151 | 152 | 153 | takeOp :: String -> Maybe (Op, String) 154 | takeOp str = 155 | case str of 156 | '<' : '=' : rest -> Just (LessOrEqual, rest) 157 | '<' : rest -> Just (Less, rest) 158 | _ -> Nothing 159 | 160 | 161 | eatV :: String -> Maybe String 162 | eatV str = 163 | case str of 164 | 'v' : rest -> Just rest 165 | _ -> Nothing 166 | 167 | 168 | 169 | 170 | -- JSON CONVERSION 171 | 172 | 173 | instance Json.ToJSON Constraint where 174 | toJSON constraint = 175 | Json.toJSON (toString constraint) 176 | 177 | 178 | instance Json.FromJSON Constraint where 179 | parseJSON (Json.String text) = 180 | let rawConstraint = Text.unpack text in 181 | case fromString rawConstraint of 182 | Just constraint -> 183 | return constraint 184 | 185 | Nothing -> 186 | fail $ errorMessage Nothing rawConstraint 187 | 188 | parseJSON _ = 189 | fail "constraint must be a string that looks something like \"1.2.1 <= v < 2.0.0\"." 190 | 191 | 192 | errorMessage :: Maybe String -> String -> String 193 | errorMessage maybeContext rawConstraint = 194 | unlines 195 | [ "Ran into invalid constraint \"" ++ rawConstraint ++ "\"" ++ maybe "" (" for " ++) maybeContext 196 | , "" 197 | , "It should look something like \"1.2.1 <= v < 2.0.0\", with no extra or missing" 198 | , "spaces. The middle letter needs to be a 'v' as well." 199 | , "" 200 | , "Upper and lower bounds are required so that bounds represent the maximum range" 201 | , "known to work. You do not want to promise users your library will work with" 202 | , "4.0.0 that version has not been tested!" 203 | ] -------------------------------------------------------------------------------- /tests/SolverTests.hs: -------------------------------------------------------------------------------- 1 | module SolverTests (solverTests) where 2 | 3 | import Control.Monad.Identity 4 | import Control.Monad.Error 5 | import Control.Monad.Reader 6 | import Control.Monad.State 7 | import Test.HUnit ((@?), Assertion) 8 | import qualified Test.Framework as TF 9 | import qualified Test.Framework.Providers.HUnit as TH 10 | import qualified Utils.ResolveDeps as Deps 11 | import Data.Map (Map) 12 | import qualified Data.Map as Map 13 | import qualified Elm.Internal.Constraint as C 14 | import qualified Elm.Internal.Version as V 15 | import qualified Elm.Internal.Name as N 16 | 17 | 18 | -- SETUP 19 | 20 | type FakeDB = Map N.Name [(V.Version, Deps.Constraints)] 21 | 22 | db1 :: FakeDB 23 | db1 = Map.fromList [ base, transformers, mtl, conduit, http ] 24 | where 25 | base = 26 | (n "base", [ (v "0.1", []), (v "0.2", []), (v "1.0", []), (v "1.1", []) ]) 27 | 28 | transformers = 29 | (n "transformers", [ (v "1.0", [(n "base", c ">=1.0 <2.0")]) ]) 30 | 31 | mtl = 32 | (n "mtl", [ (v "1.0", [ (n "base", c ">=0.2 <1.0") ]) 33 | , (v "2.0", [ (n "base", c ">=0.2 <2.0") 34 | , (n "transformers", c ">=1.0 <2.0") 35 | ]) 36 | ]) 37 | 38 | conduit = 39 | (n "conduit", [ (v "1.0", [ (n "base", c ">=1.0 <1.1") 40 | , (n "http", c ">=2.0 <3.0") 41 | ]) 42 | ]) 43 | 44 | http = 45 | (n "http", [ (v "2.1", [ (n "base", c ">=1.1 <2.0") ]) ]) 46 | 47 | expectSolution :: FakeDB -> N.Name -> V.Version -> Assertion 48 | expectSolution db name version = 49 | do solution <- fromError $ solveFake db name version 50 | isValidSolution db solution @? "Solution should pass sanity check" 51 | 52 | expectNoSolution :: FakeDB -> N.Name -> V.Version -> Assertion 53 | expectNoSolution db name version = 54 | let solution = runIdentity $ runErrorT $ solveFake db name version 55 | in case solution of 56 | Left err -> return () 57 | Right sol -> 58 | do when (isValidSolution db sol) $ putStrLn "FAULTY TESTS: solution is valid!" 59 | False @? ("Unexpected solution " ++ show sol) 60 | 61 | test1 = expectSolution db1 (n "mtl") (v "1.0") 62 | test2 = expectSolution db1 (n "mtl") (v "2.0") 63 | test3 = expectNoSolution db1 (n "conduit") (v "1.0") 64 | 65 | solverTests = 66 | TF.testGroup "Dependency solver tests" 67 | [ TH.testCase "test1" test1 68 | , TH.testCase "test2" test2 69 | , TH.testCase "test3" test3 70 | ] 71 | 72 | 73 | fromError :: ErrorT String Identity a -> IO a 74 | fromError action = 75 | either fail return $ runIdentity (runErrorT action) 76 | 77 | -- CHECK FOR VALIDITY OF SOLUTIONS 78 | 79 | {-| Check whether given solution is really a solution. Supposed to use as 80 | a sanity check for existing tests and solver solutions 81 | -} 82 | isValidSolution :: FakeDB -> [(N.Name, V.Version)] -> Bool 83 | isValidSolution db solution = 84 | all isConsistent solution 85 | where 86 | isConsistent (name, version) = 87 | maybe False id $ do 88 | versions <- Map.lookup name db 89 | constraints <- lookup version versions 90 | return (all isSatisfied constraints) 91 | 92 | isSatisfied (name, constraint) = 93 | maybe False id $ do 94 | version <- lookup name solution 95 | return (C.satisfyConstraint constraint version) 96 | 97 | 98 | -- RUN SOLVER 99 | 100 | -- | Run dependency solver using stub data 101 | solveFake :: FakeDB -> N.Name -> V.Version -> ErrorT String Identity [(N.Name, V.Version)] 102 | solveFake db name version = 103 | do let libraryDb = toLibraryDb db 104 | unreader = runReaderT (Deps.solveForVersion name version) $ 105 | Deps.SolverEnv libraryDb (readConstraints db) 106 | initialState = Deps.SolverState Map.empty 107 | (solved, _) <- runStateT unreader initialState 108 | return $ Map.toList solved 109 | 110 | -- | A function passed to solver which "reads" constraints by name and version 111 | readConstraints :: FakeDB -> N.Name -> V.Version -> ErrorT String Identity Deps.Constraints 112 | readConstraints db name version = 113 | maybe notFound return $ do 114 | versions <- Map.lookup name db 115 | lookup version versions 116 | where 117 | notFound = 118 | throwError $ "Could not find " ++ N.toString name ++ " " ++ V.toString version 119 | 120 | {-| Extract from stub data list of libraries and their version in 121 | format solver expects 122 | -} 123 | toLibraryDb :: FakeDB -> Deps.LibraryDB 124 | toLibraryDb fakeDb = 125 | Map.fromList (map toLibraryEntry (Map.toList fakeDb)) 126 | where 127 | toLibraryEntry (name, details) = 128 | ( N.toString name 129 | , Deps.LibraryInfo (N.toString name) "" (map fst details) 130 | ) 131 | 132 | 133 | -- SETUP HELPERS 134 | -- make it easier to create a FakeDb 135 | 136 | v :: String -> V.Version 137 | v = unsafeUnpackJust "version" . V.fromString 138 | 139 | c :: String -> C.Constraint 140 | c = unsafeUnpackJust "constraint" . C.fromString 141 | 142 | n :: String -> N.Name 143 | n = unsafeUnpackJust "name" . N.fromString . ("a/" ++) 144 | 145 | unsafeUnpackJust :: String -> Maybe a -> a 146 | unsafeUnpackJust msg result = 147 | case result of 148 | Just v -> v 149 | Nothing -> error $ "error unpacking " ++ msg ++ " from string" 150 | 151 | 152 | -------------------------------------------------------------------------------- /src/Catalog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Catalog where 3 | 4 | import Control.Exception (catch, throwIO) 5 | import Control.Monad.Except (throwError) 6 | import Control.Monad.RWS (liftIO, asks) 7 | import Data.Aeson ((.:)) 8 | import qualified Data.Aeson as Json 9 | import qualified Data.Binary as Binary 10 | import qualified Data.ByteString.Lazy as LBS 11 | import qualified Data.Time.Clock as Time 12 | import Data.Version (showVersion) 13 | import Network.HTTP 14 | import qualified Network.HTTP.Client as Client 15 | import qualified Network.HTTP.Client.MultipartFormData as Multi 16 | import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile) 17 | import System.FilePath ((), dropFileName) 18 | import System.IO.Error (isDoesNotExistError) 19 | 20 | import qualified Elm.Docs as Docs 21 | import qualified Elm.Package.Description as Desc 22 | import qualified Elm.Package as Package 23 | import qualified Elm.Package.Paths as P 24 | import qualified Manager 25 | import qualified Paths_elm_package as This 26 | import qualified Reporting.Error as Error 27 | import qualified Utils.Http as Http 28 | 29 | 30 | 31 | -- MAKE URL 32 | 33 | 34 | catalog :: String -> [(String,String)] -> Manager.Manager String 35 | catalog path vars = 36 | do domain <- asks Manager.catalog 37 | return $ domain ++ "/" ++ path ++ "?" ++ urlEncodeVars (version : vars) 38 | where 39 | version = ("elm-package-version", showVersion This.version) 40 | 41 | 42 | 43 | -- EASY REQUESTS 44 | 45 | 46 | versions :: Package.Name -> Manager.Manager (Maybe [Package.Version]) 47 | versions name = 48 | get "versions" [("name", Package.toString name)] 49 | 50 | 51 | permissions :: Package.Name -> Manager.Manager Bool 52 | permissions name = 53 | get "permissions" [("name", Package.toString name)] 54 | 55 | 56 | get :: (Binary.Binary a) => String -> [(String,String)] -> Manager.Manager a 57 | get path vars = 58 | do url <- catalog path vars 59 | Http.send url $ \request manager -> 60 | do response <- Client.httpLbs request manager 61 | return $ Binary.decode $ Client.responseBody response 62 | 63 | 64 | 65 | -- FANCIER REQUESTS 66 | 67 | 68 | allPackages :: Maybe Time.UTCTime -> Manager.Manager (Maybe [(Package.Name, [Package.Version])]) 69 | allPackages maybeTime = 70 | do url <- catalog "all-packages" vars 71 | Http.send url $ \request manager -> do 72 | response <- Client.httpLbs request manager 73 | case Json.eitherDecode (Client.responseBody response) of 74 | Left _ -> 75 | return Nothing 76 | 77 | Right summaries -> 78 | return $ Just $ map (\(PackageSummary s) -> s) summaries 79 | where 80 | vars = 81 | case maybeTime of 82 | Nothing -> [] 83 | Just time -> [("since", show time)] 84 | 85 | 86 | newtype PackageSummary = PackageSummary (Package.Name, [Package.Version]) 87 | 88 | 89 | instance Json.FromJSON PackageSummary where 90 | parseJSON (Json.Object obj) = 91 | do name <- obj .: "name" 92 | versions <- obj .: "versions" 93 | return (PackageSummary (name, versions)) 94 | 95 | parseJSON _ = 96 | fail "package summary must be an object" 97 | 98 | 99 | register :: Package.Name -> Package.Version -> Manager.Manager () 100 | register name version = 101 | do url <- catalog "register" vars 102 | Http.send url $ \request manager -> do 103 | request' <- Multi.formDataBody files request 104 | let request'' = request' { Client.responseTimeout = Nothing } 105 | Client.httpLbs request'' manager 106 | return () 107 | where 108 | vars = 109 | [ ("name", Package.toString name) 110 | , ("version", Package.versionToString version) 111 | ] 112 | 113 | files = 114 | [ Multi.partFileSource "documentation" P.documentation 115 | , Multi.partFileSource "description" P.description 116 | , Multi.partFileSource "readme" "README.md" 117 | ] 118 | 119 | 120 | 121 | -- GET JSON 122 | 123 | 124 | description :: Package.Name -> Package.Version -> Manager.Manager Desc.Description 125 | description name version = 126 | getJson "description" P.description name version 127 | 128 | 129 | documentation :: Package.Name -> Package.Version -> Manager.Manager [Docs.Documentation] 130 | documentation name version = 131 | getJson "documentation" "documentation.json" name version 132 | 133 | 134 | getJson :: (Json.FromJSON a) => String -> FilePath -> Package.Name -> Package.Version -> Manager.Manager a 135 | getJson metadata metadataPath name version = 136 | do cacheDir <- asks Manager.cacheDirectory 137 | let fullMetadataPath = 138 | cacheDir Package.toFilePath name Package.versionToString version metadataPath 139 | 140 | exists <- liftIO (doesFileExist fullMetadataPath) 141 | 142 | content <- 143 | case exists of 144 | True -> 145 | liftIO (LBS.readFile fullMetadataPath) 146 | 147 | False -> 148 | do url <- catalog metadata [("name", Package.toString name), ("version", Package.versionToString version)] 149 | Http.send url $ \request manager -> 150 | do response <- Client.httpLbs request manager 151 | createDirectoryIfMissing True (dropFileName fullMetadataPath) 152 | LBS.writeFile fullMetadataPath (Client.responseBody response) 153 | return (Client.responseBody response) 154 | 155 | case Json.eitherDecode content of 156 | Right value -> 157 | return value 158 | 159 | Left problem -> 160 | do liftIO $ removeIfExists fullMetadataPath 161 | throwError $ Error.CorruptJson metadataPath name version problem 162 | 163 | 164 | removeIfExists :: FilePath -> IO () 165 | removeIfExists path = 166 | let 167 | handleExists e = 168 | if isDoesNotExistError e then return () else throwIO e 169 | in 170 | removeFile path `catch` handleExists 171 | -------------------------------------------------------------------------------- /src/Install/Solver.hs: -------------------------------------------------------------------------------- 1 | module Install.Solver (solve) where 2 | 3 | import Control.Monad (forM) 4 | import Control.Monad.Except (throwError) 5 | import Control.Monad.State (StateT, evalStateT, runStateT) 6 | import qualified Data.List as List 7 | import qualified Data.Map as Map 8 | import qualified Data.Maybe as Maybe 9 | 10 | import qualified Elm.Compiler as Compiler 11 | import qualified Elm.Package.Constraint as C 12 | import qualified Elm.Package as Package 13 | import qualified Elm.Package.Solution as S 14 | import qualified Manager 15 | import qualified Reporting.Error as Error 16 | import qualified Store 17 | 18 | 19 | 20 | -- ACTUALLY TRY TO SOLVE 21 | 22 | 23 | solve :: C.Constraint -> [(Package.Name, C.Constraint)] -> Manager.Manager S.Solution 24 | solve elmConstraint constraints = 25 | case C.check elmConstraint Compiler.version of 26 | LT -> 27 | throwError $ Error.BadElmVersion Compiler.version False elmConstraint 28 | 29 | GT -> 30 | throwError $ Error.BadElmVersion Compiler.version True elmConstraint 31 | 32 | EQ -> 33 | do store <- Store.initialStore 34 | (maybeSolution, newStore) <- runStateT (exploreConstraints constraints) store 35 | case maybeSolution of 36 | Just solution -> 37 | return solution 38 | 39 | Nothing -> 40 | do hints <- evalStateT (mapM incompatibleWithCompiler constraints) newStore 41 | throwError (Error.ConstraintsHaveNoSolution (Maybe.catMaybes hints)) 42 | 43 | 44 | 45 | -- EXPLORE CONSTRAINTS 46 | 47 | 48 | type Explorer a = 49 | StateT Store.Store Manager.Manager a 50 | 51 | 52 | type Packages = 53 | Map.Map Package.Name [Package.Version] 54 | 55 | 56 | exploreConstraints :: [(Package.Name, C.Constraint)] -> Explorer (Maybe S.Solution) 57 | exploreConstraints constraints = 58 | do maybeInitialPackages <- addConstraints Map.empty constraints 59 | let initialPackages = maybe Map.empty id maybeInitialPackages 60 | explorePackages Map.empty initialPackages 61 | 62 | 63 | explorePackages :: S.Solution -> Packages -> Explorer (Maybe S.Solution) 64 | explorePackages solution availablePackages = 65 | case Map.minViewWithKey availablePackages of 66 | Nothing -> 67 | return (Just solution) 68 | 69 | Just ((name, versions), remainingPackages) -> 70 | exploreVersionList name versions solution remainingPackages 71 | 72 | 73 | exploreVersionList :: Package.Name -> [Package.Version] -> S.Solution -> Packages -> Explorer (Maybe S.Solution) 74 | exploreVersionList name versions solution remainingPackages = 75 | go (reverse (List.sort versions)) 76 | where 77 | go versions = 78 | case versions of 79 | [] -> 80 | return Nothing 81 | 82 | version : rest -> 83 | do maybeSolution <- exploreVersion name version solution remainingPackages 84 | case maybeSolution of 85 | Nothing -> go rest 86 | answer -> return answer 87 | 88 | 89 | exploreVersion :: Package.Name -> Package.Version -> S.Solution -> Packages -> Explorer (Maybe S.Solution) 90 | exploreVersion name version solution remainingPackages = 91 | do (elmConstraint, constraints) <- Store.getConstraints name version 92 | if C.isSatisfied elmConstraint Compiler.version 93 | then explore constraints 94 | else return Nothing 95 | 96 | where 97 | explore constraints = 98 | do let (overlappingConstraints, newConstraints) = 99 | List.partition (\(name, _) -> Map.member name solution) constraints 100 | 101 | case all (satisfiedBy solution) overlappingConstraints of 102 | False -> 103 | return Nothing 104 | 105 | True -> 106 | do maybePackages <- addConstraints remainingPackages newConstraints 107 | case maybePackages of 108 | Nothing -> return Nothing 109 | Just extendedPackages -> 110 | explorePackages (Map.insert name version solution) extendedPackages 111 | 112 | 113 | satisfiedBy :: S.Solution -> (Package.Name, C.Constraint) -> Bool 114 | satisfiedBy solution (name, constraint) = 115 | case Map.lookup name solution of 116 | Nothing -> 117 | False 118 | 119 | Just version -> 120 | C.isSatisfied constraint version 121 | 122 | 123 | addConstraints :: Packages -> [(Package.Name, C.Constraint)] -> Explorer (Maybe Packages) 124 | addConstraints packages constraints = 125 | case constraints of 126 | [] -> 127 | return (Just packages) 128 | 129 | (name, constraint) : rest -> 130 | do versions <- Store.getVersions name 131 | case filter (C.isSatisfied constraint) versions of 132 | [] -> 133 | return Nothing 134 | 135 | vs -> 136 | addConstraints (Map.insert name vs packages) rest 137 | 138 | 139 | 140 | -- FAILURE HINTS 141 | 142 | 143 | incompatibleWithCompiler :: (Package.Name, C.Constraint) -> Explorer (Maybe Error.Hint) 144 | incompatibleWithCompiler (name, constraint) = 145 | do allVersions <- Store.getVersions name 146 | let presentAndFutureVersions = 147 | filter (\vsn -> C.check constraint vsn /= LT) allVersions 148 | 149 | compilerConstraints <- 150 | forM presentAndFutureVersions $ \vsn -> 151 | do elmConstraint <- fst <$> Store.getConstraints name vsn 152 | return (vsn, elmConstraint) 153 | 154 | case filter (isCompatible . snd) compilerConstraints of 155 | [] -> 156 | return $ Just $ Error.IncompatiblePackage name 157 | 158 | compatibleVersions -> 159 | case filter (C.isSatisfied constraint . fst) compilerConstraints of 160 | [] -> 161 | return $ Just $ Error.EmptyConstraint name constraint 162 | 163 | pairs -> 164 | if any (isCompatible . snd) pairs then 165 | return Nothing 166 | 167 | else 168 | return $ Just $ 169 | Error.IncompatibleConstraint name constraint $ 170 | maximum (map fst compatibleVersions) 171 | 172 | 173 | isCompatible :: C.Constraint -> Bool 174 | isCompatible constraint = 175 | C.isSatisfied constraint Compiler.version -------------------------------------------------------------------------------- /src/Diff/Display.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Diff.Display (packageChanges) where 3 | 4 | import Data.Char (isDigit) 5 | import qualified Data.Map as Map 6 | import qualified Data.Text as Text 7 | import Data.Text (Text) 8 | import Text.PrettyPrint ((<+>), (<>)) 9 | import qualified Text.PrettyPrint as P 10 | 11 | import qualified Elm.Compiler.Type as Type 12 | import qualified Diff.Compare as D 13 | 14 | 15 | 16 | -- DISPLAY DIFF 17 | 18 | 19 | packageChanges :: D.PackageChanges -> String 20 | packageChanges pkgChanges@(D.PackageChanges added changed removed) = 21 | "This is a " ++ show (D.packageChangeMagnitude pkgChanges) ++ " change.\n\n" 22 | ++ showAdded 23 | ++ showRemoved 24 | ++ showChanged 25 | where 26 | showRemoved = 27 | if null removed then 28 | "" 29 | else 30 | "------ Removed modules - MAJOR ------\n" 31 | ++ concatMap ((++) "\n " . Text.unpack) removed 32 | ++ "\n\n\n" 33 | 34 | showAdded = 35 | if null added then 36 | "" 37 | else 38 | "------ Added modules - MINOR ------\n" 39 | ++ concatMap ((++) "\n " . Text.unpack) added 40 | ++ "\n\n\n" 41 | 42 | showChanged = 43 | if Map.null changed then 44 | "" 45 | else 46 | concatMap moduleChanges (Map.toList changed) 47 | 48 | 49 | moduleChanges :: (Text, D.ModuleChanges) -> String 50 | moduleChanges (name, changes) = 51 | "------ Changes to module " ++ Text.unpack name ++ " - " ++ show magnitude ++ " ------" 52 | ++ display "Added" adtAdd aliasAdd valueAdd 53 | ++ display "Removed" adtRemove aliasRemove valueRemove 54 | ++ display "Changed" adtChange aliasChange valueChange 55 | ++ "\n\n\n" 56 | where 57 | magnitude = 58 | D.moduleChangeMagnitude changes 59 | 60 | (adtAdd, adtChange, adtRemove) = 61 | changesToDocs unionDoc (D.adtChanges changes) 62 | 63 | (aliasAdd, aliasChange, aliasRemove) = 64 | changesToDocs aliasDoc (D.aliasChanges changes) 65 | 66 | (valueAdd, valueChange, valueRemove) = 67 | changesToDocs valueDoc (D.valueChanges changes) 68 | 69 | 70 | changesToDocs :: (k -> v -> P.Doc) -> D.Changes k v -> ([P.Doc], [P.Doc], [P.Doc]) 71 | changesToDocs toDoc (D.Changes added changed removed) = 72 | ( map indented (Map.toList added) 73 | , map diffed (Map.toList changed) 74 | , map indented (Map.toList removed) 75 | ) 76 | where 77 | indented (name, value) = 78 | P.text " " <> toDoc name value 79 | 80 | diffed (name, (oldValue, newValue)) = 81 | P.vcat 82 | [ P.text " - " <> toDoc name oldValue 83 | , P.text " + " <> toDoc name newValue 84 | , P.text "" 85 | ] 86 | 87 | 88 | display :: String -> [P.Doc] -> [P.Doc] -> [P.Doc] -> String 89 | display categoryName adts aliases values 90 | | null (adts ++ aliases ++ values) = "" 91 | | otherwise = 92 | P.renderStyle (P.style { P.lineLength = 80 }) $ 93 | P.vcat $ 94 | P.text "" : P.text category : adts ++ aliases ++ values 95 | where 96 | category = 97 | "\n " ++ categoryName ++ ":" 98 | 99 | 100 | 101 | -- HELPER 102 | 103 | 104 | chunk :: Text -> P.Doc 105 | chunk txt = 106 | P.text (Text.unpack txt) 107 | 108 | 109 | 110 | -- PRETTY PRINTING 111 | 112 | 113 | unionDoc :: Text -> ([Text], Map.Map Text [Type.Type]) -> P.Doc 114 | unionDoc name (tvars, ctors) = 115 | P.hang setup 4 (P.sep (zipWith (<+>) separators ctorDocs)) 116 | where 117 | setup = 118 | P.text "type" <+> chunk name <+> P.hsep (map chunk tvars) 119 | 120 | separators = 121 | map P.text ("=" : repeat "|") 122 | 123 | ctorDocs = 124 | map ctorDoc (Map.toList ctors) 125 | 126 | ctorDoc (ctor, tipes) = 127 | P.hsep (chunk ctor : map parenDoc tipes) 128 | 129 | 130 | aliasDoc :: Text -> ([Text], Type.Type) -> P.Doc 131 | aliasDoc name (tvars, tipe) = 132 | P.hang (setup <+> P.equals) 4 (typeDoc tipe) 133 | where 134 | setup = 135 | P.text "type" <+> P.text "alias" <+> chunk name <+> P.hsep (map chunk tvars) 136 | 137 | 138 | valueDoc :: Text -> Type.Type -> P.Doc 139 | valueDoc name tipe = 140 | chunk name <+> P.colon <+> typeDoc tipe 141 | 142 | 143 | parenDoc = generalTypeDoc True 144 | typeDoc = generalTypeDoc False 145 | 146 | generalTypeDoc :: Bool -> Type.Type -> P.Doc 147 | generalTypeDoc parens tipe = 148 | case tipe of 149 | Type.Var x -> 150 | chunk x 151 | 152 | Type.Type name -> 153 | chunk name 154 | 155 | Type.Lambda t t' -> 156 | let (args, result) = collectLambdas [t] t' 157 | in 158 | (if parens then P.parens else id) $ 159 | foldr arrow (typeDoc result) args 160 | 161 | Type.App t ts -> 162 | case t : ts of 163 | [ Type.Type name, tipe ] 164 | | name == "_List" -> 165 | P.lbrack <> typeDoc tipe <> P.rbrack 166 | 167 | Type.Type name : types 168 | | Text.isPrefixOf "_Tuple" name && Text.all isDigit (Text.drop 6 name) -> 169 | P.parens (P.hsep (P.punctuate P.comma (map typeDoc types))) 170 | 171 | types -> 172 | (if parens then P.parens else id) $ 173 | P.hsep (map parenDoc types) 174 | 175 | Type.Record fields maybeExt -> 176 | P.sep [ P.hang start 2 fieldDocs, P.rbrace ] 177 | where 178 | start = 179 | case maybeExt of 180 | Nothing -> P.lbrace 181 | Just ext -> P.lbrace <+> typeDoc ext <+> P.text "|" 182 | 183 | fieldDocs = 184 | P.sep (P.punctuate P.comma (map fieldDoc fields)) 185 | 186 | fieldDoc (name, tipe) = 187 | chunk name <+> P.colon <+> typeDoc tipe 188 | 189 | 190 | arrow :: Type.Type -> P.Doc -> P.Doc 191 | arrow arg result = 192 | argDoc <+> P.text "->" <+> result 193 | where 194 | argDoc = 195 | case arg of 196 | Type.Lambda _ _ -> P.parens (typeDoc arg) 197 | _ -> typeDoc arg 198 | 199 | 200 | collectLambdas :: [Type.Type] -> Type.Type -> ([Type.Type], Type.Type) 201 | collectLambdas args result = 202 | case result of 203 | Type.Lambda t t' -> collectLambdas (t:args) t' 204 | _ -> (reverse args, result) 205 | 206 | -------------------------------------------------------------------------------- /src/Bump.hs: -------------------------------------------------------------------------------- 1 | module Bump where 2 | 3 | import Control.Monad.Except (liftIO, throwError) 4 | import qualified Data.List as List 5 | 6 | import qualified Catalog 7 | import qualified CommandLine.Helpers as Cmd 8 | import qualified Diff.Compare as Diff 9 | import qualified Diff.Magnitude as Diff 10 | import qualified Docs 11 | import qualified Elm.Docs as Docs 12 | import qualified Elm.Package.Description as Desc 13 | import qualified Elm.Package as Package 14 | import qualified Elm.Package.Paths as Path 15 | import qualified Manager 16 | import qualified Reporting.Error as Error 17 | 18 | 19 | bump :: Manager.Manager () 20 | bump = 21 | do description <- Desc.read Error.CorruptDescription Path.description 22 | let name = Desc.name description 23 | let statedVersion = Desc.version description 24 | 25 | newDocs <- Docs.generate name 26 | 27 | maybeVersions <- Catalog.versions name 28 | case maybeVersions of 29 | Nothing -> 30 | validateInitialVersion description 31 | 32 | Just publishedVersions -> 33 | let 34 | baseVersions = 35 | map (\(old, _, _) -> old) (validBumps publishedVersions) 36 | in 37 | if statedVersion `elem` baseVersions then 38 | suggestVersion newDocs name statedVersion description 39 | else 40 | throwError $ Error.Unbumpable statedVersion $ 41 | map head (List.group (List.sort baseVersions)) 42 | 43 | return () 44 | 45 | 46 | data Validity 47 | = Valid 48 | | Invalid 49 | | Changed Package.Version 50 | 51 | 52 | validateInitialVersion :: Desc.Description -> Manager.Manager Validity 53 | validateInitialVersion description = 54 | do Cmd.out explanation 55 | if Desc.version description == Package.initialVersion 56 | then Cmd.out goodMsg >> return Valid 57 | else changeVersion badMsg description Package.initialVersion 58 | where 59 | explanation = 60 | unlines 61 | [ "This package has never been published before. Here's how things work:" 62 | , "" 63 | , " * Versions all have exactly three parts: MAJOR.MINOR.PATCH" 64 | , "" 65 | , " * All packages start with initial version " ++ Package.versionToString Package.initialVersion 66 | , "" 67 | , " * Versions are incremented based on how the API changes:" 68 | , "" 69 | , " PATCH - the API is the same, no risk of breaking code" 70 | , " MINOR - values have been added, existing values are unchanged" 71 | , " MAJOR - existing values have been changed or removed" 72 | , "" 73 | , " * I will bump versions for you, automatically enforcing these rules" 74 | , "" 75 | ] 76 | 77 | goodMsg = 78 | "The version number in " ++ Path.description ++ " is correct so you are all set!" 79 | 80 | badMsg = 81 | concat 82 | [ "It looks like the version in " ++ Path.description ++ " has been changed though!\n" 83 | , "Would you like me to change it back to " ++ Package.versionToString Package.initialVersion ++ "? [Y/n] " 84 | ] 85 | 86 | 87 | changeVersion :: String -> Desc.Description -> Package.Version -> Manager.Manager Validity 88 | changeVersion explanation description newVersion = 89 | do liftIO $ putStr explanation 90 | yes <- liftIO Cmd.yesOrNo 91 | case yes of 92 | False -> do 93 | Cmd.out "Okay, no changes were made." 94 | return Invalid 95 | 96 | True -> do 97 | liftIO $ Desc.write (description { Desc.version = newVersion }) 98 | Cmd.out $ "Version changed to " ++ Package.versionToString newVersion ++ "." 99 | return (Changed newVersion) 100 | 101 | 102 | suggestVersion 103 | :: [Docs.Documentation] 104 | -> Package.Name 105 | -> Package.Version 106 | -> Desc.Description 107 | -> Manager.Manager Validity 108 | suggestVersion newDocs name version description = 109 | do changes <- Diff.computeChanges newDocs name version 110 | let newVersion = Diff.bumpBy changes version 111 | changeVersion (infoMsg changes newVersion) description newVersion 112 | 113 | where 114 | infoMsg changes newVersion = 115 | let old = Package.versionToString version 116 | new = Package.versionToString newVersion 117 | magnitude = show (Diff.packageChangeMagnitude changes) 118 | in 119 | concat 120 | [ "Based on your new API, this should be a ", magnitude, " change (", old, " => ", new, ")\n" 121 | , "Bail out of this command and run 'elm-package diff' for a full explanation.\n" 122 | , "\n" 123 | , "Should I perform the update (", old, " => ", new, ") in ", Path.description, "? [Y/n] " 124 | ] 125 | 126 | 127 | validateVersion 128 | :: [Docs.Documentation] 129 | -> Package.Name 130 | -> Package.Version 131 | -> [Package.Version] 132 | -> Manager.Manager Validity 133 | validateVersion newDocs name statedVersion publishedVersions = 134 | case List.find (\(_ ,new, _) -> statedVersion == new) bumps of 135 | Nothing -> 136 | if elem statedVersion publishedVersions then 137 | throwError $ Error.AlreadyPublished statedVersion 138 | 139 | else 140 | throwError $ Error.InvalidBump statedVersion (last publishedVersions) 141 | 142 | Just (old, new, magnitude) -> 143 | do changes <- Diff.computeChanges newDocs name old 144 | let realNew = Diff.bumpBy changes old 145 | case new == realNew of 146 | False -> 147 | throwError $ Error.BadBump old new magnitude realNew $ 148 | Diff.packageChangeMagnitude changes 149 | 150 | True -> 151 | do Cmd.out (looksGood old new magnitude) 152 | return Valid 153 | 154 | where 155 | bumps = 156 | validBumps publishedVersions 157 | 158 | looksGood old new magnitude = 159 | "Version number " ++ Package.versionToString new ++ " verified (" ++ show magnitude 160 | ++ " change, " ++ Package.versionToString old ++ " => " ++ Package.versionToString new ++ ")" 161 | 162 | 163 | 164 | -- VALID BUMPS 165 | 166 | 167 | validBumps :: [Package.Version] -> [(Package.Version, Package.Version, Diff.Magnitude)] 168 | validBumps publishedVersions = 169 | [ (majorPoint, Package.bumpMajor majorPoint, Diff.MAJOR) ] 170 | ++ map (\v -> (v, Package.bumpMinor v, Diff.MINOR)) minorPoints 171 | ++ map (\v -> (v, Package.bumpPatch v, Diff.PATCH)) patchPoints 172 | where 173 | patchPoints = Package.filterLatest Package.majorAndMinor publishedVersions 174 | minorPoints = Package.filterLatest Package._major publishedVersions 175 | majorPoint = head publishedVersions 176 | 177 | -------------------------------------------------------------------------------- /src/Install.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Install where 3 | 4 | import Control.Monad.Except (liftIO, throwError) 5 | import Control.Monad 6 | import qualified Data.List as List 7 | import qualified Data.Map as Map 8 | import System.Directory (createDirectoryIfMissing, doesFileExist, removeDirectoryRecursive) 9 | import System.FilePath (()) 10 | 11 | import qualified CommandLine.Helpers as Cmd 12 | import qualified Elm.Package as Package 13 | import qualified Elm.Package.Constraint as Constraint 14 | import qualified Elm.Package.Description as Desc 15 | import qualified Elm.Package.Paths as Path 16 | import qualified Elm.Package.Solution as Solution 17 | import qualified Install.Fetch as Fetch 18 | import qualified Install.Plan as Plan 19 | import qualified Install.Solver as Solver 20 | import qualified Manager 21 | import qualified Reporting.Error as Error 22 | import qualified Store 23 | 24 | 25 | 26 | data Args 27 | = Everything 28 | | Latest Package.Name 29 | | Exactly Package.Name Package.Version 30 | 31 | 32 | install :: Bool -> Args -> Manager.Manager () 33 | install autoYes args = 34 | do exists <- liftIO (doesFileExist Path.description) 35 | 36 | description <- 37 | if exists then 38 | Desc.read Error.CorruptDescription Path.description 39 | else 40 | initialDescription 41 | 42 | case args of 43 | Everything -> 44 | upgrade autoYes description 45 | 46 | Latest name -> 47 | do version <- latestVersion name 48 | newDescription <- addConstraint autoYes name version description 49 | upgrade autoYes newDescription 50 | 51 | Exactly name version -> 52 | do newDescription <- addConstraint autoYes name version description 53 | upgrade autoYes newDescription 54 | 55 | 56 | 57 | -- INSTALL EVERYTHING 58 | 59 | 60 | upgrade :: Bool -> Desc.Description -> Manager.Manager () 61 | upgrade autoYes desc = 62 | do newSolution <- Solver.solve (Desc.elmVersion desc) (Desc.dependencies desc) 63 | 64 | exists <- liftIO (doesFileExist Path.solvedDependencies) 65 | 66 | oldSolution <- 67 | if exists then 68 | Solution.read Error.CorruptSolution Path.solvedDependencies 69 | else 70 | return Map.empty 71 | 72 | let plan = Plan.create oldSolution newSolution 73 | 74 | approve <- liftIO (getApproval autoYes plan) 75 | 76 | if approve 77 | then runPlan newSolution plan 78 | else liftIO $ putStrLn "Okay, I did not change anything!" 79 | 80 | 81 | getApproval :: Bool -> Plan.Plan -> IO Bool 82 | getApproval autoYes plan = 83 | case autoYes || Plan.isEmpty plan of 84 | True -> 85 | return True 86 | 87 | False -> 88 | do putStrLn "Some new packages are needed. Here is the upgrade plan." 89 | putStrLn (Plan.display plan) 90 | putStr "Do you approve of this plan? [Y/n] " 91 | Cmd.yesOrNo 92 | 93 | 94 | runPlan :: Solution.Solution -> Plan.Plan -> Manager.Manager () 95 | runPlan solution plan = 96 | do let installs = 97 | Map.toList (Plan.installs plan) 98 | ++ Map.toList (Map.map snd (Plan.upgrades plan)) 99 | 100 | let removals = 101 | Map.toList (Plan.removals plan) 102 | ++ Map.toList (Map.map fst (Plan.upgrades plan)) 103 | 104 | -- ensure we have the stuff directory before doing anything else 105 | liftIO (createDirectoryIfMissing True Path.stuffDirectory) 106 | 107 | -- fetch new dependencies 108 | Fetch.everything installs 109 | 110 | -- try to build new dependencies 111 | liftIO (Solution.write Path.solvedDependencies solution) 112 | 113 | -- remove dependencies that are not needed 114 | Cmd.inDir Path.packagesDirectory $ 115 | forM_ removals $ \(name, version) -> 116 | liftIO $ 117 | removeDirectoryRecursive (Package.toFilePath name Package.versionToString version) 118 | 119 | liftIO $ putStrLn "Packages configured successfully!" 120 | 121 | 122 | 123 | -- MODIFY DESCRIPTION 124 | 125 | 126 | latestVersion :: Package.Name -> Manager.Manager Package.Version 127 | latestVersion name = 128 | do versionCache <- Store.readVersionCache 129 | case Map.lookup name versionCache of 130 | Just versions -> 131 | return $ maximum versions 132 | 133 | Nothing -> 134 | throwError $ Error.PackageNotFound name $ 135 | Error.nearbyNames name (Map.keys versionCache) 136 | 137 | 138 | addConstraint :: Bool -> Package.Name -> Package.Version -> Desc.Description -> Manager.Manager Desc.Description 139 | addConstraint autoYes name version description = 140 | case List.lookup name (Desc.dependencies description) of 141 | Nothing -> 142 | addNewDependency autoYes name version description 143 | 144 | Just constraint -> 145 | if Constraint.isSatisfied constraint version then 146 | return description 147 | 148 | else 149 | throwError $ Error.AddTrickyConstraint name version constraint 150 | 151 | 152 | addNewDependency :: Bool -> Package.Name -> Package.Version -> Desc.Description -> Manager.Manager Desc.Description 153 | addNewDependency autoYes name version description = 154 | do confirm <- 155 | case autoYes of 156 | True -> return True 157 | False -> 158 | do answer <- liftIO confirmNewAddition 159 | liftIO (putStrLn "") 160 | return answer 161 | 162 | case confirm of 163 | False -> 164 | do liftIO $ putStrLn noConfirmation 165 | return description 166 | True -> 167 | do let newDescription = description { Desc.dependencies = newConstraints } 168 | liftIO $ Desc.write newDescription 169 | return newDescription 170 | where 171 | newConstraint = 172 | Constraint.untilNextMajor version 173 | 174 | newConstraints = 175 | (name, newConstraint) : Desc.dependencies description 176 | 177 | noConfirmation = 178 | "Cannot install the new package unless it appears in " ++ Path.description ++ ".\n" ++ 179 | "If you do not like the constraint I suggested, change it manually and then run:\n" ++ 180 | "\n elm-package install\n\n" ++ 181 | "This will install everything listed in " ++ Path.description ++ "." 182 | 183 | confirmNewAddition = 184 | do putStrLn $ 185 | "To install " ++ Package.toString name ++ " I would like to add the following\n" 186 | ++ "dependency to " ++ Path.description ++ ":\n\n " 187 | ++ showDependency name newConstraint 188 | ++ "\n" 189 | 190 | putStr $ "May I add that to " ++ Path.description ++ " for you? [Y/n] " 191 | Cmd.yesOrNo 192 | 193 | 194 | showDependency :: Package.Name -> Constraint.Constraint -> String 195 | showDependency name constraint = 196 | show (Package.toString name) ++ ": " ++ show (Constraint.toString constraint) 197 | 198 | 199 | initialDescription :: Manager.Manager Desc.Description 200 | initialDescription = 201 | do let core = Package.Name "elm-lang" "core" 202 | let html = Package.Name "elm-lang" "html" 203 | coreVersion <- latestVersion core 204 | htmlVersion <- latestVersion html 205 | let desc = Desc.defaultDescription { 206 | Desc.dependencies = 207 | [ (core, Constraint.untilNextMajor coreVersion) 208 | , (html, Constraint.untilNextMajor htmlVersion) 209 | ] 210 | } 211 | liftIO (Desc.write desc) 212 | return desc 213 | -------------------------------------------------------------------------------- /src/Elm/Package/Description.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Elm.Package.Description 4 | ( Description(..) 5 | , defaultDescription 6 | , read, write 7 | ) 8 | where 9 | 10 | import Prelude hiding (read) 11 | import Control.Applicative ((<|>)) 12 | import Control.Arrow (first) 13 | import Control.Monad (forM, when) 14 | import Control.Monad.Error.Class (MonadError, throwError) 15 | import Control.Monad.Trans (MonadIO, liftIO) 16 | import Data.Aeson 17 | import Data.Aeson.Types (Parser, parseEither) 18 | import Data.Aeson.Encode.Pretty (encodePretty', defConfig, confCompare, keyOrder) 19 | import qualified Data.ByteString.Lazy.Char8 as BS 20 | import qualified Data.HashMap.Strict as Map 21 | import qualified Data.List as List 22 | import qualified Data.Text as T 23 | 24 | import qualified Elm.Compiler.Module as Module 25 | import qualified Elm.Package as Package 26 | import qualified Elm.Package.Constraint as C 27 | import qualified Elm.Package.Paths as Path 28 | import Elm.Utils ((|>)) 29 | 30 | 31 | 32 | -- DESCRIPTION 33 | 34 | 35 | data Description = Description 36 | { name :: Package.Name 37 | , repo :: String 38 | , version :: Package.Version 39 | , elmVersion :: C.Constraint 40 | , summary :: String 41 | , license :: String 42 | , sourceDirs :: [FilePath] 43 | , exposed :: [Module.Raw] 44 | , natives :: Bool 45 | , dependencies :: [(Package.Name, C.Constraint)] 46 | } 47 | 48 | 49 | defaultDescription :: Description 50 | defaultDescription = 51 | Description 52 | { name = Package.Name "user" "project" 53 | , repo = "https://github.com/user/project.git" 54 | , version = Package.initialVersion 55 | , elmVersion = C.defaultElmVersion 56 | , summary = "helpful summary of your project, less than 80 characters" 57 | , license = "BSD3" 58 | , sourceDirs = [ "." ] 59 | , exposed = [] 60 | , natives = False 61 | , dependencies = [] 62 | } 63 | 64 | 65 | 66 | -- READ 67 | 68 | 69 | read :: (MonadIO m, MonadError e m) => (String -> e) -> FilePath -> m Description 70 | read toError path = 71 | do json <- liftIO (BS.readFile path) 72 | either (throwError . toError) return (decodeDescription json) 73 | 74 | 75 | 76 | -- WRITE 77 | 78 | 79 | write :: Description -> IO () 80 | write description = 81 | BS.writeFile Path.description (prettyJSON description) 82 | 83 | 84 | 85 | -- TO JSON 86 | 87 | 88 | prettyJSON :: Description -> BS.ByteString 89 | prettyJSON description = 90 | BS.snoc (prettyAngles (encodePretty' config description)) '\n' 91 | where 92 | config = 93 | defConfig { confCompare = keyOrder (normalKeys ++ dependencyKeys) } 94 | 95 | normalKeys = 96 | [ "version" 97 | , "summary" 98 | , "repository" 99 | , "license" 100 | , "source-directories" 101 | , "exposed-modules" 102 | , "native-modules" 103 | , "dependencies" 104 | , "elm-version" 105 | ] 106 | 107 | dependencyKeys = 108 | dependencies description 109 | |> map fst 110 | |> List.sort 111 | |> map (T.pack . Package.toString) 112 | 113 | 114 | prettyAngles :: BS.ByteString -> BS.ByteString 115 | prettyAngles string = 116 | BS.concat $ replaceAngles string 117 | 118 | 119 | replaceAngles :: BS.ByteString -> [BS.ByteString] 120 | replaceAngles str = 121 | let 122 | (before, after) = 123 | BS.break (=='\\') str 124 | in 125 | case BS.take 6 after of 126 | "\\u003e" -> 127 | before : ">" : replaceAngles (BS.drop 6 after) 128 | 129 | "\\u003c" -> 130 | before : "<" : replaceAngles (BS.drop 6 after) 131 | 132 | "" -> 133 | [before] 134 | 135 | _ -> 136 | before : "\\" : replaceAngles (BS.tail after) 137 | 138 | 139 | instance ToJSON Description where 140 | toJSON d = 141 | object $ 142 | [ "repository" .= repo d 143 | , "version" .= version d 144 | , "summary" .= summary d 145 | , "license" .= license d 146 | , "source-directories" .= sourceDirs d 147 | , "exposed-modules" .= map Module.RawForJson (exposed d) 148 | , "dependencies" .= jsonDeps (dependencies d) 149 | , "elm-version" .= elmVersion d 150 | ] ++ if natives d then ["native-modules" .= True] else [] 151 | where 152 | jsonDeps deps = 153 | Map.fromList $ map (first (T.pack . Package.toString)) deps 154 | 155 | 156 | 157 | -- FROM JSON 158 | 159 | 160 | decodeDescription :: BS.ByteString -> Either String Description 161 | decodeDescription bytestring = 162 | do value <- eitherDecode bytestring <|> badJson 163 | parseEither getDescription value 164 | 165 | 166 | badJson :: Either String a 167 | badJson = 168 | Left $ 169 | "I cannot parse the JSON. Maybe a comma is missing? Or there is an extra one?\n\ 170 | \It could also be because of mismatched brackets or quotes.\n\ 171 | \\n\ 172 | \You can also check out the following example to see what it should look like:\n\ 173 | \" 174 | 175 | 176 | instance FromJSON Description where 177 | parseJSON = getDescription 178 | 179 | 180 | getDescription :: Value -> Parser Description 181 | getDescription value = 182 | case value of 183 | Object obj -> 184 | do version <- get obj "version" "your project's version number" 185 | 186 | elmVersion <- getElmVersion obj 187 | 188 | summary <- get obj "summary" "a short summary of your project" 189 | when (length summary >= 80) $ 190 | fail "The \"summary\" must be less than 80 characters" 191 | 192 | license <- get obj "license" "license information (BSD3 is recommended)" 193 | 194 | repo <- get obj "repository" "a link to the project's GitHub repo" 195 | name <- case repoToName repo of 196 | Left err -> fail err 197 | Right nm -> return nm 198 | 199 | exposed <- map Module.fromJson <$> get obj "exposed-modules" "a list of modules exposed to users" 200 | 201 | sourceDirs <- get obj "source-directories" "a list of directories containing source code" 202 | 203 | deps <- getDependencies obj 204 | 205 | natives <- maybe False id <$> obj .:? "native-modules" 206 | 207 | return $ Description name repo version elmVersion summary license sourceDirs exposed natives deps 208 | 209 | _ -> 210 | fail $ 211 | "I was expecting a JSON object, like the one here:\n\ 212 | \" 213 | 214 | 215 | get :: FromJSON a => Object -> T.Text -> String -> Parser a 216 | get obj field desc = 217 | do maybe <- obj .:? field 218 | case maybe of 219 | Just value -> 220 | return value 221 | 222 | Nothing -> 223 | fail $ 224 | "Missing field " ++ show field ++ " which should hold " ++ desc ++ ".\n\ 225 | \\n\ 226 | \Check out an example " ++ Path.description ++ " file here:\n\ 227 | \" 228 | 229 | 230 | getDependencies :: Object -> Parser [(Package.Name, C.Constraint)] 231 | getDependencies obj = 232 | do deps <- get obj "dependencies" "a list of the dependencies you need" 233 | forM (Map.toList deps) $ \(rawName, rawConstraint) -> 234 | case Package.fromString rawName of 235 | Left problem -> 236 | fail ("Ran into invalid package name \"" ++ rawName ++ "\" in dependencies.\n\n" ++ problem) 237 | 238 | Right name -> 239 | case C.fromString rawConstraint of 240 | Just constraint -> 241 | return (name, constraint) 242 | 243 | Nothing -> 244 | fail (C.errorMessage (Just rawName) rawConstraint) 245 | 246 | 247 | getElmVersion :: Object -> Parser C.Constraint 248 | getElmVersion obj = 249 | do rawConstraint <- get obj "elm-version" elmVersionDescription 250 | case C.fromString rawConstraint of 251 | Just constraint -> 252 | return constraint 253 | 254 | Nothing -> 255 | fail (C.errorMessage (Just "the elm-version field") rawConstraint) 256 | 257 | 258 | elmVersionDescription :: String 259 | elmVersionDescription = 260 | "acceptable versions of the Elm Platform (e.g. \"" 261 | ++ C.toString C.defaultElmVersion ++ "\")" 262 | 263 | 264 | repoToName :: String -> Either String Package.Name 265 | repoToName rawRepo = 266 | do rawName <- dropDomain =<< dropExtension rawRepo 267 | case Package.fromString rawName of 268 | Left problem -> 269 | Left (repoProblem problem) 270 | 271 | Right name -> 272 | Right name 273 | 274 | 275 | dropExtension :: String -> Either String String 276 | dropExtension string = 277 | if List.isSuffixOf ".git" string then 278 | Right (take (length string - 4) string) 279 | 280 | else 281 | Left (repoProblem "The given URI does not end with .git") 282 | 283 | 284 | dropDomain :: String -> Either String String 285 | dropDomain string = 286 | let 287 | http = "http://github.com/" 288 | https = "https://github.com/" 289 | in 290 | if List.isPrefixOf http string then 291 | Right (drop (length http) string) 292 | 293 | else if List.isPrefixOf https string then 294 | Right (drop (length https) string) 295 | 296 | else 297 | Left (repoProblem "The given domain does not start with ") 298 | 299 | 300 | repoProblem :: String -> String 301 | repoProblem problem = 302 | "Problem with the \"repository\" field.\n\n" ++ problem 303 | -------------------------------------------------------------------------------- /src/Diff/Compare.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Diff.Compare 3 | ( bumpBy 4 | , computeChanges 5 | , Changes(..) 6 | , PackageChanges(..), packageChangeMagnitude 7 | , ModuleChanges(..), moduleChangeMagnitude 8 | ) 9 | where 10 | 11 | import Control.Monad (zipWithM) 12 | import Data.Function (on) 13 | import qualified Data.List as List 14 | import qualified Data.Map as Map 15 | import qualified Data.Set as Set 16 | import qualified Data.Text as Text 17 | import Data.Text (Text) 18 | 19 | import qualified Catalog 20 | import Diff.Magnitude (Magnitude(..)) 21 | import qualified Elm.Compiler.Module as Module 22 | import qualified Elm.Compiler.Type as Type 23 | import qualified Elm.Docs as Docs 24 | import qualified Elm.Package as Package 25 | import qualified Manager 26 | 27 | 28 | 29 | computeChanges 30 | :: [Docs.Documentation] 31 | -> Package.Name 32 | -> Package.Version 33 | -> Manager.Manager PackageChanges 34 | computeChanges newDocs name version = 35 | do oldDocs <- Catalog.documentation name version 36 | return (diffPackages oldDocs newDocs) 37 | 38 | 39 | 40 | -- CHANGE MAGNITUDE 41 | 42 | 43 | bumpBy :: PackageChanges -> Package.Version -> Package.Version 44 | bumpBy changes version = 45 | case packageChangeMagnitude changes of 46 | PATCH -> 47 | Package.bumpPatch version 48 | 49 | MINOR -> 50 | Package.bumpMinor version 51 | 52 | MAJOR -> 53 | Package.bumpMajor version 54 | 55 | 56 | packageChangeMagnitude :: PackageChanges -> Magnitude 57 | packageChangeMagnitude pkgChanges = 58 | maximum (added : removed : map moduleChangeMagnitude moduleChanges) 59 | where 60 | moduleChanges = 61 | Map.elems (modulesChanged pkgChanges) 62 | 63 | removed = 64 | if null (modulesRemoved pkgChanges) then 65 | PATCH 66 | else 67 | MAJOR 68 | 69 | added = 70 | if null (modulesAdded pkgChanges) then 71 | PATCH 72 | else 73 | MINOR 74 | 75 | 76 | moduleChangeMagnitude :: ModuleChanges -> Magnitude 77 | moduleChangeMagnitude moduleChanges = 78 | maximum 79 | [ changeMagnitude (adtChanges moduleChanges) 80 | , changeMagnitude (aliasChanges moduleChanges) 81 | , changeMagnitude (valueChanges moduleChanges) 82 | ] 83 | 84 | 85 | changeMagnitude :: Changes k v -> Magnitude 86 | changeMagnitude (Changes added changed removed) 87 | | Map.size removed > 0 = MAJOR 88 | | Map.size changed > 0 = MAJOR 89 | | Map.size added > 0 = MINOR 90 | | otherwise = PATCH 91 | 92 | 93 | 94 | -- DETECT CHANGES 95 | 96 | 97 | data PackageChanges = 98 | PackageChanges 99 | { modulesAdded :: [Text] 100 | , modulesChanged :: Map.Map Text ModuleChanges 101 | , modulesRemoved :: [Text] 102 | } 103 | 104 | 105 | data ModuleChanges = 106 | ModuleChanges 107 | { adtChanges :: Changes Text ([Text], Map.Map Text [Type.Type]) 108 | , aliasChanges :: Changes Text ([Text], Type.Type) 109 | , valueChanges :: Changes Text Type.Type 110 | } 111 | 112 | 113 | data Changes k v = 114 | Changes 115 | { added :: Map.Map k v 116 | , changed :: Map.Map k (v,v) 117 | , removed :: Map.Map k v 118 | } 119 | 120 | 121 | diffPackages :: [Docs.Documentation] -> [Docs.Documentation] -> PackageChanges 122 | diffPackages oldDocs newDocs = 123 | let 124 | filterOutPatches chngs = 125 | Map.filter (\chng -> moduleChangeMagnitude chng /= PATCH) chngs 126 | 127 | (Changes added changed removed) = 128 | getChanges 129 | (\_ _ -> False) 130 | (docsToModules oldDocs) 131 | (docsToModules newDocs) 132 | in 133 | PackageChanges 134 | (Map.keys added) 135 | (filterOutPatches (Map.map (uncurry diffModule) changed)) 136 | (Map.keys removed) 137 | 138 | 139 | 140 | data Module = Module 141 | { adts :: Map.Map Text ([Text], Map.Map Text [Type.Type]) 142 | , aliases :: Map.Map Text ([Text], Type.Type) 143 | , values :: Map.Map Text Type.Type 144 | , version :: Docs.Version 145 | } 146 | 147 | 148 | docsToModules :: [Docs.Documentation] -> Map.Map Text Module 149 | docsToModules docs = 150 | Map.fromList (map docToModule docs) 151 | 152 | 153 | docToModule :: Docs.Documentation -> (Text, Module) 154 | docToModule (Docs.Documentation name _ aliases' unions' values' generatedByVersion) = 155 | (,) (Text.pack (Module.nameToString name)) $ Module 156 | { adts = 157 | Map.fromList $ flip map unions' $ \union -> 158 | ( Docs.unionName union 159 | , (Docs.unionArgs union, Map.fromList (Docs.unionCases union)) 160 | ) 161 | 162 | , aliases = 163 | Map.fromList $ flip map aliases' $ \alias -> 164 | (Docs.aliasName alias, (Docs.aliasArgs alias, Docs.aliasType alias)) 165 | 166 | , values = 167 | Map.fromList $ flip map values' $ \value -> 168 | (Docs.valueName value, Docs.valueType value) 169 | , version = 170 | generatedByVersion 171 | } 172 | 173 | 174 | diffModule :: Module -> Module -> ModuleChanges 175 | diffModule (Module adts aliases values version) (Module adts' aliases' values' version') = 176 | let 177 | ignoreOrigin = 178 | case (version, version') of 179 | (Docs.NonCanonicalTypes, _) -> True 180 | (_, Docs.NonCanonicalTypes) -> True 181 | (_, _) -> False 182 | in 183 | ModuleChanges 184 | (getChanges (isEquivalentAdt ignoreOrigin) adts adts') 185 | (getChanges (isEquivalentType ignoreOrigin) aliases aliases') 186 | (getChanges (\t t' -> isEquivalentType ignoreOrigin ([],t) ([],t')) values values') 187 | 188 | 189 | getChanges :: (Ord k) => (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Changes k v 190 | getChanges isEquivalent old new = 191 | Changes 192 | { added = 193 | Map.difference new old 194 | , changed = 195 | Map.filter 196 | (not . uncurry isEquivalent) 197 | (Map.intersectionWith (,) old new) 198 | , removed = 199 | Map.difference old new 200 | } 201 | 202 | 203 | isEquivalentAdt 204 | :: Bool 205 | -> ([Text], Map.Map Text [Type.Type]) 206 | -> ([Text], Map.Map Text [Type.Type]) 207 | -> Bool 208 | isEquivalentAdt ignoreOrigin (oldVars, oldCtors) (newVars, newCtors) = 209 | Map.size oldCtors == Map.size newCtors 210 | && and (zipWith (==) (Map.keys oldCtors) (Map.keys newCtors)) 211 | && and (Map.elems (Map.intersectionWith equiv oldCtors newCtors)) 212 | where 213 | equiv :: [Type.Type] -> [Type.Type] -> Bool 214 | equiv oldTypes newTypes = 215 | let 216 | allEquivalent = 217 | zipWith 218 | (isEquivalentType ignoreOrigin) 219 | (map ((,) oldVars) oldTypes) 220 | (map ((,) newVars) newTypes) 221 | in 222 | length oldTypes == length newTypes 223 | && and allEquivalent 224 | 225 | 226 | isEquivalentType :: Bool -> ([Text], Type.Type) -> ([Text], Type.Type) -> Bool 227 | isEquivalentType ignoreOrigin (oldVars, oldType) (newVars, newType) = 228 | case diffType ignoreOrigin oldType newType of 229 | Nothing -> 230 | False 231 | 232 | Just renamings -> 233 | length oldVars == length newVars 234 | && isEquivalentRenaming (zip oldVars newVars ++ renamings) 235 | 236 | 237 | 238 | -- TYPES 239 | 240 | 241 | diffType :: Bool -> Type.Type -> Type.Type -> Maybe [(Text,Text)] 242 | diffType ignoreOrigin oldType newType = 243 | let 244 | go = diffType ignoreOrigin 245 | in 246 | case (oldType, newType) of 247 | (Type.Var oldName, Type.Var newName) -> 248 | Just [(oldName, newName)] 249 | 250 | (Type.Type oldName, Type.Type newName) -> 251 | let 252 | format = 253 | if ignoreOrigin then dropOrigin else id 254 | in 255 | if format oldName == format newName then 256 | Just [] 257 | else 258 | Nothing 259 | 260 | (Type.Lambda a b, Type.Lambda a' b') -> 261 | (++) 262 | <$> go a a' 263 | <*> go b b' 264 | 265 | (Type.App t ts, Type.App t' ts') -> 266 | if length ts /= length ts' then 267 | Nothing 268 | else 269 | (++) 270 | <$> go t t' 271 | <*> (concat <$> zipWithM go ts ts') 272 | 273 | (Type.Record fields maybeExt, Type.Record fields' maybeExt') -> 274 | case (maybeExt, maybeExt') of 275 | (Nothing, Just _) -> 276 | Nothing 277 | 278 | (Just _, Nothing) -> 279 | Nothing 280 | 281 | (Nothing, Nothing) -> 282 | diffFields ignoreOrigin fields fields' 283 | 284 | (Just ext, Just ext') -> 285 | (++) 286 | <$> go ext ext' 287 | <*> diffFields ignoreOrigin fields fields' 288 | 289 | (_, _) -> 290 | Nothing 291 | 292 | 293 | diffFields :: Bool -> [(Text, Type.Type)] -> [(Text, Type.Type)] -> Maybe [(Text,Text)] 294 | diffFields ignoreOrigin rawFields rawFields' 295 | | length rawFields /= length rawFields' = Nothing 296 | | or (zipWith ((/=) `on` fst) fields fields') = Nothing 297 | | otherwise = 298 | concat <$> zipWithM (diffType ignoreOrigin `on` snd) fields fields' 299 | where 300 | fields = sort rawFields 301 | fields' = sort rawFields' 302 | 303 | sort = 304 | List.sortBy (compare `on` fst) 305 | 306 | 307 | dropOrigin :: Text -> Text 308 | dropOrigin name = 309 | snd (Text.breakOnEnd "." name) 310 | 311 | 312 | 313 | -- TYPE VARIABLES 314 | 315 | 316 | isEquivalentRenaming :: [(Text,Text)] -> Bool 317 | isEquivalentRenaming varPairs = 318 | let 319 | renamings = 320 | Map.toList (foldr insert Map.empty varPairs) 321 | 322 | insert (old,new) dict = 323 | Map.insertWith (++) old [new] dict 324 | 325 | verify (old, news) = 326 | case news of 327 | [] -> 328 | Nothing 329 | 330 | new : rest -> 331 | if all (new ==) rest then 332 | Just (old, new) 333 | else 334 | Nothing 335 | 336 | allUnique list = 337 | length list == Set.size (Set.fromList list) 338 | in 339 | case mapM verify renamings of 340 | Nothing -> 341 | False 342 | 343 | Just verifiedRenamings -> 344 | all compatableVars verifiedRenamings 345 | && 346 | allUnique (map snd verifiedRenamings) 347 | 348 | 349 | compatableVars :: (Text, Text) -> Bool 350 | compatableVars (old, new) = 351 | case (categorizeVar old, categorizeVar new) of 352 | (CompAppend, CompAppend) -> True 353 | (Comparable, Comparable) -> True 354 | (Appendable, Appendable) -> True 355 | (Number , Number ) -> True 356 | 357 | (Comparable, CompAppend) -> True 358 | (Appendable, CompAppend) -> True 359 | (Number , CompAppend) -> True 360 | (Number , Comparable) -> True 361 | 362 | (_, Var) -> True 363 | 364 | (_, _) -> False 365 | 366 | 367 | data TypeVarCategory 368 | = CompAppend 369 | | Comparable 370 | | Appendable 371 | | Number 372 | | Var 373 | 374 | 375 | categorizeVar :: Text -> TypeVarCategory 376 | categorizeVar name 377 | | Text.isPrefixOf "compappend" name = CompAppend 378 | | Text.isPrefixOf "comparable" name = Comparable 379 | | Text.isPrefixOf "appendable" name = Appendable 380 | | Text.isPrefixOf "number" name = Number 381 | | otherwise = Var 382 | -------------------------------------------------------------------------------- /src/Reporting/Error.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Reporting.Error 4 | ( Error(..) 5 | , Hint(..) 6 | , toString 7 | , toStderr 8 | , nearbyNames 9 | ) 10 | where 11 | 12 | import Data.Function (on) 13 | import qualified Data.List as List 14 | import qualified Elm.Compiler as Compiler 15 | import qualified Elm.Package as Pkg 16 | import qualified Elm.Package.Constraint as C 17 | import qualified Elm.Package.Paths as Path 18 | import GHC.IO.Handle (hIsTerminalDevice) 19 | import System.IO (hPutStr, stderr) 20 | import qualified Text.EditDistance as Dist 21 | import Text.PrettyPrint.ANSI.Leijen 22 | ( Doc, (<+>), (<>), align, displayS, displayIO, dullred, dullyellow, fillSep 23 | , hardline, indent, plain, red, renderPretty, text, underline, vcat 24 | ) 25 | 26 | import qualified Diff.Magnitude as Diff 27 | 28 | 29 | 30 | -- ALL POSSIBLE ERRORS 31 | 32 | 33 | data Error 34 | = BadElmVersion Pkg.Version Bool C.Constraint 35 | | SystemCallFailed String 36 | | HttpRequestFailed String String 37 | | ZipDownloadFailed Pkg.Name Pkg.Version 38 | | CorruptJson String Pkg.Name Pkg.Version String 39 | | CorruptDescription String 40 | | CorruptDocumentation String 41 | | CorruptSolution String 42 | | CorruptVersionCache Pkg.Name 43 | | PackageNotFound Pkg.Name [Pkg.Name] 44 | | AddTrickyConstraint Pkg.Name Pkg.Version C.Constraint 45 | 46 | | ConstraintsHaveNoSolution [Hint] 47 | 48 | | BadInstall Pkg.Version 49 | 50 | | Undiffable 51 | | VersionInvalid 52 | | VersionJustChanged 53 | | BadMetadata [String] 54 | | MissingTag Pkg.Version 55 | 56 | | AlreadyPublished Pkg.Version 57 | | Unbumpable Pkg.Version [Pkg.Version] 58 | | InvalidBump Pkg.Version Pkg.Version 59 | | BadBump Pkg.Version Pkg.Version Diff.Magnitude Pkg.Version Diff.Magnitude 60 | 61 | 62 | 63 | -- BAD CONSTRAINT HINTS 64 | 65 | 66 | data Hint 67 | = EmptyConstraint Pkg.Name C.Constraint 68 | | IncompatibleConstraint Pkg.Name C.Constraint Pkg.Version 69 | | IncompatiblePackage Pkg.Name 70 | 71 | 72 | 73 | -- NEARBY NAMES 74 | 75 | 76 | nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name] 77 | nearbyNames package allPackages = 78 | let 79 | name = 80 | Pkg.toString package 81 | 82 | ratedNames = 83 | map (\pkg -> (distance name (Pkg.toString pkg), pkg)) allPackages 84 | 85 | sortedNames = 86 | List.sortBy (compare `on` fst) ratedNames 87 | in 88 | map snd $ take 4 sortedNames 89 | 90 | 91 | distance :: String -> String -> Int 92 | distance x y = 93 | Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y 94 | 95 | 96 | 97 | -- TO MESSAGE 98 | 99 | 100 | data Message = 101 | Message 102 | { _summary :: String 103 | , _details :: [Doc] 104 | } 105 | 106 | 107 | toMessage :: Error -> Message 108 | toMessage err = 109 | case err of 110 | BadElmVersion elmVersion isGreater elmConstraint -> 111 | Message 112 | ( "You are using Elm " ++ Pkg.versionToString elmVersion 113 | ++ ", but this project is saying it needs a version in this range: " 114 | ++ C.toString elmConstraint 115 | ) 116 | ( map reflow $ 117 | if isGreater then 118 | [ "This means this package has not been upgraded for the newer version of Elm yet.\ 119 | \ Check out the upgrade docs for guidance on how to get things working again:\ 120 | \ " 121 | ] 122 | else 123 | [ "This means the package is written for a newer version of Elm. The best route\ 124 | \ is to just download the new Elm version! " 125 | , "If you cannot upgrade for some reason, you can install different versions at\ 126 | \ the same time with npm. I switch between versions by changing my PATH to\ 127 | \ point at certain binaries, but you can do it however you want." 128 | ] 129 | ) 130 | 131 | SystemCallFailed problem -> 132 | Message "A system call failed." [ text problem ] 133 | 134 | HttpRequestFailed url message -> 135 | Message 136 | ( "The following HTTP request failed. <" ++ url ++ ">" 137 | ) 138 | [ text message 139 | ] 140 | 141 | ZipDownloadFailed name version -> 142 | Message 143 | ( "Problem when downloading the " ++ Pkg.toString name 144 | ++ " " ++ Pkg.versionToString version ++ " code." 145 | ) 146 | [] 147 | 148 | CorruptJson path name version problem -> 149 | Message 150 | ( "I just fetched " ++ path ++ " for " ++ Pkg.toString name 151 | ++ " " ++ Pkg.versionToString version 152 | ++ ", but I cannot read the contents." 153 | ) 154 | [ reflow $ 155 | "Maybe it is a very old file, and the file format changed since then?\ 156 | \ Or maybe you are at a hotel or airport where they hijack your HTTP\ 157 | \ requests and redirect you to some log in page? The particular problem\ 158 | \ I am seeing is:" 159 | , text problem 160 | ] 161 | 162 | CorruptDescription problem -> 163 | Message 164 | ( "The description in " ++ Path.description ++ " is not valid." 165 | ) 166 | [ text problem 167 | ] 168 | 169 | CorruptDocumentation problem -> 170 | Message 171 | ( "I was able to produce documentation for your package, but it is not valid.\ 172 | \ My guess is that the elm-package and elm-make on your PATH are not from the\ 173 | \ same version of Elm, but it could be some other similarly crazy thing." 174 | ) 175 | [ text problem 176 | ] 177 | 178 | CorruptSolution problem -> 179 | Message 180 | ( "Your " ++ Path.solvedDependencies ++ " file is corrupted. Do not modify it\ 181 | \ by hand! You can just delete it and I will recreate a valid one." 182 | ) 183 | [ text problem 184 | ] 185 | 186 | CorruptVersionCache name -> 187 | Message 188 | ( "Your .elm/packages/ directory may be corrupted. I was led to believe\ 189 | \ that " ++ Pkg.toString name ++ " existed, but I could not find anything\ 190 | \ when I went to look up the published versions of this package." 191 | ) 192 | [] 193 | 194 | ConstraintsHaveNoSolution hints -> 195 | Message "I cannot find a set of packages that works with your constraints." $ 196 | case hints of 197 | [] -> 198 | [ reflow $ 199 | "One way to rebuild your constraints is to clear everything out of\ 200 | \ the \"dependencies\" field of " ++ Path.description ++ " and add\ 201 | \ them back one at a time with `elm-package install`." 202 | , reflow $ 203 | "I hope to automate this in the future, but at least there is\ 204 | \ a way to make progress for now!" 205 | ] 206 | 207 | _ -> 208 | [ stack (map hintToBullet hints) ] 209 | 210 | PackageNotFound package suggestions -> 211 | Message 212 | ( "Could not find any packages named " ++ Pkg.toString package ++ "." 213 | ) 214 | [ text $ "Here are some packages that have similar names:" 215 | , indent 4 $ vcat $ map (text . Pkg.toString) suggestions 216 | , text $ "Maybe you want one of those?" 217 | ] 218 | 219 | AddTrickyConstraint name version constraint -> 220 | Message 221 | ( "This change is too tricky for me. Your " ++ Path.description 222 | ++ " already lists the following dependency:" 223 | ) 224 | [ indent 4 $ text $ showDependency name constraint 225 | , reflow $ 226 | "So I am not sure how to make that include version " 227 | ++ Pkg.versionToString version 228 | ++ " as well. Maybe you want one of the following constraints?" 229 | , indent 4 $ vcat $ map text $ 230 | [ C.toString (C.expand constraint version) 231 | , C.toString (C.untilNextMajor version) 232 | ] 233 | , reflow $ 234 | "Modify " ++ Path.description ++ " by hand to be exactly what you want." 235 | ] 236 | 237 | BadInstall version -> 238 | Message 239 | ( "You specified a version number, but not a package! Version " 240 | ++ Pkg.versionToString version ++ " of what?" 241 | ) 242 | [] 243 | 244 | Undiffable -> 245 | Message "This package has not been published, there is nothing to diff against!" [] 246 | 247 | VersionInvalid -> 248 | Message 249 | "Cannot publish a package with an invalid version. Use `elm-package bump` to\ 250 | \ figure out what the next version should be, and be sure you commit any\ 251 | \ changes and tag them appropriately." 252 | [] 253 | 254 | VersionJustChanged -> 255 | Message 256 | "Cannot publish a package with an invalid version. Be sure you commit any\ 257 | \ necessary changes and tag them appropriately." 258 | [] 259 | 260 | BadMetadata problems -> 261 | Message 262 | ( "Some of the fields in " ++ Path.description ++ " have not been filled in yet:" 263 | ) 264 | [ vcat (map text problems) 265 | , text $ "Fill these in and try to publish again!" 266 | ] 267 | 268 | MissingTag version -> 269 | let 270 | vsn = 271 | Pkg.versionToString version 272 | in 273 | Message 274 | ( "Libraries must be tagged in git, but tag " ++ vsn ++ " was not found." 275 | ) 276 | [ vcat $ map text $ 277 | [ "These tags make it possible to find this specific version on GitHub." 278 | , "To tag the most recent commit and push it to GitHub, run this:" 279 | , "" 280 | , " git tag -a " ++ vsn ++ " -m \"release version " ++ vsn ++ "\"" 281 | , " git push origin " ++ vsn 282 | ] 283 | ] 284 | 285 | AlreadyPublished vsn -> 286 | Message 287 | ( "Version " ++ Pkg.versionToString vsn ++ " has already been published.\ 288 | \ You cannot publish it again! Run the following command to see what\ 289 | \ the new version should be:" 290 | ) 291 | [ indent 4 $ text "elm-package bump" 292 | ] 293 | 294 | Unbumpable vsn versions -> 295 | let 296 | list = 297 | case map Pkg.versionToString versions of 298 | [v] -> 299 | " to " ++ v ++ "." 300 | 301 | [v,w] -> 302 | " to " ++ v ++ " or " ++ w ++ "." 303 | 304 | vsnStrings -> 305 | " to one of these: "++ List.intercalate ", " vsnStrings 306 | in 307 | Message 308 | ( "To compute a version bump, I need to start with a version that has\ 309 | \ already been published. Your " ++ Path.description 310 | ++ " says I should start with version " 311 | ++ Pkg.versionToString vsn 312 | ++ ", but I cannot find that version on ." 313 | ) 314 | [ reflow $ 315 | "Try again after changing the version in " ++ Path.description ++ list 316 | ] 317 | 318 | InvalidBump statedVersion latestVersion -> 319 | Message 320 | ( "Your " ++ Path.description ++ " says the next version should be " 321 | ++ Pkg.versionToString statedVersion ++ ", but that is not valid\ 322 | \ based on the previously published versions." 323 | ) 324 | [ reflow $ 325 | "Generally, you want to put the most recently published version (" 326 | ++ Pkg.versionToString latestVersion ++ " for this package) in your " 327 | ++ Path.description 328 | ++ " and run `elm-package bump` to figure out what should come next." 329 | ] 330 | 331 | BadBump old new magnitude realNew realMagnitude -> 332 | Message 333 | ( "Your " ++ Path.description ++ " says the next version should be " 334 | ++ Pkg.versionToString new ++ ", indicating a " ++ show magnitude 335 | ++ " change to the public API. This does not match the API diff given by:" 336 | ) 337 | [ indent 4 $ text $ 338 | "elm-package diff " ++ Pkg.versionToString old 339 | 340 | , reflow $ 341 | "This command says this is a " ++ show realMagnitude 342 | ++ " change, so the next version should be " 343 | ++ Pkg.versionToString realNew 344 | ++ ". Double check everything to make sure you are publishing what you want!" 345 | , reflow $ 346 | "Also, next time use `elm-package bump` and I'll figure all this out for you!" 347 | ] 348 | 349 | 350 | showDependency :: Pkg.Name -> C.Constraint -> String 351 | showDependency name constraint = 352 | show (Pkg.toString name) ++ ": " ++ show (C.toString constraint) 353 | 354 | 355 | hintToDoc :: Hint -> Doc 356 | hintToDoc hint = 357 | case hint of 358 | EmptyConstraint name constraint -> 359 | stack 360 | [ reflow $ "Your " ++ Path.description ++ " has the following dependency:" 361 | , indent 4 $ text $ showDependency name constraint 362 | , reflow $ 363 | "But there are no released versions in that range! I recommend\ 364 | \ removing that constraint by hand and adding it back with:" 365 | , indent 4 $ text $ "elm-package install " ++ Pkg.toString name 366 | ] 367 | 368 | IncompatibleConstraint name constraint viableVersion -> 369 | stack 370 | [ reflow $ "Your " ++ Path.description ++ " has the following dependency:" 371 | , indent 4 $ text $ showDependency name constraint 372 | , reflow $ 373 | "But none of the versions in that range work with Elm " 374 | ++ Pkg.versionToString Compiler.version ++ ". I recommend removing\ 375 | \ that dependency by hand and adding it back with:" 376 | , indent 4 $ 377 | text ("elm-package install " ++ Pkg.toString name) 378 | <+> dullyellow (text (Pkg.versionToString viableVersion)) 379 | ] 380 | 381 | IncompatiblePackage name -> 382 | let 383 | intro = 384 | map text $ words $ 385 | "There are no versions of " ++ Pkg.toString name ++ " that work with Elm " 386 | ++ Pkg.versionToString Compiler.version ++ "." 387 | 388 | outro = 389 | case name of 390 | Pkg.Name "evancz" "elm-svg" -> 391 | instead "elm-lang/svg" 392 | 393 | Pkg.Name "evancz" "elm-html" -> 394 | instead "elm-lang/html" 395 | 396 | Pkg.Name "evancz" "virtual-dom" -> 397 | instead "elm-lang/virtual-dom" 398 | 399 | _ -> 400 | map text (words "Maybe the maintainer has not updated it yet.") 401 | in 402 | fillSep $ intro ++ outro 403 | 404 | 405 | instead :: String -> [Doc] 406 | instead newName = 407 | map text (words "Remove that constraint and use") 408 | ++ [ dullyellow (text newName), text "instead!" ] 409 | 410 | 411 | hintToBullet :: Hint -> Doc 412 | hintToBullet hint = 413 | dullred (text "-->") <+> align (hintToDoc hint) 414 | 415 | 416 | 417 | -- RENDERERS 418 | 419 | 420 | toStderr :: Error -> IO () 421 | toStderr err = 422 | do isTerminal <- hIsTerminalDevice stderr 423 | if isTerminal 424 | then displayIO stderr (renderPretty 1 80 (toDoc err)) 425 | else hPutStr stderr (toString err) 426 | 427 | 428 | toString :: Error -> String 429 | toString err = 430 | displayS (renderPretty 1 80 (plain (toDoc err))) "" 431 | 432 | 433 | toDoc :: Error -> Doc 434 | toDoc err = 435 | let 436 | (Message summary details) = 437 | toMessage err 438 | 439 | summaryDoc = 440 | fillSep (errorStart : map text (words summary)) 441 | in 442 | stack (summaryDoc : details) 443 | <> hardline 444 | <> hardline 445 | 446 | 447 | stack :: [Doc] -> Doc 448 | stack allDocs = 449 | case allDocs of 450 | [] -> 451 | error "Do not use `stack` on empty lists." 452 | 453 | doc : docs -> 454 | List.foldl' verticalAppend doc docs 455 | 456 | 457 | verticalAppend :: Doc -> Doc -> Doc 458 | verticalAppend a b = 459 | a <> hardline <> hardline <> b 460 | 461 | 462 | errorStart :: Doc 463 | errorStart = 464 | red (underline (text "Error")) <> text ":" 465 | 466 | 467 | reflow :: String -> Doc 468 | reflow paragraph = 469 | fillSep (map text (words paragraph)) 470 | --------------------------------------------------------------------------------