Optics.hs

{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

{-|
Module      : GHCup.Types.Optics
Description : GHCup optics
Copyright   : (c) Julian Ospald, 2020
License     : LGPL-3.0
Maintainer  : hasufell@hasufell.de
Stability   : experimental
Portability : portable
-}
module GHCup.Types.Optics where

import GHCup.Types

import Control.Monad.Reader
import Data.ByteString      ( ByteString )
import Data.Map.Strict      ( Map )
import Optics
import URI.ByteString

import qualified Data.Map.Strict as M


makePrisms ''Tool
makePrisms ''Architecture
makePrisms ''LinuxDistro
makePrisms ''Platform
makePrisms ''Tag
makePrisms ''EnvUnion
makePrisms ''GHCupDownloads
makePrisms ''ToolVersionSpec
makePrisms ''RevisionSpec
makePrisms ''ArchitectureSpec
makePrisms ''PlatformSpec
makePrisms ''PlatformVersionSpec
makePrisms ''Rev

makeLenses ''ToolInfo
makeLenses ''ToolDescription
makeLenses ''EnvSpec
makeLenses ''ConfigSpec
makeLenses ''MakeSpec
makeLenses ''InstallationSpecGen
makeLenses ''InstallMetadata
makeLenses ''PlatformResult
makeLenses ''DownloadInfo
makeLenses ''Tag
makeLenses ''VersionInfo
makeLenses ''VersionMetadata

makeLenses ''TargetVersionReq
makeLenses ''TargetVersionRev
makeLenses ''InstallFileRule

makeLenses ''GHCupInfo

makeLenses ''CapturedProcess

toolVersionsL :: Lens' ToolInfo (Map TargetVersion VersionMetadata)
toolVersionsL = toolVersions % _ToolVersionSpec

revisionSpecL :: Getter VersionMetadata (Map Int VersionInfo)
revisionSpecL = vmRevisionSpec % _RevisionSpec % to (M.mapKeys unRev)

archL :: Lens' VersionInfo (MapIgnoreUnknownKeys Architecture PlatformSpec)
archL = viArch % _ArchitectureSpec

uriSchemeL' :: Lens' (URIRef Absolute) Scheme
uriSchemeL' = lensVL uriSchemeL

schemeBSL' :: Lens' Scheme ByteString
schemeBSL' = lensVL schemeBSL

authorityL' :: Lens' (URIRef a) (Maybe Authority)
authorityL' = lensVL authorityL

authorityHostL' :: Lens' Authority Host
authorityHostL' = lensVL authorityHostL

authorityPortL' :: Lens' Authority (Maybe Port)
authorityPortL' = lensVL authorityPortL

portNumberL' :: Lens' Port Int
portNumberL' = lensVL portNumberL

hostBSL' :: Lens' Host ByteString
hostBSL' = lensVL hostBSL

pathL' :: Lens' (URIRef a) ByteString
pathL' = lensVL pathL

queryL' :: Lens' (URIRef a) Query
queryL' = lensVL queryL

mapLast :: AffineFold (Map k a) (k, a)
mapLast = to M.lookupMax % _Just

ixOrLast :: forall k v . Ord k => Maybe k -> AffineFold (Map k v) (k, v)
ixOrLast = maybe mapLast (\i -> castOptic @An_AffineFold (ix @(Map k v) i) % to (i,))



    ----------------------
    --[ Lens utilities ]--
    ----------------------


gets :: forall f a env m . (MonadReader env m, LabelOptic' f A_Lens env a)
     => m a
gets = asks (^. labelOptic @f)


getAppState :: MonadReader AppState m => m AppState
getAppState = ask


getLeanAppState :: ( MonadReader env m
                   , LabelOptic' "settings"     A_Lens env Settings
                   , LabelOptic' "dirs"         A_Lens env Dirs
                   , LabelOptic' "keyBindings"  A_Lens env KeyBindings
                   , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
                   , LabelOptic' "pfreq"        A_Lens env PlatformRequest
                   )
                => m LeanAppState
getLeanAppState = do
  s <- gets @"settings"
  d <- gets @"dirs"
  k <- gets @"keyBindings"
  p <- gets @"pfreq"
  l <- gets @"loggerConfig"
  pure (LeanAppState s d k p l)


getSettings :: ( MonadReader env m
               , LabelOptic' "settings" A_Lens env Settings
               )
            => m Settings
getSettings = gets @"settings"


getDirs :: ( MonadReader env m
           , LabelOptic' "dirs" A_Lens env Dirs
           )
        => m Dirs
getDirs = gets @"dirs"


getLogCleanup :: ( MonadReader env m
                 , LabelOptic' "logCleanup" A_Lens env (IO ())
                 )
              => m (IO ())
getLogCleanup = gets @"logCleanup"


getKeyBindings :: ( MonadReader env m
                  , LabelOptic' "keyBindings" A_Lens env KeyBindings
                  )
               => m KeyBindings
getKeyBindings = gets @"keyBindings"


getGHCupInfo :: ( MonadReader env m
                , LabelOptic' "ghcupInfo" A_Lens env GHCupInfo
                )
             => m GHCupInfo
getGHCupInfo = gets @"ghcupInfo"


getPlatformReq :: ( MonadReader env m
                  , LabelOptic' "pfreq" A_Lens env PlatformRequest
                  )
               => m PlatformRequest
getPlatformReq = gets @"pfreq"


type HasSettings env = (LabelOptic' "settings" A_Lens env Settings)
type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs)
type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings)
type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo)
type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest)
type HasLog env = (LabelOptic' "loggerConfig" A_Lens env LoggerConfig)


getCache :: (MonadReader env m, HasSettings env) => m Bool
getCache = getSettings <&> cache


getDownloader :: (MonadReader env m, HasSettings env) => m Downloader
getDownloader = getSettings <&> downloader


instance LabelOptic "dirs" A_Lens Dirs Dirs Dirs Dirs where
  labelOptic = lens id (\_ d -> d)

instance LabelOptic "loggerConfig" A_Lens LoggerConfig LoggerConfig LoggerConfig LoggerConfig where
  labelOptic = lens id (\_ d -> d)