{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} module Elm.Package.Description where import Prelude hiding (read) import Control.Applicative ((<$>)) import Control.Arrow (first) import Control.Monad.Error (MonadError, throwError, MonadIO, liftIO, when, mzero, forM) import Data.Aeson import Data.Aeson.Types (Parser) 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.Maybe as Maybe import qualified Data.Text as T import System.FilePath ((), (<.>)) import System.Directory (doesFileExist) import qualified Elm.Compiler.Module as Module import qualified Elm.Package.Name as N import qualified Elm.Package.Version as V import qualified Elm.Package.Constraint as C import qualified Elm.Package.Paths as Path import Elm.Utils ((|>)) data Description = Description { name :: N.Name , repo :: String , version :: V.Version , elmVersion :: C.Constraint , summary :: String , license :: String , sourceDirs :: [FilePath] , exposed :: [Module.Name] , natives :: Bool , dependencies :: [(N.Name, C.Constraint)] } defaultDescription :: Description defaultDescription = Description { name = N.Name "USER" "PROJECT" , repo = "https://github.com/USER/PROJECT.git" , version = V.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 String m) => FilePath -> m Description read path = do json <- liftIO (BS.readFile path) case eitherDecode json of Left err -> throwError $ "Error reading file " ++ path ++ ":\n " ++ err Right ds -> return ds -- WRITE write :: Description -> IO () write description = BS.writeFile Path.description json where json = prettyJSON description -- FIND MODULE FILE PATHS locateExposedModules :: (MonadIO m, MonadError String m) => Description -> m [(Module.Name, FilePath)] locateExposedModules desc = mapM locate (exposed desc) where locate modul = let path = Module.nameToPath modul <.> "elm" dirs = sourceDirs desc in do possibleLocations <- forM dirs $ \dir -> do exists <- liftIO $ doesFileExist (dir path) return (if exists then Just (dir path) else Nothing) case Maybe.catMaybes possibleLocations of [] -> throwError $ unlines [ "Could not find exposed module '" ++ Module.nameToString modul ++ "' when looking through" , "the following source directories:" , concatMap ("\n " ++) dirs , "" , "You may need to add a source directory to your " ++ Path.description ++ " file." ] [location] -> return (modul, location) locations -> throwError $ unlines [ "I found more than one module named '" ++ Module.nameToString modul ++ "' in the" , "following locations:" , concatMap ("\n " ++) locations , "" , "Module names must be unique within your package." ] -- JSON prettyJSON :: Description -> BS.ByteString prettyJSON description = prettyAngles (encodePretty' config description) 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 . N.toString) prettyAngles :: BS.ByteString -> BS.ByteString prettyAngles string = BS.concat $ replaceChunks string where replaceChunks str = let (before, after) = BS.break (=='\\') str in case BS.take 6 after of "\\u003e" -> before : ">" : replaceChunks (BS.drop 6 after) "\\u003c" -> before : "<" : replaceChunks (BS.drop 6 after) "" -> [before] _ -> before : "\\" : replaceChunks (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" .= 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 . N.toString)) deps instance FromJSON Description where parseJSON (Object obj) = do version <- get obj "version" "your projects version number" elmVersion <- getElmVersion obj summary <- get obj "summary" "a short summary of your project" when (length summary >= 80) $ fail "'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 <- get obj "exposed-modules" "a list of modules exposed to users" sourceDirs <- get obj "source-directories" "the directories that hold source code" deps <- getDependencies obj natives <- maybe False id <$> obj .:? "native-modules" return $ Description name repo version elmVersion summary license sourceDirs exposed natives deps parseJSON _ = mzero 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 ++ ", " ++ desc ++ ".\n" ++ " Check out an example " ++ Path.description ++ " file here:\n" ++ " " getDependencies :: Object -> Parser [(N.Name, C.Constraint)] getDependencies obj = do deps <- get obj "dependencies" "a listing of your project's dependencies" forM (Map.toList deps) $ \(rawName, rawConstraint) -> case (N.fromString rawName, C.fromString rawConstraint) of (Just name, Just constraint) -> return (name, constraint) (Nothing, _) -> fail (N.errorMsg rawName) (_, Nothing) -> fail (C.errorMessage 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 rawConstraint) elmVersionDescription :: String elmVersionDescription = "acceptable versions of the Elm Platform (e.g. \"" ++ C.toString C.defaultElmVersion ++ "\")" repoToName :: String -> Either String N.Name repoToName repo = if not (end `List.isSuffixOf` repo) then Left msg else do path <- getPath let raw = take (length path - length end) path case N.fromString raw of Nothing -> Left msg Just name -> Right name where getPath | http `List.isPrefixOf` repo = Right $ drop (length http ) repo | https `List.isPrefixOf` repo = Right $ drop (length https) repo | otherwise = Left msg http = "http://github.com/" https = "https://github.com/" end = ".git" msg = "the 'repository' field must point to a GitHub project for now, something\n\ \like where USER is your GitHub name\n\ \and PROJECT is the repo you want to upload."