{-# LANGUAGE OverloadedStrings #-}

module Hsm.GPIO
  ( G.active
  , G.inactive
  , G.LineRequest
  , GPIO(..)
  , setPins
  , setAllPins
  , allocateGPIO
  ) where

import Control.IO.Region (Region, alloc, alloc_, defer, free)
import Control.Monad (forM_, void)
import Data.ByteString (useAsCString)
import Data.Text (Text, pack)
import Data.Text.Encoding (encodeUtf8)
import Data.Vector.Storable qualified as V
import Foreign.C.Types (CSize(CSize), CUInt(CUInt))
import Foreign.Ptr (Ptr)
import Hsm.GPIO.Lib qualified as G
import Hsm.Log qualified as L

logMsg :: Text -> IO ()
logMsg = L.logMsg ["gpio"]

data GPIO
  = GPIO2
  | GPIO3
  | GPIO4
  | GPIO5
  | GPIO6
  | GPIO7
  | GPIO8
  | GPIO9
  | GPIO10
  | GPIO11
  | GPIO12
  | GPIO13
  | GPIO14
  | GPIO15
  | GPIO16
  | GPIO17
  -- | GPIO18 -- reserved for PWM
  -- | GPIO19 -- reserved for PWM
  | GPIO20
  | GPIO21
  | GPIO22
  | GPIO23
  | GPIO24
  | GPIO25
  | GPIO26
  | GPIO27
  deriving (Bounded, Enum, Show)

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

allPins :: [GPIO]
allPins = [minBound .. maxBound]

allLines :: [CUInt]
allLines = pinLine <$> allPins

setPins :: Ptr G.LineRequest -> [GPIO] -> G.LineValue -> IO ()
setPins lineRequest pins lineValue = do
  logMsg
    $ "Setting pin(s) "
        <> pack (show pins)
        <> " to state "
        <> pack (show lineValue)
  forM_ pins $ \pin -> G.lineRequestSetValue lineRequest (pinLine pin) lineValue

setAllPins :: Ptr G.LineRequest -> G.LineValue -> IO ()
setAllPins lineRequest lineValue = do
  logMsg
    $ "Setting all pins "
        <> pack (show allPins)
        <> " to state "
        <> pack (show lineValue)
  void
    $ V.unsafeWith (V.replicate (length allPins) lineValue)
    $ G.lineRequestSetValues lineRequest

allocateGPIO :: Region -> Text -> IO (Ptr G.LineRequest)
allocateGPIO region consumer = do
  (chip, chipKey) <- allocateChip
  (lineSettings, lineSettingsKey) <- allocateLineSettings
  (lineConfig, lineConfigKey) <- allocateLineConfig lineSettings
  (requestConfig, requestConfigKey) <- allocateRequestConfig
  lineRequest <- allocateLineRequest chip requestConfig lineConfig
  free requestConfigKey
  free lineConfigKey
  free lineSettingsKey
  free chipKey
  defer region $ setAllPins lineRequest G.inactive
  return lineRequest
  where
    chipPath = "/dev/gpiochip0"
    -- GPIO chip
    chipOpen = do
      logMsg $ "Opening GPIO chip " <> chipPath
      useAsCString (encodeUtf8 chipPath) G.chipOpen
    chipClose chip = do
      logMsg $ "Closing GPIO chip " <> chipPath
      G.chipClose chip
    allocateChip = alloc region chipOpen chipClose
    -- Line settings
    lineSettingsNew = do
      logMsg "Allocating line settings"
      lineSettings <- G.lineSettingsNew
      logMsg $ "With direction set to " <> pack (show G.output)
      void $ G.lineSettingsSetDirection lineSettings G.output
      logMsg $ "With output set to " <> pack (show G.inactive)
      void $ G.lineSettingsSetOutputValue lineSettings G.inactive
      return lineSettings
    lineSettingsFree lineSettings = do
      logMsg "Freeing line settings"
      G.lineSettingsFree lineSettings
    allocateLineSettings = alloc region lineSettingsNew lineSettingsFree
    -- Line config
    lineConfigNew lineSettings = do
      logMsg "Allocating line config"
      logMsg $ "With GPIO pins " <> pack (show allPins)
      lineConfig <- G.lineConfigNew
      void
        $ V.unsafeWith (V.fromList allLines)
        $ \pinsVector ->
            G.lineConfigAddLineSettings
              lineConfig
              pinsVector
              (CSize $ fromIntegral $ length allPins)
              lineSettings
      return lineConfig
    lineConfigFree lineConfig = do
      logMsg "Freeing line config"
      G.lineConfigFree lineConfig
    allocateLineConfig lineSettings =
      alloc region (lineConfigNew lineSettings) lineConfigFree
    -- Request config
    requestConfigNew = do
      logMsg "Allocating request config"
      logMsg $ "With consumer " <> consumer
      requestConfig <- G.requestConfigNew
      useAsCString (encodeUtf8 consumer)
        $ G.requestConfigSetConsumer requestConfig
      return requestConfig
    requestConfigFree requestConfig = do
      logMsg "Freeing request config"
      G.requestConfigFree requestConfig
    allocateRequestConfig = alloc region requestConfigNew requestConfigFree
    -- Line request
    requestLines chip requestConfig lineConfig = do
      logMsg "Allocating line request"
      G.requestLines chip requestConfig lineConfig
    lineRequestRelease lineRequest = do
      logMsg "Releasing line request"
      G.lineRequestRelease lineRequest
    allocateLineRequest chip requestConfig lineConfig =
      alloc_
        region
        (requestLines chip requestConfig lineConfig)
        lineRequestRelease