{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Copilot.Arduino.Library.EEPROMex (
maxAllowedWrites,
memPool,
StartAddress(..),
EndAddress(..),
EEPROMable,
alloc,
alloc',
Location,
Range,
RangeIndex,
allocRange,
sweepRange,
sweepRange',
RangeWrites(..),
scanRange,
RangeReads(..),
) where
import Copilot.Arduino
import Copilot.Arduino.Internals
import Control.Monad.Writer
import Data.Proxy
import qualified Prelude
maxAllowedWrites :: Word16 -> Sketch ()
maxAllowedWrites n = tell [(\_ -> return (), \_ -> f)]
where
f = mempty
{ earlySetups = mkCChunk
[ CLine "#ifdef _EEPROMEX_DEBUG"
, CLine $ "EEPROM.setMaxAllowedWrites(" <> show n <> ");"
, CLine "#else"
, CLine "#error \"maxAllowedWrites cannot be checked because _EEPROMEX_DEBUG is not set.\""
, CLine "#endif"
]
, defines = mkCChunk [ includeCLine ]
}
newtype StartAddress = StartAddress Word16
deriving (Num, Eq, Ord, Enum, Show, Read, Bounded, Integral, Real)
newtype EndAddress = EndAddress Word16
deriving (Num, Eq, Ord, Enum, Show, Read, Bounded, Integral, Real)
memPool :: StartAddress -> EndAddress -> Sketch ()
memPool (StartAddress start) (EndAddress end) =
tell [(\_ -> return (), \_ -> f)]
where
f = mempty
{ earlySetups = mkCChunk
[ CLine $ "EEPROM.setMemPool("
<> show start
<> ", "
<> show end
<> ");"
]
, defines = mkCChunk [ includeCLine ]
}
alloc :: forall t. (EEPROMable t) => Sketch (Behavior t, Location t)
alloc = alloc' (factoryValue (Proxy @t))
alloc' :: forall t. (EEPROMable t) => t -> Sketch (Behavior t, Location t)
alloc' interpretval = do
i <- getUniqueId "eeprom"
let addrvarname = uniqueName "eeprom_address" i
let bootvarname = uniqueName "eeprom_boot_val" i
let proxy = Proxy @t
bootval <- mkInput $ InputSource
{ defineVar =
[ CChunk [includeCLine]
, CChunk
[ CLine $ "int " <> addrvarname <> ";"
, CLine $ showCType proxy <> " " <> bootvarname <> ";"
, CLine $ "void " <> eepromWriterName i
<> "(" <> showCType proxy <> " value) {"
, CLine $ " EEPROM." <> writeValue proxy
<> "(" <> addrvarname <> ", value);"
, CLine "}"
]
]
, setupInput = mkCChunk
[ CLine $ addrvarname <>
" = EEPROM.getAddress(sizeof("
<> showCType proxy <> "));"
, CLine $ bootvarname <>
" = EEPROM."
<> readValue proxy <> "(" <> addrvarname <> ");"
]
, readInput = []
, inputStream = extern bootvarname (Just (repeat interpretval))
, inputPinmode = mempty
}
return (bootval, Location i)
eepromWriterName :: UniqueId -> String
eepromWriterName = uniqueName' "eeprom_write"
data Location t = Location UniqueId
instance EEPROMable t => Output (Location t) (Event () (Stream t)) where
Location i =: (Event v c) = do
(f, triggername) <- defineTriggerAlias (eepromWriterName i) mempty
tell [(go triggername, \_ -> f)]
where
go triggername tl =
let c' = addTriggerLimit tl c
in trigger triggername c' [arg v]
data Range t = Range
{ rangeLocation :: Location (Range t)
, rangeSize :: Word16
}
allocRange :: (EEPROMable t) => Word16 -> Sketch (Range t)
allocRange sz = do
i <- getUniqueId "eeprom"
return (Range (Location i) sz)
data RangeWrites t = RangeWrites
(Behavior Bool -> Behavior RangeIndex)
(Behavior t)
type RangeIndex = Word16
instance EEPROMable t => Output (Range t) (RangeWrites t) where
(=:) = writeRange true
instance EEPROMable t => Output (Range t) (Event () (RangeWrites t)) where
range =: Event ws c =
writeRange c range ws
instance EEPROMable t => IsBehavior (RangeWrites t) where
(@:) = Event
type instance BehaviorToEvent (RangeWrites t) = Event () (RangeWrites t)
writeRange :: forall t. EEPROMable t => Behavior Bool -> Range t -> RangeWrites t -> Sketch()
writeRange c range (RangeWrites idx v) = do
(f', triggername) <- defineTriggerAlias writername f
tell [(spec triggername, \_ -> f')]
where
Location i = rangeLocation range
idx' = idx c `mod` constant (rangeSize range)
startaddrvarname = eepromRangeStartAddrName i
writername = uniqueName "eeprom_range_write" i
proxy = Proxy @t
f = Framework
{ defines =
[ CChunk [includeCLine]
, CChunk
[ CLine $ "int " <> startaddrvarname <> ";"
, CLine $ "void " <> writername
<> "(" <> showCType proxy <> " value"
<> ", " <> showCType (Proxy @Word16) <> " offset"
<> ") {"
, CLine $ " EEPROM." <> writeValue proxy
<> "(" <> startaddrvarname
<> " + offset*sizeof("
<> showCType proxy
<> ")"
<> ", value);"
, CLine "}"
]
]
, setups = mkCChunk
[ CLine $ startaddrvarname <> " = EEPROM.getAddress"
<> "(sizeof(" <> showCType proxy <> ")"
<> " * " <> show (rangeSize range)
<> ");"
]
, earlySetups = []
, pinmodes = mempty
, loops = mempty
}
spec triggername tl =
let c' = addTriggerLimit tl c
in trigger triggername c' [arg idx', arg v]
eepromRangeStartAddrName :: UniqueId -> String
eepromRangeStartAddrName = uniqueName "eeprom_range_address"
sweepRange :: RangeIndex -> Behavior t -> RangeWrites t
sweepRange start = RangeWrites (sweepRange' start)
sweepRange' :: RangeIndex -> Behavior Bool -> Behavior RangeIndex
sweepRange' start c = cnt
where
cnt = [start] ++ rest
rest = if c then cnt + 1 else cnt
data RangeReads t = RangeReads (Range t) RangeIndex (Behavior RangeIndex)
scanRange :: Range t -> RangeIndex -> RangeReads t
scanRange r startidx = RangeReads r startidx cnt
where
cnt = [startidx+1] ++ rest
rest = cnt + 1
instance (ShowCType t, EEPROMable t) => Input (RangeReads t) t where
input' (RangeReads range startidx idx) interpretvalues = do
(f, triggername) <- defineTriggerAlias indexvarupdatername mempty
let t tl =
let c = getTriggerLimit tl
in trigger triggername c [arg idx']
tell [(t, \_ -> f)]
mkInput $ InputSource
{ defineVar = mkCChunk
[ CLine $ showCType proxy <> " " <> valname <> ";"
, CLine $ "int " <> indexvarname <> ";"
, CLine $ "void " <> indexvarupdatername <> " (int idx) {"
, CLine $ " " <> indexvarname <> " = idx;"
, CLine $ "}"
]
, setupInput = mkCChunk
[ CLine $ indexvarname <> " = " <> show startidx' <> ";" ]
, readInput = mkCChunk
[ CLine $ valname <> " = EEPROM." <> readValue proxy
<> "("
<> eepromRangeStartAddrName i
<> " + " <> indexvarname
<> "*sizeof("
<> showCType proxy
<> ")"
<> ");"
]
, inputStream = extern valname interpretvalues'
, inputPinmode = mempty
}
where
Location i = rangeLocation range
idx' = idx `mod` constant (rangeSize range)
startidx' = startidx `Prelude.mod` rangeSize range
proxy = Proxy @t
indexvarname = uniqueName "eeprom_range_read_index" i
indexvarupdatername = uniqueName "eeprom_range_read" i
valname = uniqueName "eeprom_range_val" i
interpretvalues'
| null interpretvalues = Nothing
| otherwise = Just interpretvalues
class (ShowCType t, Typed t) => EEPROMable t where
readValue :: Proxy t -> String
writeValue :: Proxy t -> String
factoryValue :: Proxy t -> t
instance EEPROMable Bool where
readValue _ = "readByte"
writeValue _ = "updateByte"
factoryValue _ = True
instance EEPROMable Int8 where
readValue _ = "readByte"
writeValue _ = "updateByte"
factoryValue _ = minBound
instance EEPROMable Int16 where
readValue _ = "readInt"
writeValue _ = "updateInt"
factoryValue _= minBound
instance EEPROMable Int32 where
readValue _ = "readLong"
writeValue _ = "updateLong"
factoryValue _= minBound
instance EEPROMable Word8 where
readValue _ = "readByte"
writeValue _ = "updateByte"
factoryValue _ = maxBound
instance EEPROMable Word16 where
readValue _ = "readInt"
writeValue _ = "updateInt"
factoryValue _ = maxBound
instance EEPROMable Word32 where
readValue _ = "readLong"
writeValue _ = "updateLong"
factoryValue _ = maxBound
instance EEPROMable Float where
readValue _ = "readFloat"
writeValue _ = "updateFloat"
factoryValue _ = 0/0
instance EEPROMable Double where
readValue _ = "readDouble"
writeValue _ = "updateDOuble"
factoryValue _ = 0/0
includeCLine :: CLine
includeCLine = CLine "#include <EEPROMex.h>"