{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Hsm.GPIO
  ( GPIOPin(..)
  , GPIO
  , setPins
  , setAllPins
  , runGPIO
  ) where

import Control.Monad (forM_, void)
import Control.Monad.Trans.Cont (cont, evalCont)
import Data.Vector.Storable (fromList, replicate, unsafeWith)
import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>), liftIO)
import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
import Effectful.Exception (bracket)
import Foreign.C.String (withCString)
import Foreign.C.Types (CSize(CSize), CUInt)
import Foreign.Ptr (Ptr)
import Hsm.Core.Serial (makeSerial)
import Hsm.GPIO.FFI
  ( LineRequest
  , LineValue
  , chipClose
  , chipOpen
  , chipRequestLines
  , inactive
  , lineConfigAddLineSettings
  , lineConfigFree
  , lineConfigNew
  , lineRequestRelease
  , lineRequestSetValue
  , lineRequestSetValues
  , lineSettingsFree
  , lineSettingsNew
  , lineSettingsSetDirection
  , lineSettingsSetOutputValue
  , output
  , requestConfigFree
  , requestConfigNew
  , requestConfigSetConsumer
  )
import Hsm.Log (Log, Severity(Info, Trace), logMsg)
import Prelude hiding (replicate)

$(makeSerial "GPIO" "Pin" "pinLine" ''CUInt $ [2 .. 17] <> [20 .. 27])

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

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

pinCount :: Int
pinCount = length allPins

data GPIO (a :: * -> *) (b :: *)

type instance DispatchOf GPIO = Static WithSideEffects

newtype instance StaticRep GPIO =
  GPIO (Ptr LineRequest)

setPins :: (GPIO :> es, Log "gpio" :> es) => [GPIOPin] -> LineValue -> Eff es ()
setPins pins lineValue = do
  GPIO lineRequest <- getStaticRep
  logMsg Trace $ "Setting pin(s) " <> show pins <> " to " <> show lineValue
  forM_ pins $ \pin -> unsafeEff_ $ lineRequestSetValue lineRequest (pinLine pin) lineValue

setAllPins :: (GPIO :> es, Log "gpio" :> es) => LineValue -> Eff es ()
setAllPins lineValue = do
  GPIO lineRequest <- getStaticRep
  logMsg Trace $ "Setting all pins " <> show allPins <> " to " <> show lineValue
  unsafeEff_ . unsafeWith (replicate pinCount lineValue) $ void . lineRequestSetValues lineRequest

runGPIO :: (IOE :> es, Log "gpio" :> es) => String -> Eff (GPIO : es) a -> Eff es a
runGPIO consumer action = bracket lineRequestAlloc lineRequestDealloc $ \lineRequest -> evalStaticRep (GPIO lineRequest) action
  where
    contBracket alloc dealloc = cont $ bracket alloc dealloc
    chipPath = "/dev/gpiochip0"
    chipAlloc = do
      logMsg Info $ "Opening GPIO chip " <> chipPath
      liftIO $ withCString chipPath chipOpen
    chipDealloc chip = do
      logMsg Info $ "Closing GPIO chip " <> chipPath
      liftIO $ chipClose chip
    lineSettingsAlloc = do
      logMsg Info "Allocating line settings"
      lineSettings <- liftIO lineSettingsNew
      logMsg Info $ "With direction set to " <> show output
      liftIO . void $ lineSettingsSetDirection lineSettings output
      logMsg Info $ "With output set to " <> show inactive
      liftIO . void $ lineSettingsSetOutputValue lineSettings inactive
      return lineSettings
    lineSettingsDealloc lineSettings = do
      logMsg Info "Freeing line settings"
      liftIO $ lineSettingsFree lineSettings
    lineConfigAlloc lineSettings = do
      logMsg Info "Allocating line config"
      logMsg Info $ "With GPIO pins " <> show allPins
      lineConfig <- liftIO lineConfigNew
      liftIO . void . unsafeWith (fromList allLines) $ \pinsVector -> lineConfigAddLineSettings lineConfig pinsVector (CSize $ fromIntegral pinCount) lineSettings
      return lineConfig
    lineConfigDealloc lineConfig = do
      logMsg Info "Freeing line config"
      liftIO $ lineConfigFree lineConfig
    requestConfigAlloc = do
      logMsg Info "Allocating request config"
      logMsg Info $ "With consumer " <> consumer
      requestConfig <- liftIO requestConfigNew
      liftIO . withCString consumer $ requestConfigSetConsumer requestConfig
      return requestConfig
    requestConfigDealloc requestConfig = do
      logMsg Info "Freeing request config"
      liftIO $ requestConfigFree requestConfig
    lineRequestAlloc = do
      logMsg Info "Allocating line request"
      evalCont $ do
        chip <- contBracket chipAlloc chipDealloc
        lineSettings <- contBracket lineSettingsAlloc lineSettingsDealloc
        lineConfig <- contBracket (lineConfigAlloc lineSettings) lineConfigDealloc
        requestConfig <- contBracket requestConfigAlloc requestConfigDealloc
        return . liftIO $ chipRequestLines chip requestConfig lineConfig
    lineRequestDealloc lineRequest = do
      logMsg Info "Releasing line request"
      liftIO $ lineRequestRelease lineRequest