{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

module Hsm.GPIO
  ( GPIO(..)
  , GPIOEffect
  , G.LineValue
  , G.active
  , G.inactive
  , setPins
  , setAllPins
  , runGPIO
  ) where

import Control.Monad (forM_, void)
import Data.Aeson (FromJSON)
import Data.ByteString (useAsCString)
import Data.Kind (Type)
import Data.Set (Set, size, toList, unions)
import Data.String (IsString)
import Data.Text (Text, pack)
import Data.Text.Encoding (encodeUtf8)
import Data.Vector.Storable qualified as V
import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
import Effectful.Dispatch.Static qualified as E
import Effectful.Exception (finally)
import Effectful.Log (Log, LogLevel(LogTrace), localDomain, logTrace_)
import Effectful.Reader.Static (Reader, ask)
import Effectful.Resource (Resource, allocate, release)
import Foreign.C.Types (CSize(CSize), CUInt(CUInt))
import Foreign.Ptr (Ptr)
import GHC.Generics (Generic)
import GHC.Records (HasField)
import Hsm.Core.Log (flushLogger, withLogIO)
import Hsm.GPIO.Lib qualified as G

data GPIO
  = GPIO5
  | GPIO6
  | GPIO16
  | GPIO17
  | GPIO22
  | GPIO23
  | GPIO24
  | GPIO25
  | GPIO26
  | GPIO27
  deriving (Eq, FromJSON, Generic, Ord, Read, Show)

gpiosMapped ::
     forall key. (Bounded key, Enum key)
  => (key -> Set GPIO)
  -> Set GPIO
gpiosMapped mapper = unions $ mapper <$> [minBound @key .. maxBound]

gpioLine :: GPIO -> CUInt
gpioLine = CUInt . read . drop 4 . show

data GPIOEffect key a b

type instance DispatchOf (GPIOEffect key) = Static E.WithSideEffects

-- The static representation of this effect contains a function that maps a
-- `key` to a `Set` of GPIO pins. This allows a single `key` of any type to
-- control multiple pins simultaneously. By using a function (instead of
-- `Data.Map`), we ensure that the mapping is total, meaning every `key` will
-- map to a corresponding set of pins.
data instance E.StaticRep (GPIOEffect (key :: Type)) =
  GPIOEffect (key -> Set GPIO) (Ptr G.LineRequest)

domain :: Text
domain = "gpio"

chipPath :: IsString a => a
chipPath = "/dev/gpiochip0"

setPins ::
     (GPIOEffect key :> es, Log :> es, Show key)
  => G.LineValue
  -> key
  -> Eff es ()
setPins lineValue key = do
  GPIOEffect mapper lineRequest <- E.getStaticRep
  forM_ (mapper key) $ \pin -> do
    localDomain domain
      $ logTrace_
      $ "Setting PIN "
          <> pack (show pin)
          <> " mapped to key "
          <> pack (show key)
          <> " to state "
          <> pack (show lineValue)
    flushLogger
    E.unsafeEff_ $ G.lineRequestSetValue lineRequest (gpioLine pin) lineValue

setAllPins ::
     forall key es. (GPIOEffect key :> es, Log :> es, Bounded key, Enum key)
  => G.LineValue
  -> Eff es ()
setAllPins lineValue = E.getStaticRep >>= setter
  where
    setter (GPIOEffect mapper lineRequest) = do
      localDomain domain
        $ logTrace_
        $ "Setting all mapped PINs "
            <> pack (show mapped)
            <> " to state "
            <> pack (show lineValue)
      flushLogger
      void
        $ E.unsafeEff_
        $ V.unsafeWith lineValuesVector
        $ G.lineRequestSetValues lineRequest
      where
        mapped = gpiosMapped @key mapper
        lineValuesVector = V.replicate (size mapped) lineValue

runGPIO ::
     forall env es key a.
     ( HasField "name" env Text
     , IOE :> es
     , Log :> es
     , Reader env :> es
     , Resource :> es
     , Bounded key
     , Enum key
     )
  => (key -> Set GPIO)
  -> Eff (GPIOEffect key : es) a
  -> Eff es a
runGPIO mapper action = do
  lineRequest <- localDomain domain $ withLogIO >>= bootstrap
  E.evalStaticRep (GPIOEffect mapper lineRequest)
    $ finally action
    $ setAllPins @key G.inactive
  where
    bootstrap logIO = do
      (chipKey, chip) <- allocate chipOpen chipClose
      (lineSettingsKey, lineSettings) <-
        allocate lineSettingsNew lineSettingsFree
      (lineConfigKey, lineConfig) <-
        allocate (lineConfigNew lineSettings) lineConfigFree
      env <- ask @env
      (requestConfigKey, requestConfig) <-
        allocate (requestConfigNew env.name) requestConfigFree
      (_, lineRequest) <-
        allocate (requestLines chip requestConfig lineConfig) lineRequestRelease
      release requestConfigKey
      release lineConfigKey
      release lineSettingsKey
      release chipKey
      return lineRequest
      where
        gpiosVector = V.fromList $ gpioLine <$> toList (gpiosMapped mapper)
        gpiosSize = CSize $ fromIntegral $ V.length gpiosVector
        chipOpen = do
          logIO LogTrace $ "Opening GPIO chip " <> chipPath
          useAsCString chipPath G.chipOpen
        chipClose chip = do
          logIO LogTrace $ "Closing GPIO chip " <> chipPath
          G.chipClose chip
        lineSettingsNew = do
          logIO LogTrace "Allocating line settings"
          lineSettings <- G.lineSettingsNew
          logIO LogTrace $ "With direction set to " <> pack (show G.output)
          void $ G.lineSettingsSetDirection lineSettings G.output
          logIO LogTrace $ "With output set to " <> pack (show G.inactive)
          void $ G.lineSettingsSetOutputValue lineSettings G.inactive
          return lineSettings
        lineSettingsFree lineSettings = do
          logIO LogTrace "Freeing line settings"
          G.lineSettingsFree lineSettings
        lineConfigNew lineSettings = do
          logIO LogTrace "Allocating line config"
          logIO LogTrace $ "With GPIOs " <> pack (show gpiosVector)
          lineConfig <- G.lineConfigNew
          void
            $ V.unsafeWith gpiosVector
            $ \gpiosPtr ->
                G.lineConfigAddLineSettings
                  lineConfig
                  gpiosPtr
                  gpiosSize
                  lineSettings
          return lineConfig
        lineConfigFree lineConfig = do
          logIO LogTrace "Freeing line config"
          G.lineConfigFree lineConfig
        requestConfigNew consumer = do
          logIO LogTrace "Allocating request config"
          logIO LogTrace $ "With consumer " <> consumer
          requestConfig <- G.requestConfigNew
          useAsCString (encodeUtf8 consumer)
            $ G.requestConfigSetConsumer requestConfig
          return requestConfig
        requestConfigFree requestConfig = do
          logIO LogTrace "Freeing request config"
          G.requestConfigFree requestConfig
        requestLines chip requestConfig lineConfig = do
          logIO LogTrace "Requesting lines from chip"
          G.requestLines chip requestConfig lineConfig
        lineRequestRelease lineRequest = do
          logIO LogTrace "Releasing lines"
          G.lineRequestRelease lineRequest