diff --git a/bower-json.cabal b/bower-json.cabal --- a/bower-json.cabal +++ b/bower-json.cabal @@ -1,5 +1,5 @@ name: bower-json -version: 0.3.0.0 +version: 0.4.0.0 synopsis: bower.json from Haskell license: MIT license-file: LICENSE @@ -11,9 +11,11 @@ cabal-version: >=1.10 description: - This package provides a data type and FromJSON instance for bower.json - package description files. + Bower is a package manager for the web (see ). + This package provides a data type and FromJSON instance for Bower's package + manifest file, bower.json. + source-repository head type: git location: https://github.com/hdgarrood/bower-json @@ -38,7 +40,9 @@ , bower-json -any , aeson -any , bytestring -any + , text -any + , unordered-containers -any , tasty -any , tasty-hunit -any - ghc-options: -Wall + ghc-options: -Wall -fno-warn-missing-signatures default-language: Haskell2010 diff --git a/src/Web/BowerJson.hs b/src/Web/BowerJson.hs --- a/src/Web/BowerJson.hs +++ b/src/Web/BowerJson.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} -- | A data type representing the Bower.json package description file, together -- with a parser and related functions. @@ -35,6 +35,12 @@ -- | A data type representing the data stored in a bower.json package manifest -- file. +-- +-- Note that the 'ToJSON' / 'FromJSON' instances don't exactly match; for +-- example, it is not always the case that decoding from JSON and then encoding +-- to JSON will give you the exact same JSON that you started with. However, if +-- you start with a BowerJson value, encode to JSON, and then decode, you +-- should always get the same value back. data BowerJson = BowerJson { bowerName :: PackageName , bowerDescription :: Maybe String @@ -92,6 +98,42 @@ let xs = HashMap.toList o mapM (\(k, v) -> (,) <$> parseKey k <*> parseJSON v) xs +instance ToJSON BowerJson where + toJSON BowerJson{..} = + object $ concat + [ [ "name" .= bowerName ] + , maybePair "description" bowerDescription + , maybeArrayPair "main" bowerMain + , maybeArrayPair "moduleType" bowerModuleType + , maybeArrayPair "licence" bowerLicence + , maybeArrayPair "ignore" bowerIgnore + , maybeArrayPair "keywords" bowerKeywords + , maybeArrayPair "authors" bowerAuthors + , maybePair "homepage" bowerHomepage + , maybePair "repository" bowerRepository + , assoc "dependencies" bowerDependencies + , assoc "devDependencies" bowerDevDependencies + , assoc "resolutions" bowerResolutions + , if bowerPrivate then [ "private" .= True ] else [] + ] + + where + asText = T.pack . runPackageName + + assoc :: ToJSON a => Text -> [(PackageName, a)] -> [Aeson.Pair] + assoc = maybeArrayAssocPair asText + +maybePair :: ToJSON a => Text -> Maybe a -> [Aeson.Pair] +maybePair key = maybe [] (\val -> [key .= val]) + +maybeArrayPair :: ToJSON a => Text -> [a] -> [Aeson.Pair] +maybeArrayPair _ [] = [] +maybeArrayPair key xs = [key .= xs] + +maybeArrayAssocPair :: ToJSON b => (a -> Text) -> Text -> [(a,b)] -> [Aeson.Pair] +maybeArrayAssocPair _ _ [] = [] +maybeArrayAssocPair f key xs = [key .= object (map (\(k, v) -> f k .= v) xs)] + -- | Read and attempt to decode a bower.json file. decodeFile :: FilePath -> IO (Either String BowerJson) decodeFile = fmap eitherDecode . B.readFile @@ -111,6 +153,9 @@ Just pkgName -> return pkgName Nothing -> fail ("unable to validate package name: " ++ show text) +instance ToJSON PackageName where + toJSON = toJSON . runPackageName + -- | A smart constructor for a PackageName. It ensures that the package name -- satisfies the restrictions described at -- . @@ -161,6 +206,9 @@ Just t' -> return t' Nothing -> fail ("invalid module type: " ++ show t) +instance ToJSON ModuleType where + toJSON = toJSON . map toLower . show + data Repository = Repository { repositoryUrl :: String , repositoryType :: String @@ -173,6 +221,12 @@ Repository <$> o .: "url" <*> o .: "type" +instance ToJSON Repository where + toJSON Repository{..} = + object [ "url" .= repositoryUrl + , "type" .= repositoryType + ] + data Author = Author { authorName :: String , authorEmail :: Maybe String @@ -193,6 +247,13 @@ parseJSON v = Aeson.typeMismatch "Author" v +instance ToJSON Author where + toJSON Author{..} = + object $ + [ "name" .= authorName ] ++ + maybePair "email" authorEmail ++ + maybePair "homepage" authorHomepage + -- | Given a prefix and a suffix, go through the supplied list, attempting -- to extract one string from the list which has the given prefix and suffix, -- All other strings in the list are returned as the second component of the @@ -223,6 +284,9 @@ parseJSON = withText "Version" (pure . Version . T.unpack) +instance ToJSON Version where + toJSON = toJSON . runVersion + newtype VersionRange = VersionRange { runVersionRange :: String } deriving (Show, Eq, Ord) @@ -230,3 +294,6 @@ instance FromJSON VersionRange where parseJSON = withText "VersionRange" (pure . VersionRange . T.unpack) + +instance ToJSON VersionRange where + toJSON = toJSON . runVersionRange diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -26,47 +26,47 @@ tests = testGroup "tests" [ testGroup "FromJSON Author instance" authorTests , testGroup "optional keys" optionalKeyTests + , testGroup "round trips" roundTripTests ] authorTests :: [TestTree] authorTests = [ testCase "As string without homepage/email" $ do - authorWithoutOptionalAttrs @=? + Just authorWithoutOptionalAttrs @=? decodeValue "\"Harry Garrood\"" -- should not be sensitive to extra whitespace - authorWithoutOptionalAttrs @=? + Just authorWithoutOptionalAttrs @=? decodeValue "\" Harry Garrood \"" , testCase "As string with homepage/email" $ do - authorWithEmail @=? + Just authorWithEmail @=? decodeValue "\"Harry Garrood \"" - authorWithHomepage @=? + Just authorWithHomepage @=? decodeValue "\"Harry Garrood (http://harry.garrood.me)\"" - authorWithBoth @=? + Just authorWithBoth @=? decodeValue "\"Harry Garrood (http://harry.garrood.me)\"" , testCase "As object" $ do - authorWithoutOptionalAttrs @=? + Just authorWithoutOptionalAttrs @=? decode "{\"name\": \"Harry Garrood\"}" - authorWithEmail @=? + Just authorWithEmail @=? decode "{\"name\": \"Harry Garrood\", \"email\": \"harry@garrood.me\"}" - authorWithHomepage @=? + Just authorWithHomepage @=? decode "{\"name\": \"Harry Garrood\", \"homepage\": \"http://harry.garrood.me\"}" - authorWithBoth @=? + Just authorWithBoth @=? decode "{\"name\": \"Harry Garrood\", \"email\": \"harry@garrood.me\", \"homepage\": \"http://harry.garrood.me\"}" ] - where - authorWithoutOptionalAttrs = Just (Author "Harry Garrood" Nothing Nothing) - authorWithEmail = Just (Author "Harry Garrood" (Just "harry@garrood.me") Nothing) - authorWithHomepage = Just (Author "Harry Garrood" Nothing (Just "http://harry.garrood.me")) - authorWithBoth = Just (Author "Harry Garrood" (Just "harry@garrood.me") (Just "http://harry.garrood.me")) +authorWithoutOptionalAttrs = Author "Harry Garrood" Nothing Nothing +authorWithEmail = Author "Harry Garrood" (Just "harry@garrood.me") Nothing +authorWithHomepage = Author "Harry Garrood" Nothing (Just "http://harry.garrood.me") +authorWithBoth = Author "Harry Garrood" (Just "harry@garrood.me") (Just "http://harry.garrood.me") optionalKeyTests :: [TestTree] optionalKeyTests = @@ -88,8 +88,39 @@ decode "{\"name\": \"test-package\", \"moduleType\": [\"amd\"]}" ] where - pkgName = fromJust (mkPackageName "test-package") - depPkgName = fromJust (mkPackageName "dependency-package") - basic = BowerJson pkgName Nothing [] [] [] [] [] [] Nothing Nothing [] [] [] False - basicWithDeps = basic { bowerDependencies = [(depPkgName, VersionRange ">= 1.0")] } - basicWithModuleType = basic { bowerModuleType = [AMD] } + +pkgName = fromJust (mkPackageName "test-package") +depPkgName = fromJust (mkPackageName "dependency-package") +basic = BowerJson pkgName Nothing [] [] [] [] [] [] Nothing Nothing [] [] [] False +basicWithDeps = basic { bowerDependencies = [(depPkgName, VersionRange ">= 1.0")] } +basicWithModuleType = basic { bowerModuleType = [AMD] } + +complex = + basicWithDeps + { bowerDescription = Just "hello, world" + , bowerMain = ["foo.js"] + , bowerModuleType = [Globals, Node] + , bowerLicence = ["MIT"] + , bowerIgnore = [] + , bowerKeywords = ["purescript"] + , bowerAuthors = [authorWithoutOptionalAttrs, authorWithEmail, authorWithBoth] + , bowerHomepage = Nothing + , bowerRepository = Just (Repository "git://github.com/hdgarrood/test-package" "git") + , bowerDevDependencies = [] + , bowerResolutions = [] + } + +complexPrivate = complex { bowerPrivate = True } + +allBowerJsons = + [ ("basic", basic) + , ("basicWithDeps", basicWithDeps) + , ("basicWithModuleType", basicWithModuleType) + , ("complex", complex) + , ("complexPrivate", complexPrivate) + ] + +roundTripTests :: [TestTree] +roundTripTests = + map (\(name, b) -> testCase name (Just b @=? decode (encode b))) + allBowerJsons