From cc7f71385af841022fca3155c449cff91b3b728c Mon Sep 17 00:00:00 2001 From: David Nalchevanidze Date: Thu, 6 Jun 2024 10:44:04 +0200 Subject: [PATCH] hconf-cli (#863) * hconf-cli * hconf * cli/conf * cli/hconf * hconf * checkout * yaml * fix * shell * add npm i * add path * cli * add cli * prefix * update * add hconf * hconf * add to path * update * update * hconf * hconf * PATH * path * cd * update * update * version * hconf * hconf * update * hconf * setup --- .github/actions/setup-hs/action.yaml | 11 +- .github/workflows/haskell-ci.yml | 27 --- .github/workflows/publish-release.yaml | 7 +- hconf.yaml | 4 - hconf/LICENSE | 21 --- hconf/README.md | 245 ------------------------- hconf/app/CLI/Commands.hs | 91 --------- hconf/app/Main.hs | 46 ----- hconf/hconf.cabal | 95 ---------- hconf/package.yaml | 41 ----- hconf/src/HConf.hs | 42 ----- hconf/src/HConf/Config/Build.hs | 73 -------- hconf/src/HConf/Config/Config.hs | 78 -------- hconf/src/HConf/Config/ConfigT.hs | 85 --------- hconf/src/HConf/Config/PkgGroup.hs | 57 ------ hconf/src/HConf/Config/Tag.hs | 55 ------ hconf/src/HConf/Core/Bounds.hs | 134 -------------- hconf/src/HConf/Core/Dependencies.hs | 64 ------- hconf/src/HConf/Core/Env.hs | 11 -- hconf/src/HConf/Core/Version.hs | 112 ----------- hconf/src/HConf/Hie.hs | 78 -------- hconf/src/HConf/Stack/Cabal.hs | 92 ---------- hconf/src/HConf/Stack/Config.hs | 68 ------- hconf/src/HConf/Stack/Lib.hs | 96 ---------- hconf/src/HConf/Stack/Package.hs | 91 --------- hconf/src/HConf/Utils/Chalk.hs | 29 --- hconf/src/HConf/Utils/Class.hs | 32 ---- hconf/src/HConf/Utils/Core.hs | 121 ------------ hconf/src/HConf/Utils/Format.hs | 25 --- hconf/src/HConf/Utils/Http.hs | 35 ---- hconf/src/HConf/Utils/Log.hs | 58 ------ hconf/src/HConf/Utils/Yaml.hs | 71 ------- hie.yaml | 4 - package.json | 2 +- scripts/cli.ts | 3 + scripts/lib/format.ts | 4 +- scripts/lib/hconf.ts | 23 +++ stack.yaml | 1 - 38 files changed, 38 insertions(+), 2094 deletions(-) delete mode 100644 hconf/LICENSE delete mode 100644 hconf/README.md delete mode 100644 hconf/app/CLI/Commands.hs delete mode 100644 hconf/app/Main.hs delete mode 100644 hconf/hconf.cabal delete mode 100644 hconf/package.yaml delete mode 100644 hconf/src/HConf.hs delete mode 100644 hconf/src/HConf/Config/Build.hs delete mode 100644 hconf/src/HConf/Config/Config.hs delete mode 100644 hconf/src/HConf/Config/ConfigT.hs delete mode 100644 hconf/src/HConf/Config/PkgGroup.hs delete mode 100644 hconf/src/HConf/Config/Tag.hs delete mode 100644 hconf/src/HConf/Core/Bounds.hs delete mode 100644 hconf/src/HConf/Core/Dependencies.hs delete mode 100644 hconf/src/HConf/Core/Env.hs delete mode 100644 hconf/src/HConf/Core/Version.hs delete mode 100644 hconf/src/HConf/Hie.hs delete mode 100644 hconf/src/HConf/Stack/Cabal.hs delete mode 100644 hconf/src/HConf/Stack/Config.hs delete mode 100644 hconf/src/HConf/Stack/Lib.hs delete mode 100644 hconf/src/HConf/Stack/Package.hs delete mode 100644 hconf/src/HConf/Utils/Chalk.hs delete mode 100644 hconf/src/HConf/Utils/Class.hs delete mode 100644 hconf/src/HConf/Utils/Core.hs delete mode 100644 hconf/src/HConf/Utils/Format.hs delete mode 100644 hconf/src/HConf/Utils/Http.hs delete mode 100644 hconf/src/HConf/Utils/Log.hs delete mode 100644 hconf/src/HConf/Utils/Yaml.hs create mode 100644 scripts/lib/hconf.ts diff --git a/.github/actions/setup-hs/action.yaml b/.github/actions/setup-hs/action.yaml index 909a94a471..faf5e50bf1 100644 --- a/.github/actions/setup-hs/action.yaml +++ b/.github/actions/setup-hs/action.yaml @@ -8,10 +8,15 @@ inputs: runs: using: "composite" steps: - - name: Setup Node - uses: actions/setup-node@v3 + - uses: actions/setup-node@v3 + - name: Download HConf + shell: bash + run: | + npm i + npm run hconf + hconf setup ${{ inputs.ghc }} - - name: Setup Haskell + - name: HConf Haskell uses: haskell/actions/setup@v1.2 with: ghc-version: ${{ inputs.ghc }} diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 66d99827d4..4186604fd7 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,24 +8,7 @@ on: - main jobs: - hconf: - runs-on: ubuntu-latest - steps: - - uses: actions/checkout@v4 - - uses: ./.github/actions/setup-hs - - name: Build - run: | - stack build hconf - mkdir cli - cp $(stack exec which hconf) ./cli/hconf - - - uses: actions/upload-artifact@v4 - with: - name: hconf-cli - path: ./cli - build: - needs: hconf strategy: matrix: ghc: ["8.4.4", "8.6.5", "8.8.3", "8.10.7", "9.0.2", "latest"] @@ -34,16 +17,6 @@ jobs: name: GHC ${{ matrix.ghc}} steps: - uses: actions/checkout@v4 - - uses: actions/download-artifact@v4 - with: - name: hconf-cli - path: ./cli - - - name: Setup file - run: | - chmod +x ./cli/hconf - ./cli/hconf setup ${{ matrix.ghc }} - - name: Setup uses: ./.github/actions/setup-hs with: diff --git a/.github/workflows/publish-release.yaml b/.github/workflows/publish-release.yaml index 730176d093..16847c8280 100644 --- a/.github/workflows/publish-release.yaml +++ b/.github/workflows/publish-release.yaml @@ -13,7 +13,7 @@ jobs: tag_name: ${{ steps.describe.outputs.version }} steps: - uses: actions/checkout@v2 - - uses: haskell/actions/setup@v1.2 + - uses: ./.github/actions/setup-hs - name: Upload Packages run: | stack sdist @@ -30,11 +30,6 @@ jobs: HACKAGE_USERNAME: ${{ secrets.HACKAGE_USERNAME }} HACKAGE_PASSWORD: ${{ secrets.HACKAGE_PASSWORD }} - - name: Node - uses: actions/setup-node@v1 - with: - node-version: 14.x - - name: Describe id: describe run: echo "VERSION=$(hconf version)" >> $GITHUB_OUTPUT diff --git a/hconf.yaml b/hconf.yaml index 6f478a32c7..b4735fcf81 100644 --- a/hconf.yaml +++ b/hconf.yaml @@ -26,10 +26,6 @@ groups: - benchmarks - . prefix: true - - name: hconf - packages: - - hconf - dir: ./ builds: - ghc: 8.4.4 resolver: lts-12.26 diff --git a/hconf/LICENSE b/hconf/LICENSE deleted file mode 100644 index ca870fea1b..0000000000 --- a/hconf/LICENSE +++ /dev/null @@ -1,21 +0,0 @@ -MIT License - -Copyright (c) 2019 Daviti Nalchevanidze - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. \ No newline at end of file diff --git a/hconf/README.md b/hconf/README.md deleted file mode 100644 index b844abaf23..0000000000 --- a/hconf/README.md +++ /dev/null @@ -1,245 +0,0 @@ -# Morpheus GraphQL [![Hackage](https://img.shields.io/hackage/v/morpheus-graphql.svg)](https://hackage.haskell.org/package/morpheus-graphql) ![CI](https://github.com/morpheusgraphql/morpheus-graphql/workflows/CI/badge.svg) - -Build GraphQL APIs with your favorite functional language! - -Morpheus GraphQL (Server & Client) helps you to build GraphQL APIs in Haskell with native Haskell types. -Morpheus will convert your Haskell types to a GraphQL schema and all your resolvers are just native Haskell functions. Morpheus GraphQL can also convert your GraphQL Schema or Query to Haskell types and validate them in compile time. - -Morpheus is still in an early stage of development, so any feedback is more than welcome, and we appreciate any contribution! -Just open an issue here on GitHub, or join [our Slack channel](https://morpheus-graphql-slack-invite.herokuapp.com/) to get in touch. - -Please note that this readme file provides only a brief introduction to the library. If you are interested in more advanced topics, visit [Docs](https://morpheusgraphql.com/). - -## Getting Started - -### Setup - -To get started with Morpheus, you first need to add it to your project's dependencies, as follows (assuming you're using hpack): - -_package.yml_ - -```yaml -dependencies: - - morpheus-graphql -``` - -Additionally, you should tell stack which version to pick: - -_stack.yml_ - -```yaml -resolver: lts-16.2 - -extra-deps: - - morpheus-graphql-0.17.0 - - morpheus-graphql-app-0.17.0 - - morpheus-graphql-core-0.17.0 -``` - -As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update` - -### Building your first GraphQL API - -### with GraphQL syntax - -_schema.gql_ - -```gql -type Query { - deity(name: String! = "Morpheus"): Deity! -} - -""" -Description for Deity -""" -type Deity { - """ - Description for name - """ - name: String! - power: String @deprecated(reason: "some reason for") -} -``` - -_API.hs_ - -```haskell -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module API (api) where - -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Morpheus (interpreter) -import Data.Morpheus.Document (importGQLDocument) -import Data.Morpheus.Types (RootResolver (..), Undefined (..)) -import Data.Text (Text) - -importGQLDocument "schema.gql" - -rootResolver :: RootResolver IO () Query Undefined Undefined -rootResolver = - RootResolver - { queryResolver = Query {deity}, - mutationResolver = Undefined, - subscriptionResolver = Undefined - } - where - deity DeityArgs {name} = - pure - Deity - { name = pure name, - power = pure (Just "Shapeshifting") - } - -api :: ByteString -> IO ByteString -api = interpreter rootResolver -``` - -Template Haskell Generates types: `Query` , `Deity`, `DeityArgs`, that can be used by `rootResolver` - -`descriptions` and `deprecations` will be displayed in introspection. - -`importGQLDocumentWithNamespace` will generate Types with namespaced fields. If you don't need namespace use `importGQLDocument` - -### with Native Haskell Types - -To define a GraphQL API with Morpheus we start by defining the API Schema as a native Haskell data type, -which derives the `Generic` type class. Using the `DeriveAnyClass` language extension we then also derive instances for the `GQLType` type class. Lazily resolvable fields on this `Query` type are defined via `a -> ResolverQ () IO b`, representing resolving a set of arguments `a` to a concrete value `b`. - -```haskell -data Query m = Query - { deity :: DeityArgs -> m Deity - } deriving (Generic, GQLType) - -data Deity = Deity - { fullName :: Text -- Non-Nullable Field - , power :: Maybe Text -- Nullable Field - } deriving (Generic, GQLType) - -data DeityArgs = DeityArgs - { name :: Text -- Required Argument - , mythology :: Maybe Text -- Optional Argument - } deriving (Generic, GQLType) -``` - -For each field in the `Query` type defined via `a -> m b` (like `deity`) we will define a resolver implementation that provides the values during runtime by referring to -some data source, e.g. a database or another API. Fields that are defined without `a -> m b` you can just provide a value. - -In above example, the field of `DeityArgs` could also be named using reserved identities (such as: `type`, `where`, etc), in order to avoid conflict, a prime symbol (`'`) must be attached. For example, you can have: - -```haskell -data DeityArgs = DeityArgs - { name :: Text -- Required Argument - , mythology :: Maybe Text -- Optional Argument - , type' :: Text - } deriving (Generic, GQLType) -``` - -The field name in the final request will be `type` instead of `type'`. The Morpheus request parser converts each of the reserved identities in Haskell 2010 to their corresponding names internally. This also applies to selections. - -```haskell -resolveDeity :: DeityArgs -> ResolverQ () IO Deity -resolveDeity DeityArgs { name, mythology } = liftEither $ dbDeity name mythology - -askDB :: Text -> Maybe Text -> IO (Either String Deity) -askDB = ... -``` - -To make this `Query` type available as an API, we define a `RootResolver` and feed it to the Morpheus `interpreter`. A `RootResolver` consists of `query`, `mutation` and `subscription` definitions, while we omit the latter for this example: - -```haskell -rootResolver :: RootResolver IO () Query Undefined Undefined -rootResolver = - RootResolver - { queryResolver = Query {deity = resolveDeity} - , mutationResolver = Undefined - , subscriptionResolver = Undefined - } - -gqlApi :: ByteString -> IO ByteString -gqlApi = interpreter rootResolver -``` - -As you can see, the API is defined as `ByteString -> IO ByteString` which we can either invoke directly or use inside an arbitrary web framework -such as `scotty` or `serverless-haskell`. We'll go for `scotty` in this example: - -```haskell -main :: IO () -main = scotty 3000 $ post "/api" $ raw =<< (liftIO . gqlApi =<< body) -``` - -If we now send a POST request to `http://localhost:3000/api` with a GraphQL Query as body for example in a tool like `Insomnia`: - -```GraphQL -query GetDeity { - deity (name: "Morpheus") { - fullName - power - } -} -``` - -our query will be resolved! - -```JSON -{ - "data": { - "deity": { - "fullName": "Morpheus", - "power": "Shapeshifting" - } - } -} -``` - -## Serverless Example - -If you are interested in creating a `Morpheus GraphQL` API with `Serverless`, you should take a look at our example in this repository: -[_Mythology API_](https://github.com/morpheusgraphql/mythology-api) it is our example project build with `Morpheus GraphQL` and `Serverless-Haskell`, -where you can query different mythology characters with `GraphiQL`. - -Mythology API is deployed on : [_api.morpheusgraphql.com_](https://api.morpheusgraphql.com) where you can test it with `GraphiQL` - -![Mythology Api](https://morpheusgraphql.com/assets/img/mythology-api.png "mythology-api") - -## Showcase - -Below are the list of projects using Morpheus GraphQL. If you want to start using Morpheus GraphQL, they are -good templates to begin with. - -- https://github.com/morpheusgraphql/mythology-api - - Serverless Mythology API -- https://github.com/dandoh/web-haskell - - Modern webserver boilerplate in Haskell: Morpheus Graphql + Postgresql + Authentication + DB migration + Dotenv and more - -_Edit this section and send PR if you want to share your project_. - -# About - -## The name - -_Morpheus_ is the greek god of sleep and dreams whose name comes from the greek word _μορφή_ meaning form or shape. -He is said to be able to mimic different forms and GraphQL is good at doing exactly that: Transforming data in the shape -of many different APIs. - -## Team - -Morpheus is written and maintained by [_nalchevanidze_](https://github.com/nalchevanidze) - -## Roadmap - -- Medium future: - - Stabilize API - - Specification-isomorphic error handling -- Long term: - - Support all possible GQL features - - Performance optimization diff --git a/hconf/app/CLI/Commands.hs b/hconf/app/CLI/Commands.hs deleted file mode 100644 index 6bb33a85cb..0000000000 --- a/hconf/app/CLI/Commands.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module CLI.Commands - ( GlobalOptions (..), - App (..), - Command (..), - parseCLI, - ) -where - -import Options.Applicative - ( Parser, - command, - customExecParser, - fullDesc, - help, - helper, - info, - long, - metavar, - prefs, - progDesc, - short, - showHelpOnError, - strArgument, - subparser, - switch, - ) -import qualified Options.Applicative as OA -import Relude hiding (ByteString) - -data Command - = Setup (Maybe String) - | Next Bool - | UpperBounds - | About - | CurrentVersion - deriving (Show) - -data App = App - { operations :: Command, - options :: GlobalOptions - } - deriving (Show) - -data GlobalOptions = GlobalOptions - { version :: Bool, - silence :: Bool - } - deriving (Show) - -commandParser :: Parser Command -commandParser = - buildOperation - [ ("setup", "builds Haskell code from GQL source", Setup <$> optional parseVersion), - ("about", "api information", pure About), - ("update", "check/fix upper bounds for dependencies", pure UpperBounds), - ("next", "next release", Next <$> switch (long "breaking" <> short 'b')), - ("version", "get current version", pure CurrentVersion) - ] - -buildOperation :: [(String, String, Parser Command)] -> Parser Command -buildOperation xs = joinParsers $ map parseOperation xs - -joinParsers :: [OA.Mod OA.CommandFields a] -> Parser a -joinParsers xs = subparser $ mconcat xs - -parseOperation :: (String, String, Parser Command) -> OA.Mod OA.CommandFields Command -parseOperation (bName, bDesc, bValue) = - command bName (info (helper <*> bValue) (fullDesc <> progDesc bDesc)) - -parseVersion :: Parser String -parseVersion = (strArgument . mconcat) [metavar "version", help "existing version"] - -parseCLI :: IO App -parseCLI = - customExecParser - (prefs showHelpOnError) - (info (helper <*> parseApp) description) - -parseApp :: OA.Parser App -parseApp = App <$> commandParser <*> parseOptions - -parseOptions :: Parser GlobalOptions -parseOptions = - GlobalOptions - <$> switch (long "version" <> short 'v' <> help "show Version number") - <*> switch (long "silence" <> short 's' <> help "show Version number") - -description :: OA.InfoMod a -description = fullDesc <> progDesc "Morpheus GraphQL CLI - haskell Api Generator" diff --git a/hconf/app/Main.hs b/hconf/app/Main.hs deleted file mode 100644 index 7c934df78f..0000000000 --- a/hconf/app/Main.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Main - ( main, - ) -where - -import CLI.Commands - ( App (..), - Command (..), - GlobalOptions (..), - parseCLI, - ) -import Data.Version (showVersion) -import HConf (Env (..), getVersion, setup, updateVersion, upperBounds) -import qualified Paths_hconf as CLI -import Relude hiding (ByteString) - -currentVersion :: String -currentVersion = showVersion CLI.version - -main :: IO () -main = parseCLI >>= runApp - -env :: Env -env = - Env - { hconf = "./hconf.yaml", - hie = "./hie.yaml", - stack = "./stack.yaml", - silence = False - } - -runApp :: App -> IO () -runApp App {..} - | version options = putStrLn currentVersion - | otherwise = runOperation operations - where - runOperation About = putStrLn $ "Stack Config CLI, version " <> currentVersion - runOperation (Setup version) = setup (fromMaybe "latest" version) env - runOperation (Next isBreaking) = updateVersion isBreaking env - runOperation UpperBounds = upperBounds env - runOperation CurrentVersion = getVersion env diff --git a/hconf/hconf.cabal b/hconf/hconf.cabal deleted file mode 100644 index e224a2a931..0000000000 --- a/hconf/hconf.cabal +++ /dev/null @@ -1,95 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.36.0. --- --- see: https://github.com/sol/hpack - -name: hconf -version: 0.27.3 -synopsis: Stack Config -description: cli to manage multiple stack projects -category: web, graphql -homepage: https://github.com/nalchevanidze/morpheus-graphql#readme -bug-reports: https://github.com/nalchevanidze/morpheus-graphql/issues -author: Daviti Nalchevanidze -maintainer: d.nalchevanidze@gmail.com -copyright: (c) 2019 Daviti Nalchevanidze -license: MIT -license-file: LICENSE -build-type: Simple -extra-source-files: - README.md - -source-repository head - type: git - location: https://github.com/nalchevanidze/morpheus-graphql - -library - exposed-modules: - HConf - other-modules: - HConf.Config.Build - HConf.Config.Config - HConf.Config.ConfigT - HConf.Config.PkgGroup - HConf.Config.Tag - HConf.Core.Bounds - HConf.Core.Dependencies - HConf.Core.Env - HConf.Core.Version - HConf.Hie - HConf.Stack.Cabal - HConf.Stack.Config - HConf.Stack.Lib - HConf.Stack.Package - HConf.Utils.Chalk - HConf.Utils.Class - HConf.Utils.Core - HConf.Utils.Format - HConf.Utils.Http - HConf.Utils.Log - HConf.Utils.Yaml - Paths_hconf - hs-source-dirs: - src - ghc-options: -Wall - build-depends: - aeson >=1.4.4 && <3.0.0 - , base >=4.7.0 && <5.0.0 - , bytestring >=0.10.4 && <0.15.0 - , containers >=0.4.2.1 && <=0.7 - , filepath >=1.1.0 && <=1.5.2.0 - , modern-uri >=0.1.0.0 && <1.0.0 - , process >=1.0 && <2.0 - , relude >=0.3.0 && <2.0.0 - , req >=3.0.0 && <4.0.0 - , text >=1.2.3 && <3.0.0 - , unordered-containers >=0.2.8 && <0.3.0 - , yaml >=0.8.32 && <1.0.0 - default-language: Haskell2010 - -executable hconf - main-is: Main.hs - other-modules: - CLI.Commands - Paths_hconf - hs-source-dirs: - app - ghc-options: -Wall - build-depends: - Glob >=0.7.0 && <1.0.0 - , aeson >=1.4.4 && <3.0.0 - , base >=4.7.0 && <5.0.0 - , bytestring >=0.10.4 && <0.15.0 - , containers >=0.4.2.1 && <=0.7 - , filepath >=1.1.0 && <=1.5.2.0 - , hconf >=0.27.0 && <0.28.0 - , modern-uri >=0.1.0.0 && <1.0.0 - , optparse-applicative >=0.12.0 && <0.20.0 - , process >=1.0 && <2.0 - , relude >=0.3.0 && <2.0.0 - , req >=3.0.0 && <4.0.0 - , text >=1.2.3 && <3.0.0 - , unordered-containers >=0.2.8 && <0.3.0 - , yaml >=0.8.32 && <1.0.0 - default-language: Haskell2010 diff --git a/hconf/package.yaml b/hconf/package.yaml deleted file mode 100644 index 2e6ba39ac7..0000000000 --- a/hconf/package.yaml +++ /dev/null @@ -1,41 +0,0 @@ -name: hconf -version: 0.27.3 -github: nalchevanidze/morpheus-graphql -license: MIT -author: Daviti Nalchevanidze -category: web, graphql -synopsis: Stack Config -maintainer: d.nalchevanidze@gmail.com -copyright: (c) 2019 Daviti Nalchevanidze -license-file: LICENSE -description: cli to manage multiple stack projects -extra-source-files: -- README.md -dependencies: -- aeson >= 1.4.4 && < 3.0.0 -- base >= 4.7.0 && < 5.0.0 -- bytestring >= 0.10.4 && < 0.15.0 -- containers >= 0.4.2.1 && <= 0.7 -- filepath >= 1.1.0 && <= 1.5.2.0 -- modern-uri >= 0.1.0.0 && < 1.0.0 -- process >= 1.0 && < 2.0 -- relude >= 0.3.0 && < 2.0.0 -- req >= 3.0.0 && < 4.0.0 -- text >= 1.2.3 && < 3.0.0 -- unordered-containers >= 0.2.8 && < 0.3.0 -- yaml >= 0.8.32 && < 1.0.0 -library: - source-dirs: src - ghc-options: -Wall - exposed-modules: - - HConf -executables: - hconf: - main: Main.hs - source-dirs: app - ghc-options: -Wall - dependencies: - - Glob >= 0.7.0 && < 1.0.0 - - filepath >= 1.1.0 && <= 1.5.2.0 - - hconf >= 0.27.0 && < 0.28.0 - - optparse-applicative >= 0.12.0 && < 0.20.0 diff --git a/hconf/src/HConf.hs b/hconf/src/HConf.hs deleted file mode 100644 index 1ebf255825..0000000000 --- a/hconf/src/HConf.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf - ( setup, - Env (..), - updateVersion, - VersionTag, - Parse (..), - getVersion, - upperBounds, - ) -where - -import HConf.Config.Config (Config (..), updateConfig, updateConfigUpperBounds) -import HConf.Config.ConfigT (HCEnv (..), run, runTask, save) -import HConf.Config.Tag (VersionTag) -import HConf.Core.Env (Env (..)) -import HConf.Hie (genHie) -import HConf.Stack.Config (setupStack) -import HConf.Stack.Package (checkPackages) -import HConf.Utils.Class (Parse (..)) -import Relude - -upperBounds :: Env -> IO () -upperBounds = - runTask "upper-bounds" $ - asks config - >>= updateConfigUpperBounds - >>= save - -setup :: String -> Env -> IO () -setup v = runTask "setup" $ do - parse v >>= setupStack - genHie - checkPackages - -updateVersion :: Bool -> Env -> IO () -updateVersion isBreaking = runTask "next" $ (asks config <&> updateConfig isBreaking) >>= save - -getVersion :: Env -> IO () -getVersion = run (Just . version <$> asks config) diff --git a/hconf/src/HConf/Config/Build.hs b/hconf/src/HConf/Config/Build.hs deleted file mode 100644 index 718bc84522..0000000000 --- a/hconf/src/HConf/Config/Build.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Config.Build - ( Build (..), - Builds, - findBuild, - getExtras, - ) -where - -import Data.Aeson - ( FromJSON (..), - Options (..), - ToJSON (toJSON), - genericToJSON, - ) -import Data.Aeson.Types - ( defaultOptions, - ) -import qualified Data.Map as M -import Data.Text (unpack) -import HConf.Config.Tag (VersionTag) -import HConf.Core.Version (Version, checkVersion) -import HConf.Utils.Class (Check (..)) -import HConf.Utils.Core (notElemError) -import Relude hiding - ( Undefined, - group, - intercalate, - isPrefixOf, - ) - -type Extras = Map Text Version - -data Build = Build - { ghc :: VersionTag, - resolver :: Text, - extra :: Maybe Extras, - include :: Maybe [Text], - exclude :: Maybe [Text] - } - deriving - ( Generic, - FromJSON, - Show - ) - -instance ToJSON Build where - toJSON = genericToJSON defaultOptions {omitNothingFields = True} - -instance Check Build where - check Build {..} = - traverse_ - (checkVersion . first unpack) - (maybe [] M.toList extra) - -type Builds = [Build] - -findBuild :: (MonadFail m) => VersionTag -> Builds -> m Build -findBuild v builds = maybe (notElemError "build" (show v) (map ghc builds)) pure (find ((== v) . ghc) builds) - -selectBuilds :: VersionTag -> [Build] -> [Build] -selectBuilds v = sortBy (\a b -> compare (ghc b) (ghc a)) . filter ((v <=) . ghc) - -getExtras :: VersionTag -> [Build] -> Extras -getExtras version = M.fromList . concatMap getExtra . selectBuilds version - -getExtra :: Build -> [(Text, Version)] -getExtra b = maybe [] M.toList (extra b) diff --git a/hconf/src/HConf/Config/Config.hs b/hconf/src/HConf/Config/Config.hs deleted file mode 100644 index b1be0fe82b..0000000000 --- a/hconf/src/HConf/Config/Config.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | GQL Types -module HConf.Config.Config - ( Config (..), - getPackages, - getBuild, - getRule, - updateConfig, - updateConfigUpperBounds, - ) -where - -import Data.Aeson - ( FromJSON (..), - Options (..), - ToJSON (toJSON), - genericToJSON, - ) -import Data.Aeson.Types (defaultOptions) -import HConf.Config.Build (Build, Builds, findBuild) -import HConf.Config.PkgGroup (PkgGroup, isMember, toPackageName) -import HConf.Config.Tag (VersionTag) -import HConf.Core.Bounds (Bounds, updateUpperBound, versionBounds) -import HConf.Core.Dependencies (Dependencies, getBounds, traverseDeps) -import HConf.Core.Version (Version, nextVersion) -import HConf.Utils.Class (Check (check)) -import HConf.Utils.Log (Log (..)) -import Relude hiding - ( Undefined, - group, - intercalate, - isPrefixOf, - ) - -data Config = Config - { version :: Version, - bounds :: Bounds, - groups :: [PkgGroup], - builds :: Builds, - dependencies :: Dependencies - } - deriving - ( Generic, - FromJSON, - Show - ) - -getRule :: (MonadFail m) => Text -> Config -> m Bounds -getRule name Config {..} - | any (isMember name) groups = pure bounds - | otherwise = getBounds name dependencies - -getPackages :: Config -> [Text] -getPackages Config {..} = concatMap toPackageName groups - -getBuild :: (MonadFail m) => VersionTag -> Config -> m Build -getBuild key = findBuild key . builds - -instance ToJSON Config where - toJSON = genericToJSON defaultOptions {omitNothingFields = True} - -instance Check Config where - check Config {..} = traverse_ check (toList builds) - -updateConfig :: Bool -> Config -> Config -updateConfig isBreaking Config {..} = - let version' = nextVersion isBreaking version - bounds' = versionBounds version' - in Config {version = version', bounds = bounds', ..} - -updateConfigUpperBounds :: (MonadFail m, MonadIO m, Log m) => Config -> m Config -updateConfigUpperBounds Config {..} = do - dependencies' <- traverseDeps updateUpperBound dependencies - pure Config {dependencies = dependencies', ..} diff --git a/hconf/src/HConf/Config/ConfigT.hs b/hconf/src/HConf/Config/ConfigT.hs deleted file mode 100644 index 597e93602b..0000000000 --- a/hconf/src/HConf/Config/ConfigT.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Config.ConfigT - ( ConfigT (..), - packages, - HCEnv (..), - save, - run, - runTask, - ) -where - -import Control.Exception (tryJust) -import HConf.Config.Config (Config, getPackages) -import HConf.Core.Env (Env (..)) -import HConf.Utils.Chalk (Color (Green), chalk) -import HConf.Utils.Class (Check (..), HConfIO (..)) -import HConf.Utils.Core (Name) -import HConf.Utils.Log (Log (..), alert, label, task) -import HConf.Utils.Yaml (readYaml, writeYaml) -import Relude - -data HCEnv = HCEnv - { config :: Config, - env :: Env, - indention :: Int - } - -newtype ConfigT (a :: Type) = ConfigT {_runConfigT :: ReaderT HCEnv IO a} - deriving - ( Functor, - Applicative, - Monad, - MonadReader HCEnv, - MonadIO, - MonadFail - ) - -printException :: SomeException -> String -printException = show - -runConfigT :: ConfigT a -> Env -> Config -> IO (Either String a) -runConfigT (ConfigT (ReaderT f)) env config = tryJust (Just . printException) (f HCEnv {indention = 0, ..}) - -packages :: ConfigT [Name] -packages = getPackages <$> asks config - -indent :: Int -> String -indent i = replicate (i * 2) ' ' - -instance Log ConfigT where - log txt = do - i <- asks indention - liftIO $ putStrLn $ indent i <> txt - inside = local (\c -> c {indention = indention c + 1}) - -instance HConfIO ConfigT where - eitherRead = liftIO . eitherRead - read = liftIO . read - write f = liftIO . write f - -run :: (ToString a) => ConfigT (Maybe a) -> Env -> IO () -run m env@Env {..} = do - cfg <- readYaml hconf - runConfigT (asks config >>= check >> m) env cfg >>= handle - -runTask :: String -> ConfigT () -> Env -> IO () -runTask name m = run (label name m $> Just (chalk Green "Ok")) - -handle :: (ToString a) => (Log m, Monad m) => Either String (Maybe a) -> m () -handle res = case res of - Left x -> alert ("ERROR: " <> x) - (Right Nothing) -> pure () - (Right (Just msg)) -> log (toString msg) - -save :: Config -> ConfigT () -save cfg = label "save" $ task "hconf.yaml" $ do - ctx <- asks id - writeYaml (hconf $ env ctx) cfg diff --git a/hconf/src/HConf/Config/PkgGroup.hs b/hconf/src/HConf/Config/PkgGroup.hs deleted file mode 100644 index 814a523d9d..0000000000 --- a/hconf/src/HConf/Config/PkgGroup.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Config.PkgGroup - ( PkgGroup (..), - toPackageName, - isMember, - ) -where - -import Data.Aeson - ( FromJSON (..), - Options (..), - ToJSON (toJSON), - genericToJSON, - ) -import Data.Aeson.Types - ( defaultOptions, - ) -import Data.List (intercalate) -import Data.Text (isPrefixOf, pack, unpack) -import HConf.Utils.Core (Name) -import Relude hiding - ( Undefined, - group, - intercalate, - isPrefixOf, - ) -import System.FilePath.Posix (joinPath, normalise) - -data PkgGroup = PkgGroup - { name :: Name, - dir :: Maybe FilePath, - packages :: [Text], - prefix :: Maybe Bool - } - deriving - ( Generic, - FromJSON, - Show - ) - -instance ToJSON PkgGroup where - toJSON = genericToJSON defaultOptions {omitNothingFields = True} - -toPackageName :: PkgGroup -> [Text] -toPackageName PkgGroup {..} = map (pack . pkgPath) packages - where - pkgPath pkg = - let pkgName = intercalate "-" ([unpack name | fromMaybe False prefix] <> [unpack pkg | pkg /= "."]) - in normalise (joinPath (maybeToList dir <> [pkgName])) - -isMember :: Name -> PkgGroup -> Bool -isMember pkgName = (`isPrefixOf` pkgName) . name diff --git a/hconf/src/HConf/Config/Tag.hs b/hconf/src/HConf/Config/Tag.hs deleted file mode 100644 index dec98d43cb..0000000000 --- a/hconf/src/HConf/Config/Tag.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Config.Tag - ( VersionTag (..), - ) -where - -import Data.Aeson - ( FromJSON (..), - ToJSON (toJSON), - Value (..), - ) -import Data.Text (pack) -import GHC.Show (Show (show)) -import HConf.Core.Version (Version) -import HConf.Utils.Class (Parse (..)) -import Relude hiding (show) - -data VersionTag - = Version Version - | Latest - deriving - ( Generic, - Eq - ) - -instance Parse VersionTag where - parse = parseText . pack - parseText "latest" = pure Latest - parseText s = Version <$> parseText s - -instance ToString VersionTag where - toString Latest = "latest" - toString (Version v) = toString v - -instance Show VersionTag where - show = toString - -instance ToText VersionTag where - toText = pack . toString - -instance FromJSON VersionTag where - parseJSON (String s) = parseText s - parseJSON v = Version <$> parseJSON v - -instance ToJSON VersionTag where - toJSON = String . toText - -instance Ord VersionTag where - compare Latest Latest = EQ - compare Latest Version {} = GT - compare Version {} Latest = LT - compare (Version v1) (Version v2) = compare v1 v2 diff --git a/hconf/src/HConf/Core/Bounds.hs b/hconf/src/HConf/Core/Bounds.hs deleted file mode 100644 index f806117612..0000000000 --- a/hconf/src/HConf/Core/Bounds.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Core.Bounds - ( Bound (..), - Restriction (..), - Bounds (..), - versionBounds, - diff, - printBoundParts, - updateUpperBound, - ) -where - -import Data.Aeson - ( FromJSON (..), - ToJSON (toJSON), - Value (..), - ) -import Data.Char (isSeparator) -import Data.List (maximum) -import Data.Text - ( null, - pack, - ) -import qualified Data.Text as T -import GHC.Show (Show (show)) -import HConf.Core.Version (Version, dropPatch, fetchVersions, nextVersion) -import HConf.Utils.Chalk (Color (Yellow), chalk) -import HConf.Utils.Class (Parse (..)) -import HConf.Utils.Core (Name) -import HConf.Utils.Log (Log, field) -import Relude hiding - ( Undefined, - break, - drop, - fromList, - isPrefixOf, - length, - null, - show, - toList, - ) - -data Restriction = Min | Max deriving (Show, Eq, Ord) - -parseRestriction :: (MonadFail f) => Char -> f Restriction -parseRestriction '>' = pure Min -- > 0.7.0 -parseRestriction '<' = pure Max -- < 1.0.0 -parseRestriction x = fail ("unsorted bound type" <> show x) - -instance ToString Restriction where - toString Min = ">" -- > 0.7.0 - toString Max = "<" -- < 1.0.0 - -instance ToText Restriction where - toText = pack . toString - -data Bound = Bound - { restriction :: Restriction, - orEquals :: Bool, - version :: Version - } - deriving (Show, Eq) - -instance Ord Bound where - compare a b = - compare (version a) (version b) - <> compare (restriction a) (restriction b) - <> compare (orEquals a) (orEquals b) - -parseOrEquals :: [Char] -> (Bool, [Char]) -parseOrEquals ('=' : ver) = (True, ver) -parseOrEquals ver = (False, ver) - -printBoundPart :: Bound -> [Text] -printBoundPart Bound {..} = pack (toString restriction <> if orEquals then "=" else "") : [toText version] - -instance Parse Bound where - parseText = parse . T.unpack - parse (char : str) = do - res <- parseRestriction char - let (isStrict, value) = parseOrEquals str - Bound res isStrict <$> parse value - parse x = fail ("unsorted bound type" <> toString x) - -newtype Bounds = Bounds [Bound] - deriving (Generic, Show, Eq) - -instance Parse Bounds where - parse = parseText . pack - parseText str - | null str = pure $ Bounds [] - | otherwise = Bounds <$> traverse parseText (T.splitOn "&&" $ T.filter (not . isSeparator) str) - -instance ToString Bounds where - toString = intercalate " " . map toString . printBoundParts - -instance FromJSON Bounds where - parseJSON (String s) = parseText s - parseJSON v = fail $ "version should be either true or string" <> show v - -instance ToJSON Bounds where - toJSON = String . pack . toString - -versionBounds :: Version -> Bounds -versionBounds version = - Bounds - [ Bound Min True (dropPatch version), - Bound Max False (nextVersion True version) - ] - -diff :: Bounds -> Bounds -> String -diff old deps = toString old <> chalk Yellow " -> " <> toString deps - -printBoundParts :: Bounds -> [Text] -printBoundParts (Bounds xs) = intercalate ["&&"] $ map printBoundPart $ sort xs - -getBound :: Restriction -> Bounds -> Maybe Bound -getBound v (Bounds xs) = find (\Bound {..} -> restriction == v) xs - -getLatestBound :: (MonadFail m, MonadIO m) => Name -> m Bound -getLatestBound = fmap (Bound Max True . head) . fetchVersions . T.unpack - -updateUpperBound :: (MonadFail m, MonadIO m, Log m) => Name -> Bounds -> m Bounds -updateUpperBound name bounds = do - latest <- getLatestBound name - let ma = getBound Max bounds - let mi = maybeToList (getBound Min bounds) - let newVersion = maximum (latest : maybeToList ma) - if ma == Just newVersion then pure () else field (T.unpack name) (show newVersion) - pure (Bounds (mi <> [newVersion])) diff --git a/hconf/src/HConf/Core/Dependencies.hs b/hconf/src/HConf/Core/Dependencies.hs deleted file mode 100644 index 6519a0fc8d..0000000000 --- a/hconf/src/HConf/Core/Dependencies.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Core.Dependencies - ( Dependencies, - Dependency, - getBounds, - traverseDeps, - ) -where - -import Data.Aeson - ( FromJSON (..), - ToJSON (toJSON), - ) -import Data.Char (isSeparator) -import Data.Map (fromList, toList) -import qualified Data.Map as M -import Data.Map.Strict (traverseWithKey) -import Data.Text (break, pack, strip, unpack) -import HConf.Core.Bounds (Bounds, printBoundParts) -import HConf.Utils.Class (Parse (..)) -import HConf.Utils.Core (Name) -import HConf.Utils.Format (formatTable) -import Relude hiding - ( Undefined, - break, - drop, - fromList, - isPrefixOf, - length, - null, - show, - toList, - ) - -data Dependency = Dependency Name Bounds - -instance Parse Dependency where - parse = parseText . pack - parseText = - (\(name, txt) -> Dependency name <$> parseText txt) - . bimap strip strip - . break isSeparator - -newtype Dependencies = Dependencies {unpackDeps :: Map Name Bounds} - deriving (Show) - -getBounds :: (MonadFail m) => Text -> Dependencies -> m Bounds -getBounds name = maybe (fail $ "Unknown package: " <> unpack name) pure . M.lookup name . unpackDeps - -traverseDeps :: (Applicative f) => (Text -> Bounds -> f Bounds) -> Dependencies -> f Dependencies -traverseDeps f (Dependencies xs) = Dependencies <$> traverseWithKey f xs - -initDependencies :: [Dependency] -> Dependencies -initDependencies = Dependencies . fromList . map toDuple - where - toDuple (Dependency a b) = (a, b) - -instance FromJSON Dependencies where - parseJSON v = initDependencies <$> (parseJSON v >>= traverse parseText . sort) - -instance ToJSON Dependencies where - toJSON (Dependencies m) = toJSON $ formatTable $ map (\(name, b) -> name : printBoundParts b) (toList m) diff --git a/hconf/src/HConf/Core/Env.hs b/hconf/src/HConf/Core/Env.hs deleted file mode 100644 index fd1e4998f4..0000000000 --- a/hconf/src/HConf/Core/Env.hs +++ /dev/null @@ -1,11 +0,0 @@ -module HConf.Core.Env - ( Env (..), - ) -where - -data Env = Env - { hie :: FilePath, - hconf :: FilePath, - stack :: FilePath, - silence :: Bool - } diff --git a/hconf/src/HConf/Core/Version.hs b/hconf/src/HConf/Core/Version.hs deleted file mode 100644 index 9d8436c70a..0000000000 --- a/hconf/src/HConf/Core/Version.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Core.Version - ( nextVersion, - dropPatch, - checkVersion, - Version, - fetchVersions, - ) -where - -import Data.Aeson - ( FromJSON (..), - ToJSON (toJSON), - Value (..), - ) -import Data.List.NonEmpty (toList) -import Data.Map (lookup) -import Data.Text - ( pack, - split, - unpack, - ) -import GHC.Show (Show (show)) -import HConf.Utils.Class (Parse (..)) -import HConf.Utils.Core (checkElem) -import HConf.Utils.Http (hackage) -import Relude hiding - ( Undefined, - break, - drop, - fromList, - isPrefixOf, - length, - null, - show, - toList, - ) - -data Version = Version Int Int [Int] - deriving - ( Generic, - Eq - ) - -getNumber :: [Int] -> Int -getNumber (n : _) = n -getNumber [] = 0 - -nextVersion :: Bool -> Version -> Version -nextVersion isBreaking (Version major minor revision) - | isBreaking = Version major (minor + 1) [0] - | otherwise = Version major minor [getNumber revision + 1] - -dropPatch :: Version -> Version -dropPatch (Version ma mi _) = Version ma mi [0] - -compareSeries :: (Ord a) => [a] -> [a] -> Ordering -compareSeries [] _ = EQ -compareSeries _ [] = EQ -compareSeries (x : xs) (y : ys) - | x == y = compareSeries xs ys - | otherwise = compare x y - -instance Parse Version where - parse = parseText . pack - parseText s = toMonad fromSeries (parseSeries s) - where - toMonad = maybe (fail $ "invalid version: '" <> toString s <> "'!") - -parseSeries :: Text -> Maybe [Int] -parseSeries = traverse (readMaybe . unpack) . split (== '.') - -fromSeries :: (MonadFail m) => [Int] -> m Version -fromSeries [ma] = pure $ Version ma 0 [] -fromSeries (ma : (mi : xs)) = pure $ Version ma mi xs -fromSeries [] = fail "invalid version: version should have at least one number !" - -instance ToString Version where - toString (Version maj mi ns) = intercalate "." $ map show ([maj, mi] <> ns) - -instance Ord Version where - compare (Version maj1 min1 v1) (Version maj2 min2 v2) = compareSeries ([maj1, min1] <> v1) ([maj2, min2] <> v2) - -instance Show Version where - show = toString - -instance ToText Version where - toText = pack . toString - -instance FromJSON Version where - parseJSON (String s) = parseText s - parseJSON (Number n) = parse (show n) - parseJSON v = fail $ "version should be either true or string" <> show v - -instance ToJSON Version where - toJSON = String . toText - -fetchVersionResponse :: (MonadIO m, MonadFail m) => String -> m (Either String (Map Text (NonEmpty Version))) -fetchVersionResponse name = hackage ["package", name, "preferred"] - -lookupVersions :: (MonadFail m) => Either String (Map Text (NonEmpty Version)) -> m (NonEmpty Version) -lookupVersions (Right x) = maybe (fail "field normal-version not found") pure (lookup "normal-version" x) -lookupVersions (Left x) = fail x - -fetchVersions :: (MonadFail m, MonadIO m) => String -> m (NonEmpty Version) -fetchVersions name = fetchVersionResponse name >>= lookupVersions - -checkVersion :: (MonadFail m, MonadIO m) => (String, Version) -> m () -checkVersion (name, version) = fetchVersions name >>= checkElem "version" name version . toList diff --git a/hconf/src/HConf/Hie.hs b/hconf/src/HConf/Hie.hs deleted file mode 100644 index 2e3edcc1b3..0000000000 --- a/hconf/src/HConf/Hie.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | GQL Types -module HConf.Hie - ( genHie, - ) -where - -import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object) -import qualified Data.Map as M -import HConf.Config.ConfigT (ConfigT, HCEnv (..)) -import HConf.Core.Env (Env (..)) -import HConf.Stack.Lib (Libraries, Library (..)) -import HConf.Stack.Package (Package (..), resolvePackages) -import HConf.Utils.Log (label, task) -import HConf.Utils.Yaml (writeYaml) -import Relude hiding (Undefined, intercalate) - -data Component = Component - { path :: Text, - component :: Text - } - deriving - ( ToJSON, - FromJSON, - Generic, - Show - ) - -data Components = Components - { stackYaml :: FilePath, - components :: [Component] - } - deriving - ( ToJSON, - FromJSON, - Generic, - Show - ) - -packHie :: Components -> Value -packHie value = object [("cradle", object [("stack", toJSON value)])] - -(<:>) :: (Semigroup a, IsString a) => a -> a -> a -(<:>) name tag = name <> ":" <> tag - -toLib :: (Text, Package) -> [Component] -toLib (path, Package {..}) = - comp "lib" library - <> compGroup "test" tests - <> compGroup "exe" executables - <> compGroup "bench" benchmarks - where - compGroup :: Text -> Maybe Libraries -> [Component] - compGroup tag = concatMap mkComp . concatMap M.toList . maybeToList - where - mkComp (k, lib) = comp (tag <:> k) (Just lib) - comp :: Text -> Maybe Library -> [Component] - comp tag (Just Library {sourceDirs}) = - [ Component - { path = "./" <> path <> "/" <> sourceDirs, - component = name <:> tag - } - ] - comp _ _ = [] - -genHie :: ConfigT () -genHie = label "hie" $ - task "hie.yaml" $ do - Env {..} <- asks env - components <- concatMap toLib <$> resolvePackages - writeYaml hie (packHie Components {stackYaml = stack, components}) diff --git a/hconf/src/HConf/Stack/Cabal.hs b/hconf/src/HConf/Stack/Cabal.hs deleted file mode 100644 index 04e57b3256..0000000000 --- a/hconf/src/HConf/Stack/Cabal.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | GQL Types -module HConf.Stack.Cabal - ( checkCabal, - ) -where - -import qualified Data.ByteString.Char8 as BS (unpack) -import Data.Map (lookup) -import qualified Data.Text as T -import GHC.IO.Exception (ExitCode (..)) -import HConf.Config.ConfigT (ConfigT) -import HConf.Core.Version (Version) -import HConf.Utils.Class (HConfIO (..), Parse (..)) -import HConf.Utils.Core (Name) -import HConf.Utils.Log (alert, field, subTask, task, warn) -import Relude -import System.Process - -toLines :: Text -> [Text] -toLines = T.split (== '\n') - -parseFields :: ByteString -> Map Text Text -parseFields = - fromList - . filter (not . T.null . fst) - . map (bimap T.strip T.strip . (second (T.drop 1) . T.breakOn ":") . T.strip) - . toLines - . T.pack - . BS.unpack - -getField :: (MonadFail m) => Name -> Map Name a -> m a -getField k = maybe (fail $ "missing field" <> T.unpack k) pure . lookup k - -getCabalFields :: FilePath -> Name -> ConfigT (Name, Version) -getCabalFields path pkgName = do - bs <- read (path <> "/" <> T.unpack pkgName <> ".cabal") - let fields = parseFields bs - name <- getField "name" fields - version <- getField "version" fields >>= parseText - field (T.unpack name) (show version) - pure (name, version) - -noNewLine :: Char -> String -noNewLine '\n' = " \n" -noNewLine x = [x] - -stack :: String -> String -> [String] -> ConfigT () -stack l name options = do - (code, _, out) <- liftIO (readProcessWithExitCode "stack" (l : (name : map ("--" <>) options)) "") - case code of - ExitFailure {} -> alert (l <> ": " <> concatMap noNewLine (T.unpack $ T.strip $ T.pack out)) - ExitSuccess {} -> printWarnings l (parseWarnings out) - -printWarnings :: String -> [(Text, [Text])] -> ConfigT () -printWarnings name [] = field name "ok" -printWarnings name xs = task (T.pack name) $ traverse_ subWarn xs - where - subWarn (x, ls) = - warn (T.unpack x) - >> traverse_ (warn . T.unpack) ls - -parseWarnings :: String -> [(Text, [Text])] -parseWarnings = concatMap toWarning . groupTopics . toLines . T.pack - -groupTopics :: [Text] -> [[Text]] -groupTopics = regroup . break emptyLine - where - emptyLine = (== "") - regroup (h, t) - | null t = [h] - | otherwise = h : groupTopics (dropWhile emptyLine t) - -toWarning :: [Text] -> [(Text, [Text])] -toWarning (x : xs) - | T.isPrefixOf "warning" (T.toLower x) = [(x, takeWhile (\p -> T.head p == ' ') xs)] -toWarning _ = [] - -buildCabal :: String -> ConfigT () -buildCabal name = do - stack "build" name ["test", "dry-run"] - stack "sdist" name [] - -checkCabal :: Name -> Name -> Version -> ConfigT () -checkCabal path name version = subTask "cabal" $ do - buildCabal (T.unpack path) - (pkgName, pkgVersion) <- getCabalFields (T.unpack path) name - if pkgVersion == version && pkgName == name then pure () else fail (T.unpack path <> "mismatching version or name") diff --git a/hconf/src/HConf/Stack/Config.hs b/hconf/src/HConf/Stack/Config.hs deleted file mode 100644 index d031d7d7b4..0000000000 --- a/hconf/src/HConf/Stack/Config.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | GQL Types -module HConf.Stack.Config - ( Stack, - setupStack, - ) -where - -import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) -import Data.List ((\\)) -import qualified Data.Map as M -import HConf.Config.Build (Build (..), getExtras) -import HConf.Config.Config (Config (builds), getBuild, getPackages) -import HConf.Config.ConfigT (ConfigT, HCEnv (..)) -import HConf.Config.Tag (VersionTag (..)) -import HConf.Core.Env (Env (..)) -import HConf.Core.Version (Version) -import HConf.Utils.Core (Name, aesonYAMLOptions, maybeList) -import HConf.Utils.Log (label, task) -import HConf.Utils.Yaml (rewriteYaml) -import Relude - -data Stack = Stack - { packages :: [Name], - resolver :: Name, - allowNewer :: Maybe Bool, - saveHackageCreds :: Maybe Bool, - extraDeps :: [Name] - } - deriving - ( Show, - Generic - ) - -instance FromJSON Stack where - parseJSON = genericParseJSON aesonYAMLOptions - -instance ToJSON Stack where - toJSON = genericToJSON aesonYAMLOptions - -setupStack :: VersionTag -> ConfigT () -setupStack version = label ("stack(" <> show version <> ")") $ task "stack.yaml" $ do - p <- asks (stack . env) - rewriteYaml p (updateStack version) $> () - -updateStack :: VersionTag -> Stack -> ConfigT Stack -updateStack version _ = do - config <- asks config - Build {..} <- getBuild version config - -- TODO: check if exclude /include packages exist - let packages = (getPackages config <> maybeList include) \\ maybeList exclude - pure - Stack - { packages, - resolver, - allowNewer = Just (Latest == version), - saveHackageCreds = Just False, - extraDeps = sort $ map printExtra $ M.toList $ getExtras version $ builds config - } - -printExtra :: (Text, Version) -> Text -printExtra (k, ver) = k <> "-" <> show ver diff --git a/hconf/src/HConf/Stack/Lib.hs b/hconf/src/HConf/Stack/Lib.hs deleted file mode 100644 index eb6af84fd2..0000000000 --- a/hconf/src/HConf/Stack/Lib.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Stack.Lib - ( Library (..), - updateDependencies, - updateLibrary, - Libraries, - ) -where - -#if MIN_VERSION_aeson(2,0,0) -import Data.Aeson.KeyMap (delete) -# else -import Data.HashMap.Lazy (delete) -#endif -import Data.Aeson.Types - ( FromJSON (..), - GFromJSON, - Object, - Parser, - ToJSON (..), - Value (..), - Zero, - genericParseJSON, - genericToJSON, - withObject, - ) -import GHC.Generics (Generic (..)) -import HConf.Config.Config (getRule) -import HConf.Config.ConfigT (ConfigT, HCEnv (config)) -import HConf.Core.Bounds (Bounds (..), diff) -import HConf.Core.Dependencies (Dependencies, traverseDeps) -import HConf.Utils.Core (Name, aesonYAMLOptions) -import HConf.Utils.Log (field) -import Relude hiding - ( Undefined, - break, - drop, - intercalate, - isPrefixOf, - length, - null, - ) - -type Libraries = Map Name Library - -data Library = Library - { sourceDirs :: Text, - dependencies :: Maybe Dependencies, - __unknownFields :: Maybe Object - } - deriving - ( Show, - Generic - ) - -instance FromJSON Library where - parseJSON = fromObject (\t o -> t {__unknownFields = o}) - -instance ToJSON Library where - toJSON t = Object (toObject (genericToJSON aesonYAMLOptions t) <> fromMaybe mempty (__unknownFields t)) - -fromObject :: (Generic a, GFromJSON Zero (Rep a)) => (a -> Maybe Object -> a) -> Value -> Parser a -fromObject f v = do - t <- genericParseJSON aesonYAMLOptions v - o <- withObject "Lib" pure v - pure (f t (Just o)) - -toObject :: Value -> Object -toObject (Object x) = delete "__unknown-fields" x -toObject _ = mempty - -withRule :: Text -> Bounds -> Bounds -> ConfigT Bounds -withRule name oldBounds bounds = - when (oldBounds /= bounds) (field (toString name) (diff oldBounds bounds)) - $> bounds - -updateDependency :: Name -> Bounds -> ConfigT Bounds -updateDependency name oldBounds = - asks config - >>= getRule name - >>= withRule name oldBounds - -updateDependencies :: Dependencies -> ConfigT Dependencies -updateDependencies = traverseDeps updateDependency - -updateLibrary :: Library -> ConfigT Library -updateLibrary Library {..} = do - newDependencies <- traverse updateDependencies dependencies - pure $ Library {dependencies = newDependencies, ..} \ No newline at end of file diff --git a/hconf/src/HConf/Stack/Package.hs b/hconf/src/HConf/Stack/Package.hs deleted file mode 100644 index 30696f3074..0000000000 --- a/hconf/src/HConf/Stack/Package.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | GQL Types -module HConf.Stack.Package - ( Package (..), - checkPackages, - resolvePackages, - ) -where - -import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) -import Data.Text (unpack) -import qualified HConf.Config.Config as C -import HConf.Config.ConfigT (ConfigT, HCEnv (config), packages) -import HConf.Core.Dependencies (Dependencies) -import HConf.Core.Version (Version) -import HConf.Stack.Cabal (checkCabal) -import HConf.Stack.Lib (Libraries, Library, updateDependencies, updateLibrary) -import HConf.Utils.Core (Name, aesonYAMLOptions, tupled) -import HConf.Utils.Log (label, subTask, task) -import HConf.Utils.Yaml (readYaml, rewriteYaml) -import Relude hiding (Undefined, length, replicate) - -data Package = Package - { name :: Name, - version :: Version, - library :: Maybe Library, - dependencies :: Dependencies, - tests :: Maybe Libraries, - executables :: Maybe Libraries, - benchmarks :: Maybe Libraries - } - deriving - ( Show, - Generic - ) - -instance FromJSON Package where - parseJSON = genericParseJSON aesonYAMLOptions - -instance ToJSON Package where - toJSON = genericToJSON aesonYAMLOptions - -toPath :: Name -> FilePath -toPath = (<> "/package.yaml") . unpack - -resolvePackages :: ConfigT [(Name, Package)] -resolvePackages = packages >>= traverse (tupled (readYaml . toPath)) - -updateLibraries :: Maybe Libraries -> ConfigT (Maybe Libraries) -updateLibraries = traverse (traverse updateLibrary) - -updatePackage :: Package -> ConfigT Package -updatePackage Package {..} = do - cfg <- asks config - newLibrary <- traverse updateLibrary library - newTests <- updateLibraries tests - newExecutables <- updateLibraries executables - newBenchmarks <- updateLibraries benchmarks - newDependencies <- updateDependencies dependencies - pure $ - Package - { version = C.version cfg, - library = newLibrary, - tests = newTests, - executables = newExecutables, - benchmarks = newBenchmarks, - dependencies = newDependencies, - .. - } - -rewritePackage :: Name -> ConfigT Package -rewritePackage path = - subTask "package" $ - rewriteYaml (toPath path) updatePackage - -checkPackage :: Name -> ConfigT () -checkPackage path = - task path $ do - Package {..} <- rewritePackage path - checkCabal path name version - -checkPackages :: ConfigT () -checkPackages = - label "packages" $ - packages - >>= traverse_ checkPackage diff --git a/hconf/src/HConf/Utils/Chalk.hs b/hconf/src/HConf/Utils/Chalk.hs deleted file mode 100644 index ef340e52da..0000000000 --- a/hconf/src/HConf/Utils/Chalk.hs +++ /dev/null @@ -1,29 +0,0 @@ -module HConf.Utils.Chalk - ( Color (..), - chalk, - ) -where - -data Color - = Red - | Green - | Yellow - | Gray - | Magenta - | Cyan - | None - -toColor :: Color -> String -toColor c = "\x1b[" <> show (colorCode c) <> "m" - -colorCode :: Color -> Int -colorCode Red = 31 -colorCode Green = 32 -colorCode Yellow = 33 -colorCode Gray = 90 -colorCode Magenta = 95 -colorCode None = 0 -colorCode Cyan = 36 - -chalk :: Color -> String -> String -chalk c x = toColor c <> x <> toColor None diff --git a/hconf/src/HConf/Utils/Class.hs b/hconf/src/HConf/Utils/Class.hs deleted file mode 100644 index 02139d1a55..0000000000 --- a/hconf/src/HConf/Utils/Class.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Utils.Class - ( Parse (..), - Check (..), - HConfIO (..), - ) -where - -import Control.Exception (tryJust) -import qualified Data.ByteString as L -import Relude - -class Parse a where - parse :: (MonadFail m) => String -> m a - parseText :: (MonadFail m) => Text -> m a - -class Check a where - check :: (MonadFail m, MonadIO m) => a -> m () - -class (MonadIO m, MonadFail m) => HConfIO m where - eitherRead :: FilePath -> m (Either String ByteString) - read :: FilePath -> m ByteString - write :: FilePath -> ByteString -> m () - -printException :: SomeException -> String -printException = show - -instance HConfIO IO where - eitherRead path = tryJust (Just . printException) (L.readFile path) - read = L.readFile - write = L.writeFile diff --git a/hconf/src/HConf/Utils/Core.hs b/hconf/src/HConf/Utils/Core.hs deleted file mode 100644 index 5e7e37a047..0000000000 --- a/hconf/src/HConf/Utils/Core.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | GQL Types -module HConf.Utils.Core - ( compareFields, - maybeList, - toKebabCase, - Name, - tupled, - aesonYAMLOptions, - checkElem, - notElemError, - ) -where - -import Data.Aeson - ( Options (..), - defaultOptions, - ) -import Data.Char (isUpper, toLower) -import Data.List (elemIndex, intercalate) -import Data.Text (toTitle) -import Relude hiding (Undefined, intercalate) - -aesonYAMLOptions :: Options -aesonYAMLOptions = defaultOptions {fieldLabelModifier = toKebabCase} - -type Name = Text - -fields :: [Text] -fields = - map - toTitle - [ "name", - "version", - "github", - "license", - "author", - "category", - "synopsis", - "maintainer", - "homepage", - "copyright", - "license-file", - "description", - "bounds", - "ghc", - "resolver", - "packages", - "groups", - "builds", - "extra-source-files", - "data-files", - "main", - "source-dirs", - "ghc-options", - "dependencies", - "library", - "executables", - "include", - "exclude", - "allow-newer", - "save-hackage-creds", - "extra-deps", - "stackYaml", - "components", - "path", - "component" - ] - -getIndex :: Text -> Maybe Int -getIndex = (`elemIndex` fields) - -type TupleRes a = (Text, Text) -> (a, a) - -mapTuple :: (Text -> a) -> TupleRes a -mapTuple f = bimap f f - -compareFieldNames :: (Text, Text) -> Ordering -compareFieldNames t = case mapTuple getIndex t of - (Nothing, Nothing) -> uncurry compare t - (Nothing, _) -> GT - (_, Nothing) -> LT - (i1, i2) -> compare i1 i2 - -compareFieldsTuple :: (Text, Text) -> Ordering -compareFieldsTuple = compareFieldNames . mapTuple toTitle - -compareFields :: Text -> Text -> Ordering -compareFields = curry compareFieldsTuple - -maybeList :: Maybe [a] -> [a] -maybeList = fromMaybe [] - -toKebabCase :: String -> String -toKebabCase = concatMap toKebab - where - toKebab - x - | isUpper x = ['-', toLower x] - | otherwise = [x] - -tupled :: (Functor f) => (t -> f a) -> t -> f (t, a) -tupled f p = (p,) <$> f p - -notElemError :: (MonadFail m, Eq t, ToString t) => String -> String -> [t] -> m a -notElemError name listName xs = - fail - ( "no matching " <> name <> " for '" - <> listName - <> "'! try one of: " - <> intercalate ", " (map toString xs) - ) - -checkElem :: (MonadFail m, Eq t, ToString t) => String -> String -> t -> [t] -> m () -checkElem name listName x xs = - if x `elem` xs - then pure () - else notElemError name listName xs \ No newline at end of file diff --git a/hconf/src/HConf/Utils/Format.hs b/hconf/src/HConf/Utils/Format.hs deleted file mode 100644 index ea506d0fc1..0000000000 --- a/hconf/src/HConf/Utils/Format.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Utils.Format (formatTable) where - -import Data.List (maximum) -import qualified Data.Text as T -import Relude - -type Table = [[Text]] - -getSizes :: Table -> [Int] -getSizes xs = map size (transpose xs) - where - size :: [Text] -> Int - size = maximum . map T.length - -printRow :: [Int] -> [Text] -> Text -printRow sizes ls = - T.strip $ - T.intercalate " " $ - zipWith (\item s -> T.justifyLeft s ' ' item) ls sizes - -formatTable :: Table -> [Text] -formatTable deps = sort $ map (printRow (getSizes deps)) deps diff --git a/hconf/src/HConf/Utils/Http.hs b/hconf/src/HConf/Utils/Http.hs deleted file mode 100644 index 29a73353b0..0000000000 --- a/hconf/src/HConf/Utils/Http.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Utils.Http - ( hackage, - ) -where - -import Data.Aeson (FromJSON, eitherDecode) -import qualified Data.Text as T -import Network.HTTP.Req - ( GET (..), - NoReqBody (..), - defaultHttpConfig, - lbsResponse, - req, - responseBody, - runReq, - useURI, - ) -import Relude hiding (ByteString) -import Text.URI (URI, mkURI) - -httpRequest :: (FromJSON a, MonadIO m, MonadFail m) => URI -> m (Either String a) -httpRequest uri = case useURI uri of - Nothing -> fail ("Invalid Endpoint: " <> show uri <> "!") - (Just (Left (u, o))) -> liftIO (eitherDecode . responseBody <$> runReq defaultHttpConfig (req GET u NoReqBody lbsResponse o)) - (Just (Right (u, o))) -> liftIO (eitherDecode . responseBody <$> runReq defaultHttpConfig (req GET u NoReqBody lbsResponse o)) - -parseURI :: (MonadFail m) => String -> m URI -parseURI url = maybe (fail ("Invalid Endpoint: " <> show url <> "!")) pure (mkURI (T.pack url)) - -hackage :: (MonadIO m, MonadFail m, FromJSON a) => [String] -> m (Either String a) -hackage path = parseURI ("https://hackage.haskell.org/" <> intercalate "/" path <> ".json") >>= httpRequest diff --git a/hconf/src/HConf/Utils/Log.hs b/hconf/src/HConf/Utils/Log.hs deleted file mode 100644 index 46bebbc24a..0000000000 --- a/hconf/src/HConf/Utils/Log.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Utils.Log - ( label, - task, - warn, - alert, - logFileChange, - Log (..), - info, - field, - subTask, - ) -where - -import HConf.Utils.Chalk (Color (..), chalk) -import HConf.Utils.Core (Name) -import Relude - -class Log m where - log :: String -> m () - inside :: m a -> m a - -instance Log IO where - log = putStrLn - inside = id - -newLine :: (Log m) => m () -newLine = log "" - -li :: (ToString a) => a -> String -li e = "- " <> toString e <> ":" - -label :: (Log m, Monad m) => String -> m () -> m () -label name m = info (li name) >> newLine >> inside m >> newLine - -task :: (Log m, Monad m) => Name -> m a -> m a -task name m = log (chalk Magenta (li name)) >> inside m - -subTask :: (Log m, Monad m) => Name -> m a -> m a -subTask name m = log (chalk Cyan (li name)) >> inside m - -field :: (Log m) => String -> String -> m () -field name = log . ((name <> ": ") <>) - -logFileChange :: (Log m) => String -> Bool -> m () -logFileChange path noChange - | noChange = field "checked" $ chalk Gray path - | otherwise = field "updated" $ chalk Yellow path - -info :: (Log m) => String -> m () -info = log . chalk Green - -warn :: (Log m) => String -> m () -warn = log . chalk Yellow - -alert :: (Log m) => String -> m () -alert = log . chalk Red diff --git a/hconf/src/HConf/Utils/Yaml.hs b/hconf/src/HConf/Utils/Yaml.hs deleted file mode 100644 index 47cd44095f..0000000000 --- a/hconf/src/HConf/Utils/Yaml.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HConf.Utils.Yaml - ( readYaml, - writeYaml, - rewriteYaml, - ) -where - -import Data.Aeson - ( FromJSON (..), - Object, - ToJSON (..), - Value (..), - ) -import Data.Yaml (decodeThrow) -import Data.Yaml.Pretty (defConfig, encodePretty, setConfCompare, setConfDropNull) -import HConf.Utils.Class (HConfIO (..)) -import HConf.Utils.Core (compareFields) -import HConf.Utils.Log (Log, logFileChange) -import Relude hiding (Show, Undefined, intercalate, show) -import Prelude (Show (..)) - -serializeYaml :: (ToJSON a) => a -> ByteString -serializeYaml = - encodePretty $ - setConfDropNull True $ - setConfCompare compareFields defConfig - -readYaml :: (FromJSON a, HConfIO m) => FilePath -> m a -readYaml = read >=> (liftIO . decodeThrow) - -writeYaml :: (ToJSON a, HConfIO m, Log m) => FilePath -> a -> m () -writeYaml path v = checkAndWrite path (serializeYaml v) >>= logFileChange path - -checkAndWrite :: (HConfIO m) => FilePath -> ByteString -> m Bool -checkAndWrite path newFile = do - file <- eitherRead path - write path newFile - return (fromRight "" file == newFile) - -data Yaml t = Yaml - { getData :: t, - rawValue :: Object - } - deriving (Generic) - -instance (Show t) => Show (Yaml t) where - show (Yaml t _) = show t - -instance (FromJSON t) => FromJSON (Yaml t) where - parseJSON v = Yaml <$> parseJSON v <*> parseJSON v - -instance (ToJSON t) => ToJSON (Yaml t) where - toJSON (Yaml t v) = Object (toObject (toJSON t) <> v) - -toObject :: Value -> Object -toObject (Object x) = x -toObject _ = mempty - -mapYaml :: (Functor m) => (t -> m t) -> Yaml t -> m (Yaml t) -mapYaml f (Yaml v props) = (`Yaml` props) <$> f v - -rewriteYaml :: (HConfIO m, Log m, FromJSON t, ToJSON t) => FilePath -> (t -> m t) -> m t -rewriteYaml path f = do - readYaml path - >>= mapYaml f - >>= \x -> writeYaml path x >> pure (getData x) diff --git a/hie.yaml b/hie.yaml index 89826bb2d8..f6ebbda7b8 100644 --- a/hie.yaml +++ b/hie.yaml @@ -56,7 +56,3 @@ cradle: component: morpheus-graphql:lib - path: ./morpheus-graphql/test component: morpheus-graphql:test:morpheus-graphql-test - - path: ./hconf/src - component: hconf:lib - - path: ./hconf/app - component: hconf:exe:hconf diff --git a/package.json b/package.json index 2017ae99ac..ff3a32aa69 100644 --- a/package.json +++ b/package.json @@ -10,7 +10,7 @@ "check:spelling": "cspell --cache --no-progress '**/*.hs'", "changelog": "npm run release changelog", "release": "ts-node scripts/cli.ts release", - "setup": "hconf setup", + "hconf": "ts-node scripts/cli.ts hconf", "format": "ts-node scripts/cli.ts format", "format:fix": "ts-node scripts/cli.ts format --fix=true", "code-gen": "morpheus build morpheus-graphql-server/test examples/code-gen examples/code-gen-docs", diff --git a/scripts/cli.ts b/scripts/cli.ts index 45440e11e6..3b6a80efe7 100644 --- a/scripts/cli.ts +++ b/scripts/cli.ts @@ -4,6 +4,7 @@ import { changelog } from "./lib/changelog"; import { Command } from "commander"; import { format } from "./lib/format"; +import { setupHconf } from "./lib/hconf"; const cli = new Command(); @@ -16,6 +17,8 @@ cli .option("--path ", "path", "./morpheus-graphql*/**/*.hs") .action(format); +cli.command("hconf").action(setupHconf); + const release = cli.command("release"); release diff --git a/scripts/lib/format.ts b/scripts/lib/format.ts index 330f939731..e77b2d26c5 100644 --- a/scripts/lib/format.ts +++ b/scripts/lib/format.ts @@ -9,7 +9,7 @@ const config: Record = { darwin: "/ormolu-macOS.zip", }; -const name = config[process.platform] ?? config.linux; +export const platform = process.platform ?? config.linux; type Ops = { fileName: string; url: string }; @@ -57,6 +57,6 @@ export const format = async ({ fix, path }: { fix: boolean; path: string }) => }, { fileName: "ormolu", - url: `https://github.com/tweag/ormolu/releases/download/0.5.0.1/${name}`, + url: `https://github.com/tweag/ormolu/releases/download/0.5.0.1/${config[platform]}`, } ); diff --git a/scripts/lib/hconf.ts b/scripts/lib/hconf.ts new file mode 100644 index 0000000000..06ab4f3348 --- /dev/null +++ b/scripts/lib/hconf.ts @@ -0,0 +1,23 @@ +import { exec } from "./utils"; +import { platform, run } from "./format"; + +const config: Record = { + linux: "hconf-linux.zip", + win32: "hconf-windows.zip", + darwin: "hconf-mac-os.zip", +}; + +const url = `https://github.com/nalchevanidze/hconf/releases/download/0.1.2/${config[platform]}`; + +export const setupHconf = async () => + run( + async (bin) => { + try { + exec(`mkdir $HOME/.local/bin`); + } catch {} + + exec(`cp ${bin} $HOME/.local/bin/hconf`); + console.log(`installed hconf: ${exec("hconf version")}`); + }, + { fileName: "hconf", url } + ); diff --git a/stack.yaml b/stack.yaml index dbdc12555c..8b1b07c628 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,6 @@ packages: - morpheus-graphql-server - morpheus-graphql-benchmarks - morpheus-graphql -- hconf allow-newer: true save-hackage-creds: false extra-deps: