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

module Hsm.GPIO
  ( GPIO(..)
  , GPIOEffect
  , toggle
  , runGPIO
  ) where

import Data.Aeson (FromJSON)
import Data.Kind (Type)
import Data.List (intercalate)
import Data.Set (Set, toList, unions)
import Data.String (IsString)
import Data.Text (Text, pack)
import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
import Effectful.Dispatch.Static qualified as E
import Effectful.Exception (finally)
import Effectful.Log (Log, localDomain, logTrace_)
import GHC.Generics (Generic)
import Hsm.Core.Log (flushLogger)
import System.Process (callCommand)

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

data GPIOEffect key a b

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

-- Effect state is a mapping function from type `key` to a `Set` of GPIO pins.
-- This enables `key`s of any type to control many pins simultaneously. Using
-- a function (instead of `Data.Map`) ensures all keys map to pins, given the
-- provided function is total.
newtype instance E.StaticRep (GPIOEffect (key :: Type)) =
  GPIOEffect (key -> Set GPIO)

domain :: Text
domain = "gpio"

stateStr :: IsString a => Bool -> a
stateStr True = "on"
stateStr False = "off"

-- To control the pins, I use a subprocess call to `gpioset`. In the future
-- I'd prefer wrapping `libgpiod` directly. It looks like no one has created a
-- C wrapper yet, I might do it if I get bored. :)
gpioset :: Log :> es => Bool -> Set GPIO -> [Int] -> Eff es ()
gpioset state gpios periods = do
  localDomain domain $ logTrace_ $ "Calling command: " <> pack command
  E.unsafeEff_ $ callCommand command
  where
    lineArg gpio = show gpio <> "=" <> stateStr state <> " "
    command =
      "gpioset -t"
        <> intercalate "," (show <$> periods)
        <> " "
        <> concatMap lineArg (toList gpios)

logReport ::
     (Log :> es, Show key) => Bool -> key -> [Int] -> Set GPIO -> Eff es ()
logReport state key periods gpios = do
  localDomain domain $ logTrace_ report
  flushLogger
  where
    report =
      "Setting pins "
        <> pack (show gpios)
        <> " mapped to key "
        <> pack (show key)
        <> " to state "
        <> pack (show state)
        <> " using periods "
        <> pack (show periods)

toggle ::
     (GPIOEffect key :> es, Log :> es, Show key)
  => Bool
  -> key
  -> [Int]
  -> Eff es ()
toggle state key periods = do
  GPIOEffect mapper <- E.getStaticRep
  set $ mapper key
  where
    set gpios = do
      logReport state key periods gpios
      gpioset state gpios periods

runGPIO ::
     (IOE :> es, Log :> es, Bounded key, Enum key)
  => (key -> Set GPIO)
  -> Eff (GPIOEffect key : es) a
  -> Eff es a
runGPIO mapper action =
  E.evalStaticRep (GPIOEffect mapper) $ finally action release
  where
    gpios = unions $ mapper <$> [minBound .. maxBound]
    endReport =
      "Setting all mapped pins "
        <> pack (show gpios)
        <> " to state "
        <> stateStr False
    release = do
      localDomain domain $ logTrace_ endReport
      gpioset False gpios [0]