Description.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Elm.Package.Description
  ( Description(..)
  , defaultDescription
  , read, write
  )
  where

import Prelude hiding (read)
import Control.Applicative ((<|>))
import Control.Arrow (first)
import Control.Monad (forM, when)
import Control.Monad.Error.Class (MonadError, throwError)
import Control.Monad.Trans (MonadIO, liftIO)
import Data.Aeson
import Data.Aeson.Types (Parser, parseEither)
import Data.Aeson.Encode.Pretty (encodePretty', defConfig, confCompare, keyOrder)
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.HashMap.Strict as Map
import qualified Data.List as List
import qualified Data.Text as T

import qualified Elm.Compiler.Module as Module
import qualified Elm.Package as Package
import qualified Elm.Package.Constraint as C
import qualified Elm.Package.Paths as Path
import Elm.Utils ((|>))



-- DESCRIPTION


data Description = Description
    { name :: Package.Name
    , repo :: String
    , version :: Package.Version
    , elmVersion :: C.Constraint
    , summary :: String
    , license :: String
    , sourceDirs :: [FilePath]
    , exposed :: [Module.Raw]
    , natives :: Bool
    , dependencies :: [(Package.Name, C.Constraint)]
    }


defaultDescription :: Description
defaultDescription =
    Description
    { name = Package.Name "user" "project"
    , repo = "https://github.com/user/project.git"
    , version = Package.initialVersion
    , elmVersion = C.defaultElmVersion
    , summary = "helpful summary of your project, less than 80 characters"
    , license = "BSD3"
    , sourceDirs = [ "." ]
    , exposed = []
    , natives = False
    , dependencies = []
    }



-- READ


read :: (MonadIO m, MonadError e m) => (String -> e) -> FilePath -> m Description
read toError path =
  do  json <- liftIO (BS.readFile path)
      either (throwError . toError) return (decodeDescription json)



-- WRITE


write :: Description -> IO ()
write description =
  BS.writeFile Path.description (prettyJSON description)



-- TO JSON


prettyJSON :: Description -> BS.ByteString
prettyJSON description =
    BS.snoc (prettyAngles (encodePretty' config description)) '\n'
  where
    config =
        defConfig { confCompare = keyOrder (normalKeys ++ dependencyKeys) }

    normalKeys =
        [ "version"
        , "summary"
        , "repository"
        , "license"
        , "source-directories"
        , "exposed-modules"
        , "native-modules"
        , "dependencies"
        , "elm-version"
        ]

    dependencyKeys =
        dependencies description
          |> map fst
          |> List.sort
          |> map (T.pack . Package.toString)


prettyAngles :: BS.ByteString -> BS.ByteString
prettyAngles string =
    BS.concat $ replaceAngles string


replaceAngles :: BS.ByteString -> [BS.ByteString]
replaceAngles str =
  let
    (before, after) =
      BS.break (=='\\') str
  in
    case BS.take 6 after of
      "\\u003e" ->
        before : ">" : replaceAngles (BS.drop 6 after)

      "\\u003c" ->
        before : "<" : replaceAngles (BS.drop 6 after)

      "" ->
        [before]

      _ ->
        before : "\\" : replaceAngles (BS.tail after)


instance ToJSON Description where
  toJSON d =
      object $
        [ "repository" .= repo d
        , "version" .= version d
        , "summary" .= summary d
        , "license" .= license d
        , "source-directories" .= sourceDirs d
        , "exposed-modules" .= map Module.RawForJson (exposed d)
        , "dependencies" .= jsonDeps (dependencies d)
        , "elm-version" .= elmVersion d
        ] ++ if natives d then ["native-modules" .= True] else []
    where
      jsonDeps deps =
          Map.fromList $ map (first (T.pack . Package.toString)) deps



-- FROM JSON


decodeDescription :: BS.ByteString -> Either String Description
decodeDescription bytestring =
  do  value <- eitherDecode bytestring <|> badJson
      parseEither getDescription value


badJson :: Either String a
badJson =
  Left $
    "I cannot parse the JSON. Maybe a comma is missing? Or there is an extra one?\n\
    \It could also be because of mismatched brackets or quotes.\n\
    \\n\
    \You can also check out the following example to see what it should look like:\n\
    \<https://raw.githubusercontent.com/elm-lang/html/master/elm-package.json>"


instance FromJSON Description where
  parseJSON = getDescription


getDescription :: Value -> Parser Description
getDescription value =
  case value of
    Object obj ->
      do  version <- get obj "version" "your project's version number"

          elmVersion <- getElmVersion obj

          summary <- get obj "summary" "a short summary of your project"
          when (length summary >= 80) $
              fail "The \"summary\" must be less than 80 characters"

          license <- get obj "license" "license information (BSD3 is recommended)"

          repo <- get obj "repository" "a link to the project's GitHub repo"
          name <- case repoToName repo of
                    Left err -> fail err
                    Right nm -> return nm

          exposed <- map Module.fromJson <$> get obj "exposed-modules" "a list of modules exposed to users"

          sourceDirs <- get obj "source-directories" "a list of directories containing source code"

          deps <- getDependencies obj

          natives <- maybe False id <$> obj .:? "native-modules"

          return $ Description name repo version elmVersion summary license sourceDirs exposed natives deps

    _ ->
      fail $
        "I was expecting a JSON object, like the one here:\n\
        \<https://raw.githubusercontent.com/elm-lang/html/master/elm-package.json>"


get :: FromJSON a => Object -> T.Text -> String -> Parser a
get obj field desc =
  do  maybe <- obj .:? field
      case maybe of
        Just value ->
          return value

        Nothing ->
          fail $
            "Missing field " ++ show field ++ " which should hold " ++ desc ++ ".\n\
            \\n\
            \Check out an example " ++ Path.description ++ " file here:\n\
            \<https://raw.githubusercontent.com/elm-lang/html/master/elm-package.json>"


getDependencies :: Object -> Parser [(Package.Name, C.Constraint)]
getDependencies obj =
  do  deps <- get obj "dependencies" "a list of the dependencies you need"
      forM (Map.toList deps) $ \(rawName, rawConstraint) ->
        case Package.fromString rawName of
          Left problem ->
            fail ("Ran into invalid package name \"" ++ rawName ++ "\" in dependencies.\n\n" ++ problem)

          Right name ->
            case C.fromString rawConstraint of
              Just constraint ->
                return (name, constraint)

              Nothing ->
                fail (C.errorMessage (Just rawName) rawConstraint)


getElmVersion :: Object -> Parser C.Constraint
getElmVersion obj =
  do  rawConstraint <- get obj "elm-version" elmVersionDescription
      case C.fromString rawConstraint of
        Just constraint ->
            return constraint

        Nothing ->
            fail (C.errorMessage (Just "the elm-version field") rawConstraint)


elmVersionDescription :: String
elmVersionDescription =
  "acceptable versions of the Elm Platform (e.g. \""
  ++ C.toString C.defaultElmVersion ++ "\")"


repoToName :: String -> Either String Package.Name
repoToName rawRepo =
  do  rawName <- dropDomain =<< dropExtension rawRepo
      case Package.fromString rawName of
        Left problem ->
            Left (repoProblem problem)

        Right name ->
            Right name


dropExtension :: String -> Either String String
dropExtension string =
    if List.isSuffixOf ".git" string then
        Right (take (length string - 4) string)

    else
        Left (repoProblem "The given URI does not end with .git")


dropDomain :: String -> Either String String
dropDomain string =
  let
    http = "https://github.com/"
    https = "https://github.com/"
  in
    if List.isPrefixOf http string then
        Right (drop (length http) string)

    else if List.isPrefixOf https string then
        Right (drop (length https) string)

    else
        Left (repoProblem "The given domain does not start with <https://github.com/>")


repoProblem :: String -> String
repoProblem problem =
  "Problem with the \"repository\" field.\n\n" ++ problem