-- | You should not need to import this module unless you're adding support
-- for a new model of Arduino, or an Arduino library.

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Copilot.Arduino.Internals where

import Language.Copilot
import Control.Monad.Writer
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Type.Bool
import GHC.TypeLits

-- | A value that changes over time.
--
-- This is implemented as a `Stream` in the Copilot DSL.
-- Copilot provides many operations on streams, for example
-- `Language.Copilot.&&` to combine two streams of Bools.
-- 
-- For documentation on using the Copilot DSL, see
-- <https://copilot-language.github.io/>
type Behavior t = Stream t

-- | A Behavior with an additional phantom type `p`.
--
-- The Compilot DSL only lets a Stream contain basic C types,
-- a limitation that `Behavior` also has. When more type safely
-- is needed, this can be used.
data TypedBehavior p t = TypedBehavior (Behavior t)

-- | A discrete event, that occurs at particular points in time.
data Event p v = Event v (Stream Bool)

-- | An Arduino sketch, implemented using Copilot.
--
-- It's best to think of the `Sketch` as a description of the state of the
-- Arduino at any point in time.
--
-- Under the hood, the `Sketch` is run in a loop. On each iteration, it first
-- reads all inputs and then updates outputs as needed.
--
-- While it is a monad, a Sketch's outputs are not updated in any
-- particular order, because Copilot does not guarantee any order.
newtype Sketch t = Sketch (Writer [(Spec, Framework)] t)
        deriving (Monad, Applicative, Functor, MonadWriter [(Spec, Framework)])

instance Monoid (Sketch ()) where
        mempty = Sketch (return ())

instance Semigroup (Sketch t) where
        (Sketch a) <> (Sketch b) = Sketch (a >> b)

-- | The framework of an Arduino sketch.
data Framework = Framework
        { defines :: [CLine]
        -- ^ Things that come before the C code generated by Copilot.
        , setups :: [CLine]
        -- ^ Things to do at setup, not including configuring pins.
        , pinmodes :: M.Map PinId (S.Set PinMode)
        -- ^ How pins are used.
        , loops :: [CLine]
        -- ^ Things to run in `loop`.
        }

-- | A line of C code.
newtype CLine = CLine { fromCLine :: String }

instance Semigroup Framework where
        a <> b = Framework
                { defines = defines a <> defines b
                , setups = setups a <> setups b
                , pinmodes = M.unionWith S.union (pinmodes a) (pinmodes b)
                , loops = loops a  <> loops b
                }

instance Monoid Framework where
        mempty = Framework mempty mempty mempty mempty

-- | Copilot only supports calling a trigger with a given name once
-- per Spec; the generated C code will fail to build if the same name is
-- used in two triggers. This generates a name from a suffix, which should
-- be somehow unique.
defineTriggerAlias :: String -> String -> Framework -> (Framework, String)
defineTriggerAlias suffix cfuncname f =
        (f { defines = define : defines f }, triggername)
  where
        triggername = cfuncname <> "_" <> suffix
        define = CLine $ "#define " <> triggername <> " " <> cfuncname

data InputSource t = InputSource
        { defineVar :: [CLine]
        -- ^ Added to the `Framework`'s `defines`, this typically
        -- defines a C variable.
        , setupInput :: [CLine]
        -- ^ How to set up the input, not including pin mode.
        , inputPinmode :: M.Map PinId PinMode
        , readInput :: [CLine]
        -- ^ How to read a value from the input, this typically
        -- reads a value into a C variable.
        , inputStream :: Stream t
        }

mkInput :: InputSource t -> Sketch (Behavior t)
mkInput i = do
        tell [(return (), f)]
        return (inputStream i)
  where
        f = Framework
                { defines = defineVar i
                , setups = setupInput i
                , pinmodes = M.map S.singleton (inputPinmode i)
                , loops = readInput i
                }

-- | A pin on the Arduino board.
--
-- For definitions of pins like `Copilot.Arduino.Uno.pin12`, 
-- load a module such as Copilot.Arduino.Uno, which provides the pins of a
-- particular board.
--
-- A type-level list indicates how a Pin can be used, so the haskell
-- compiler will detect impossible uses of pins.
newtype Pin t = Pin PinId
        deriving (Show, Eq, Ord)

newtype PinId = PinId Int16
        deriving (Show, Eq, Ord)

data PinCapabilities
        = DigitalIO
        | AnalogInput
        | PWM
        deriving (Show, Eq, Ord)

type family IsDigitalIOPin t where
        IsDigitalIOPin t =
                'True ~ If (HasPinCapability 'DigitalIO t)
                        ('True)
                        (TypeError ('Text "This Pin does not support digital IO"))

type family IsAnalogInputPin t where
        IsAnalogInputPin t =
                'True ~ If (HasPinCapability 'AnalogInput t)
                        ('True)
                        (TypeError ('Text "This Pin does not support analog input"))

type family IsPWMPin t where
        IsPWMPin t =
                'True ~ If (HasPinCapability 'PWM t)
                        ('True)
                        (TypeError ('Text "This Pin does not support PWM"))

type family HasPinCapability (c :: t) (list :: [t]) :: Bool where
        HasPinCapability c '[] = 'False
        HasPinCapability c (x ': xs) = SameCapability c x || HasPinCapability c xs

type family SameCapability a b :: Bool where
        SameCapability 'DigitalIO 'DigitalIO = 'True
        SameCapability 'AnalogInput 'AnalogInput = 'True
        SameCapability 'PWM 'PWM = 'True
        SameCapability _ _ = 'False

data PinMode = InputMode | InputPullupMode | OutputMode
        deriving (Show, Eq, Ord)

-- | Things that can have a `Behavior` or `Event` output to them.
class Output o t where
        (=:) :: o -> t -> Sketch ()
        -- ^ Connect a `Behavior` or `Event` to an `Output`
        --
        -- > led =: blinking
        --
        -- When a `Behavior` is used, its current value is written on each
        -- iteration of the `Sketch`. 
        --
        -- For example, this constantly turns on the LED, even though it will
        -- already be on after the first iteration, because `true`
        -- is a `Behavior` (that is always True).
        --
        -- > led =: true
        --
        -- To avoid unncessary work being done, you can use an `Event`
        -- instead. Then the write only happens at the points in time
        -- when the `Event` occurs.
        -- 
        -- So to make the LED only be turned on in the first iteration,
        -- and allow it to remain on thereafter without doing extra work:
        --	
        -- > led =: true @: firstIteration

-- Same fixity as =<<
infixr 1 =:

instance Output o (Event () (Stream v)) => Output o (Behavior v) where
        (=:) o b = o =: te
          where
                te :: Event () (Stream v)
                te = Event b true

instance Output o (Event p (Stream v)) => Output o (TypedBehavior p v) where
        (=:) o (TypedBehavior b) = o =: te
          where
                te :: Event p (Stream v)
                te = Event b true

-- | This type family is open, so it can be extended when adding other data
-- types to the IsBehavior class.
type family BehaviorToEvent a
type instance BehaviorToEvent (Behavior v) = Event () (Stream v)
type instance BehaviorToEvent (TypedBehavior p v) = Event p (Stream v)

class IsBehavior behavior where
        -- | Generate an event, from some type of behavior,
        -- that only occurs when the `Behavior` Bool is True.
        (@:) :: behavior -> Behavior Bool -> BehaviorToEvent behavior

instance IsBehavior (Behavior v) where
        b @: c = Event b c

instance IsBehavior (TypedBehavior p v) where
        (@:) (TypedBehavior b) c = Event b c

instance IsDigitalIOPin t => Output (Pin t) (Event () (Stream Bool)) where
        (Pin p@(PinId n)) =: (Event b c) = tell [(go, f)]
          where
                go = trigger triggername c [arg (constant n), arg b]
                (f, triggername) =
                        defineTriggerAlias (show n) "digitalWrite" $
                                mempty { pinmodes = M.singleton p (S.singleton OutputMode) }

instance IsPWMPin t => Output (Pin t) (Event 'PWM (Stream Word8)) where
        (Pin (PinId n)) =: (Event v c) = tell [(go, f)]
          where
                go = trigger triggername c [arg (constant n), arg v]
                -- analogWrite does not need any pinmodes set up
                (f, triggername) = defineTriggerAlias (show n) "analogWrite" mempty

class Input o t where
        -- | The list is input to use when simulating the Sketch.
        input' :: o -> [t] -> Sketch (Behavior t)

instance IsDigitalIOPin t => Input (Pin t) Bool where
        input' (Pin p@(PinId n)) interpretvalues = mkInput $ InputSource
                { defineVar = [CLine $ "bool " <> varname <> ";"]
                , setupInput = []
                , inputPinmode = M.singleton p InputMode
                , readInput = [CLine $ varname <> " = digitalRead(" <> show n <> ");"]
                , inputStream = extern varname interpretvalues'
                }
          where
                varname = "arduino_digital_pin_input" <> show n
                interpretvalues'
                        | null interpretvalues = Nothing
                        | otherwise = Just interpretvalues

-- | Voltage read from an Arduino's ADC. Ranges from 0-1023.
type Voltage = Int16

instance IsAnalogInputPin t => Input (Pin t) Voltage where
        input' (Pin (PinId n)) interpretvalues = mkInput $ InputSource
                { defineVar = [CLine $ "int " <> varname <> ";"]
                , setupInput = []
                , inputPinmode = mempty
                , readInput = [CLine $ varname <> " = analogRead(" <> show n <> ");"]
                , inputStream = extern varname interpretvalues'
                }
          where
                varname = "arduino_analog_pin_input" <> show n
                interpretvalues'
                        | null interpretvalues = Nothing
                        | otherwise = Just interpretvalues