PackageSet.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Copyright: (c) 2021 berberman
-- SPDX-License-Identifier: MIT
-- Maintainer: berberman <berberman@yandex.com>
-- Stability: experimental
-- Portability: portable
--
-- This module mainly contains two things: 'PackageSet' and 'PkgDSL'.
-- NvFetcher accepts the former one -- a set of packages to produce nix sources expr;
-- the later one is used to construct a single package.
--
-- There are many combinators for defining packages. See the documentation of 'define' for example.
module NvFetcher.PackageSet
  ( -- * Package set
    PackageSetF,
    PackageSet,
    newPackage,
    purePackageSet,
    runPackageSet,

    -- * Package DSL

    -- ** Primitives
    PkgDSL (..),
    define,
    package,
    src,
    fetch,

    -- ** Two-in-one functions
    fromGitHub,
    fromGitHub',
    fromPypi,

    -- ** Version sources
    sourceGitHub,
    sourceGit,
    sourcePypi,
    sourceAur,
    sourceArchLinux,
    sourceManual,
    sourceRepology,

    -- ** Fetchers
    fetchGitHub,
    fetchGitHub',
    fetchGitHubRelease,
    fetchPypi,
    fetchGit,
    fetchGit',
    fetchUrl,

    -- ** Miscellaneous
    Prod,
    Member,
    NotElem,
    coerce,
    liftIO,

    -- * Lenses
    (&),
    (.~),
    (%~),
    (^.),
    module NvFetcher.Types.Lens,
  )
where

import Control.Monad.Free
import Control.Monad.IO.Class
import Data.Coerce (coerce)
import Data.Kind (Constraint, Type)
import Data.Map.Strict as HMap
import Data.Maybe (isJust)
import Data.Text (Text)
import GHC.TypeLits
import Lens.Micro
import NvFetcher.NixFetcher
import NvFetcher.Types
import NvFetcher.Types.Lens

--------------------------------------------------------------------------------

-- | Atomic terms of package set
data PackageSetF f
  = NewPackage !Package f
  | forall a. EmbedIO !(IO a) (a -> f)

instance Functor PackageSetF where
  fmap f (NewPackage p g) = NewPackage p $ f g
  fmap f (EmbedIO action g) = EmbedIO action $ f <$> g

-- | Package set is a monad equipped with two capabilities:
--
-- 1. Carry defined packages
-- 2. Run IO actions
--
-- Package set is evaluated be for shake runs.
-- Use 'newPackage' to add a new package, 'liftIO' to run an IO action.
type PackageSet = Free PackageSetF

instance MonadIO PackageSet where
  liftIO io = liftF $ EmbedIO io id

-- | Add a package to package set
newPackage ::
  PackageName ->
  VersionSource ->
  PackageFetcher ->
  PackageSet ()
newPackage name source fetcher = liftF $ NewPackage (Package name source fetcher) ()

-- | Add a list of packages into package set
purePackageSet :: [Package] -> PackageSet ()
purePackageSet = mapM_ (liftF . flip NewPackage ())

-- | Run package set into a set of packages
--
-- Throws exception as more then one packages with the same name
-- are defined
runPackageSet :: PackageSet () -> IO (Map PackageKey Package)
runPackageSet = \case
  Free (NewPackage p g) ->
    runPackageSet g >>= \m ->
      if isJust (HMap.lookup (PackageKey $ _pname p) m)
        then fail $ "Duplicate package name: " <> show (_pname p)
        else pure $ HMap.insert (PackageKey $ _pname p) p m
  Free (EmbedIO action g) -> action >>= runPackageSet . g
  Pure _ -> pure mempty

--------------------------------------------------------------------------------

-- | Simple HList
data Prod (r :: [Type]) where
  Nil :: Prod '[]
  Cons :: !x -> Prod xs -> Prod (x ': xs)

-- | Project elements from 'Prod'
class Member (a :: Type) (r :: [Type]) where
  proj :: Prod r -> a

instance {-# OVERLAPPING #-} NotElem x xs => Member x (x ': xs) where
  proj (Cons x _) = x

instance Member x xs => Member x (_y ': xs) where
  proj (Cons _ r) = proj r

instance TypeError (ShowType x :<>: 'Text " is undefined") => Member x '[] where
  proj = undefined

-- | Constraint for producing error messages
type family NotElem (x :: Type) (xs :: [Type]) :: Constraint where
  NotElem x (x ': xs) = TypeError (ShowType x :<>: 'Text " is defined more than one times")
  NotElem x (_ ': xs) = NotElem x xs
  NotElem x '[] = ()

--------------------------------------------------------------------------------

-- | A tagless final style DSL for constructing packages
class PkgDSL f where
  new :: f PackageName -> f (Prod '[PackageName])
  andThen :: f (Prod r) -> f a -> f (Prod (a ': r))
  end :: (Member PackageName r, Member VersionSource r, Member PackageFetcher r) => f (Prod r) -> f ()

instance PkgDSL PackageSet where
  new e = do
    name <- e
    pure $ Cons name Nil
  andThen e e' = do
    p <- e
    x <- e'
    pure $ Cons x p
  end e = do
    p <- e
    newPackage (proj p) (proj p) (proj p)

-- | 'PkgDSL' version of 'newPackage'
--
-- Example:
--
-- @
-- define $ package "nvfetcher-git" `sourceGit` "https://github.com/berberman/nvfetcher" `fetchGitHub` ("berberman", "nvfetcher")
-- @
define ::
  ( Member PackageName r,
    Member VersionSource r,
    Member PackageFetcher r
  ) =>
  PackageSet (Prod r) ->
  PackageSet ()
define = end

-- | Start chaining with the name of package to define
package :: PackageName -> PackageSet (Prod '[PackageName])
package = new . pure

-- | Attach version sources
src :: PackageSet (Prod r) -> VersionSource -> PackageSet (Prod (VersionSource ': r))
src = (. pure) . andThen

-- | Attach fetchers
fetch ::
  PackageSet (Prod r) ->
  PackageFetcher ->
  PackageSet (Prod (PackageFetcher ': r))
fetch = (. pure) . andThen

--------------------------------------------------------------------------------

-- | A synonym of 'fetchGitHub' and 'sourceGitHub'
fromGitHub ::
  PackageSet (Prod r) ->
  (Text, Text) ->
  PackageSet
    (Prod (PackageFetcher : VersionSource : r))
fromGitHub e (owner, repo) = fromGitHub' e (owner, repo, id)

-- | A synonym of 'fetchGitHub'' and 'sourceGitHub'
fromGitHub' ::
  PackageSet (Prod r) ->
  (Text, Text, NixFetcher Fresh -> NixFetcher Fresh) ->
  PackageSet
    (Prod (PackageFetcher : VersionSource : r))
fromGitHub' e p@(owner, repo, _) = fetchGitHub' (sourceGitHub e (owner, repo)) p

-- | A synonym of 'fetchPypi' and 'sourcePypi'
fromPypi ::
  PackageSet (Prod r) ->
  Text ->
  PackageSet
    (Prod (PackageFetcher : VersionSource : r))
fromPypi e p = fetchPypi (sourcePypi e p) p

--------------------------------------------------------------------------------

-- | This package follows the latest github release
sourceGitHub ::
  PackageSet (Prod r) ->
  -- | owner and repo
  (Text, Text) ->
  PackageSet (Prod (VersionSource : r))
sourceGitHub e (owner, repo) = src e $ GitHubRelease owner repo

-- | This package follows the latest git commit
sourceGit ::
  PackageSet (Prod r) ->
  -- | git url
  Text ->
  PackageSet (Prod (VersionSource : r))
sourceGit e _vurl = src e Git {..}

-- | This package follows the latest pypi release
sourcePypi ::
  PackageSet (Prod r) ->
  -- | pypi name
  Text ->
  PackageSet (Prod (VersionSource : r))
sourcePypi e _pypi = src e Pypi {..}

-- | This package follows the version of an Arch Linux package
sourceArchLinux ::
  PackageSet (Prod r) ->
  -- | package name in Arch Linux repo
  Text ->
  PackageSet (Prod (VersionSource : r))
sourceArchLinux e _archpkg = src e ArchLinux {..}

-- | This package follows the version of an Aur package
sourceAur ::
  PackageSet (Prod r) ->
  -- | package name in Aur
  Text ->
  PackageSet (Prod (VersionSource : r))
sourceAur e _aur = src e Aur {..}

-- | This package follows a pinned version
sourceManual ::
  PackageSet (Prod r) ->
  Text ->
  PackageSet (Prod (VersionSource : r))
sourceManual e _manual = src e Manual {..}

-- | This package follows the version of a repology package
sourceRepology ::
  PackageSet (Prod r) ->
  -- | repology project name and repo
  (Text, Text) ->
  PackageSet (Prod (VersionSource : r))
sourceRepology e (project, repo) = src e $ Repology project repo

--------------------------------------------------------------------------------

-- | This package is fetched from a github repo
fetchGitHub ::
  PackageSet (Prod r) ->
  -- | owner and repo
  (Text, Text) ->
  PackageSet (Prod (PackageFetcher : r))
fetchGitHub e (owner, repo) = fetchGitHub' e (owner, repo, id)

-- | This package is fetched from a github repo
--
-- Similar to 'fetchGitHub', but allows a modifier to the fetcher.
-- For example, you can enable fetch submodules like:
--
-- @
-- define $ package "qliveplayer" `sourceGitHub` ("IsoaSFlus", "QLivePlayer") `fetchGitHub'` ("IsoaSFlus", "QLivePlayer", fetchSubmodules .~ True)
-- @
fetchGitHub' ::
  PackageSet (Prod r) ->
  -- | owner and repo
  ( Text,
    Text,
    NixFetcher Fresh -> NixFetcher Fresh
  ) ->
  PackageSet (Prod (PackageFetcher : r))
fetchGitHub' e (owner, repo, f) = fetch e $ f . gitHubFetcher (owner, repo)

-- | This package is fetched from a file in github release
fetchGitHubRelease ::
  PackageSet (Prod r) ->
  -- | owner, repo, and file name
  (Text, Text, Text) ->
  PackageSet (Prod (PackageFetcher : r))
fetchGitHubRelease e (owner, repo, fp) = fetch e $ gitHubReleaseFetcher (owner, repo) fp

-- | This package is fetched from pypi
fetchPypi ::
  PackageSet (Prod r) ->
  -- | pypi name
  Text ->
  PackageSet (Prod (PackageFetcher : r))
fetchPypi e = fetch e . pypiFetcher

-- | This package is fetched from git
fetchGit ::
  PackageSet (Prod r) ->
  -- | git url
  Text ->
  PackageSet (Prod (PackageFetcher : r))
fetchGit e u = fetchGit' e (u, id)

-- | This package is fetched from git
--
-- Similar to 'fetchGit', but allows a modifier to the fetcher.
-- See 'fetchGitHub'' for a concret example.
fetchGit' ::
  PackageSet (Prod r) ->
  -- | git url
  (Text, NixFetcher Fresh -> NixFetcher Fresh) ->
  PackageSet (Prod (PackageFetcher : r))
fetchGit' e (u, f) = fetch e $ f . gitFetcher u

-- | This package is fetched from url
fetchUrl ::
  PackageSet (Prod r) ->
  -- | url, given a specific version
  (Version -> Text) ->
  PackageSet (Prod (PackageFetcher : r))
fetchUrl e f = fetch e (urlFetcher . f)

--------------------------------------------------------------------------------