module Sketch.FRP.Copilot.Internals where

import Sketch.FRP.Copilot.Types
import Language.Copilot
import Control.Monad.Writer
import Control.Monad.State.Strict
import Data.Functor.Identity
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe

getTriggerLimit :: TriggerLimit -> Behavior Bool
getTriggerLimit :: TriggerLimit -> Behavior Bool
getTriggerLimit (TriggerLimit Behavior Bool
b) = Behavior Bool
b
getTriggerLimit TriggerLimit
NoTriggerLimit = Behavior Bool
true

addTriggerLimit :: TriggerLimit -> Behavior Bool -> Behavior Bool
addTriggerLimit :: TriggerLimit -> Behavior Bool -> Behavior Bool
addTriggerLimit TriggerLimit
tl Behavior Bool
c = TriggerLimit -> Behavior Bool
getTriggerLimit (TriggerLimit
tl TriggerLimit -> TriggerLimit -> TriggerLimit
forall a. Semigroup a => a -> a -> a
<> Behavior Bool -> TriggerLimit
TriggerLimit Behavior Bool
c)

-- | Gets a unique id.
getUniqueId :: String -> GenSketch ctx UniqueId
getUniqueId :: forall ctx. String -> GenSketch ctx UniqueId
getUniqueId String
s = do
	UniqueIds Map String Integer
m <- GenSketch ctx UniqueIds
forall s (m :: * -> *). MonadState s m => m s
get
	let u :: Integer
u = Integer -> (Integer -> Integer) -> Maybe Integer -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
1 Integer -> Integer
forall a. Enum a => a -> a
succ (String -> Map String Integer -> Maybe Integer
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
s Map String Integer
m)
	UniqueIds -> GenSketch ctx ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (UniqueIds -> GenSketch ctx ()) -> UniqueIds -> GenSketch ctx ()
forall a b. (a -> b) -> a -> b
$ Map String Integer -> UniqueIds
UniqueIds (Map String Integer -> UniqueIds)
-> Map String Integer -> UniqueIds
forall a b. (a -> b) -> a -> b
$ String -> Integer -> Map String Integer -> Map String Integer
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
s Integer
u Map String Integer
m
	UniqueId -> GenSketch ctx UniqueId
forall a. a -> GenSketch ctx a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> UniqueId
UniqueId Integer
u)

-- | Generates a unique name.
uniqueName :: String -> UniqueId -> String
uniqueName :: String -> UniqueId -> String
uniqueName String
s (UniqueId Integer
i)
	| Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
Prelude.== Integer
1 = String
s
	| Bool
otherwise = String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>  Integer -> String
forall a. Show a => a -> String
show Integer
i

uniqueName' :: String -> UniqueId -> String
uniqueName' :: String -> UniqueId -> String
uniqueName' String
s (UniqueId Integer
i) = String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>  Integer -> String
forall a. Show a => a -> String
show Integer
i

-- | Use to create an empty framework. 
--
-- It helps to specify the type of context to use:
--
-- > (emptyFramework @Arduino) { ... }
emptyFramework :: Context ctx => GenFramework ctx
emptyFramework :: forall ctx. Context ctx => GenFramework ctx
emptyFramework = GenFramework ctx
forall a. Monoid a => a
mempty

mkCChunk :: [CLine] -> [CChunk]
mkCChunk :: [CLine] -> [CChunk]
mkCChunk [CLine]
l = [[CLine] -> CChunk
CChunk [CLine]
l]

-- | 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 unique alias that can be 
-- used in a trigger.
defineTriggerAlias
	:: String
	-> GenFramework ctx
	-> GenSketch ctx (GenFramework ctx, String)
defineTriggerAlias :: forall ctx.
String
-> GenFramework ctx -> GenSketch ctx (GenFramework ctx, String)
defineTriggerAlias = String
-> String
-> GenFramework ctx
-> GenSketch ctx (GenFramework ctx, String)
forall ctx.
String
-> String
-> GenFramework ctx
-> GenSketch ctx (GenFramework ctx, String)
defineTriggerAlias' String
""

defineTriggerAlias'
	:: String
	-> String
	-> GenFramework ctx
	-> GenSketch ctx (GenFramework ctx, String)
defineTriggerAlias' :: forall ctx.
String
-> String
-> GenFramework ctx
-> GenSketch ctx (GenFramework ctx, String)
defineTriggerAlias' String
suffix String
cfuncname GenFramework ctx
f = do
	let basetname :: String
basetname = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
suffix 
		then String
cfuncname
		else String
cfuncname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
suffix
	UniqueId
u <- String -> GenSketch ctx UniqueId
forall ctx. String -> GenSketch ctx UniqueId
getUniqueId String
basetname
	let triggername :: String
triggername = String -> UniqueId -> String
uniqueName String
basetname UniqueId
u
	let define :: [CChunk]
define = if String
cfuncname String -> String -> Bool
forall a. Eq a => a -> a -> Bool
Prelude./= String
triggername
		then [CLine] -> [CChunk]
mkCChunk [ String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
"#define " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
triggername String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cfuncname	]
		else [CChunk]
forall a. Monoid a => a
mempty
	(GenFramework ctx, String)
-> GenSketch ctx (GenFramework ctx, String)
forall a. a -> GenSketch ctx a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenFramework ctx
f { defines = define <> defines f }, String
triggername)

data MkInputSource ctx t = InputSource
	{ forall ctx t. MkInputSource ctx t -> [CChunk]
defineVar :: [CChunk]
	-- ^ Added to the `Framework`'s `defines`, this typically
	-- defines a C variable.
	, forall ctx t. MkInputSource ctx t -> [CChunk]
setupInput :: [CChunk]
	-- ^ How to set up the input, not including pin mode.
	, forall ctx t. MkInputSource ctx t -> Map ctx PinMode
inputPinmode :: M.Map ctx PinMode
	-- ^ How pins are used by the input.
	, forall ctx t. MkInputSource ctx t -> [CChunk]
readInput :: [CChunk]
	-- ^ How to read a value from the input, this typically
	-- reads a value into a C variable.
	, forall ctx t. MkInputSource ctx t -> Stream t
inputStream :: Stream t
	-- ^ How to use Copilot's extern to access the input values.
	}

mkInput :: MkInputSource ctx t -> GenSketch ctx (Behavior t)
mkInput :: forall ctx t. MkInputSource ctx t -> GenSketch ctx (Behavior t)
mkInput MkInputSource ctx t
i = do
	UniqueId
u <- String -> GenSketch ctx UniqueId
forall ctx. String -> GenSketch ctx UniqueId
getUniqueId String
"input"
	[(TriggerLimit -> WriterT [SpecItem] Identity (),
  TriggerLimit -> GenFramework ctx)]
-> GenSketch ctx ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(UniqueId -> TriggerLimit -> WriterT [SpecItem] Identity ()
mkspec UniqueId
u, UniqueId -> TriggerLimit -> GenFramework ctx
f UniqueId
u)]
	Behavior t -> GenSketch ctx (Behavior t)
forall a. a -> GenSketch ctx a
forall (m :: * -> *) a. Monad m => a -> m a
return (MkInputSource ctx t -> Behavior t
forall ctx t. MkInputSource ctx t -> Stream t
inputStream MkInputSource ctx t
i)
  where
	f :: UniqueId -> TriggerLimit -> GenFramework ctx
f UniqueId
u TriggerLimit
ratelimited = Framework
		{ defines :: [CChunk]
defines = MkInputSource ctx t -> [CChunk]
forall ctx t. MkInputSource ctx t -> [CChunk]
defineVar MkInputSource ctx t
i [CChunk] -> [CChunk] -> [CChunk]
forall a. Semigroup a => a -> a -> a
<> UniqueId -> TriggerLimit -> [CChunk]
mkdefine UniqueId
u TriggerLimit
ratelimited
		, setups :: [CChunk]
setups = MkInputSource ctx t -> [CChunk]
forall ctx t. MkInputSource ctx t -> [CChunk]
setupInput MkInputSource ctx t
i
		, earlySetups :: [CChunk]
earlySetups = [CChunk]
forall a. Monoid a => a
mempty
		, pinmodes :: Map ctx (Set PinMode)
pinmodes = (PinMode -> Set PinMode)
-> Map ctx PinMode -> Map ctx (Set PinMode)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map PinMode -> Set PinMode
forall a. a -> Set a
S.singleton (MkInputSource ctx t -> Map ctx PinMode
forall ctx t. MkInputSource ctx t -> Map ctx PinMode
inputPinmode MkInputSource ctx t
i)
		, loops :: [CChunk]
loops = UniqueId -> TriggerLimit -> [CChunk] -> [CChunk]
mkloops UniqueId
u TriggerLimit
ratelimited (MkInputSource ctx t -> [CChunk]
forall ctx t. MkInputSource ctx t -> [CChunk]
readInput MkInputSource ctx t
i)
		}

	varname :: UniqueId -> String
varname = String -> UniqueId -> String
uniqueName String
"update_input"
	triggername :: UniqueId -> String
triggername = String -> UniqueId -> String
uniqueName String
"input"
	
	mkdefine :: UniqueId -> TriggerLimit -> [CChunk]
mkdefine UniqueId
_ TriggerLimit
NoTriggerLimit = []
	mkdefine UniqueId
u (TriggerLimit Behavior Bool
_) = [CLine] -> [CChunk]
mkCChunk ([CLine] -> [CChunk]) -> [CLine] -> [CChunk]
forall a b. (a -> b) -> a -> b
$ (String -> CLine) -> [String] -> [CLine]
forall a b. (a -> b) -> [a] -> [b]
map String -> CLine
CLine
		[ String
"bool " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UniqueId -> String
varname UniqueId
u String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = true;"
		, String
"void " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UniqueId -> String
triggername UniqueId
u String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (bool v) {"
		, String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UniqueId -> String
varname UniqueId
u String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = v;"
		, String
"}"
		]
	
	mkloops :: UniqueId -> TriggerLimit -> [CChunk] -> [CChunk]
mkloops UniqueId
_ TriggerLimit
NoTriggerLimit [CChunk]
reader = [CChunk]
reader
	mkloops UniqueId
u (TriggerLimit Behavior Bool
_) [CChunk]
reader = [CLine] -> [CChunk]
mkCChunk ([CLine] -> [CChunk]) -> [CLine] -> [CChunk]
forall a b. (a -> b) -> a -> b
$ [[CLine]] -> [CLine]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
		[ [ String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
"if (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UniqueId -> String
varname UniqueId
u String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") {" ]
		, (CLine -> CLine) -> [CLine] -> [CLine]
forall a b. (a -> b) -> [a] -> [b]
map (\(CLine String
l) -> String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
l ) [CLine]
readerlines
		, [ String -> CLine
CLine String
"}" ]
		]
	  where
		readerlines :: [CLine]
readerlines = (CChunk -> [CLine]) -> [CChunk] -> [CLine]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(CChunk [CLine]
l) -> [CLine]
l) [CChunk]
reader

	mkspec :: UniqueId -> TriggerLimit -> WriterT [SpecItem] Identity ()
mkspec UniqueId
_ TriggerLimit
NoTriggerLimit = () -> WriterT [SpecItem] Identity ()
forall a. a -> WriterT [SpecItem] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
	mkspec UniqueId
u (TriggerLimit Behavior Bool
c) = String -> Behavior Bool -> [Arg] -> WriterT [SpecItem] Identity ()
trigger (UniqueId -> String
triggername UniqueId
u) Behavior Bool
true [Behavior Bool -> Arg
forall a. Typed a => Stream a -> Arg
arg Behavior Bool
c]

evalSketch :: Context ctx => GenSketch ctx a -> (Maybe Spec, GenFramework ctx)
evalSketch :: forall ctx a.
Context ctx =>
GenSketch ctx a
-> (Maybe (WriterT [SpecItem] Identity ()), GenFramework ctx)
evalSketch (GenSketch WriterT
  [(TriggerLimit -> WriterT [SpecItem] Identity (),
    TriggerLimit -> GenFramework ctx)]
  (State UniqueIds)
  a
s) = (Maybe (WriterT [SpecItem] Identity ())
spec, GenFramework ctx
f)
  where
	([TriggerLimit -> WriterT [SpecItem] Identity ()]
is, [TriggerLimit -> GenFramework ctx]
fs) = [(TriggerLimit -> WriterT [SpecItem] Identity (),
  TriggerLimit -> GenFramework ctx)]
-> ([TriggerLimit -> WriterT [SpecItem] Identity ()],
    [TriggerLimit -> GenFramework ctx])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(TriggerLimit -> WriterT [SpecItem] Identity (),
   TriggerLimit -> GenFramework ctx)]
 -> ([TriggerLimit -> WriterT [SpecItem] Identity ()],
     [TriggerLimit -> GenFramework ctx]))
-> [(TriggerLimit -> WriterT [SpecItem] Identity (),
     TriggerLimit -> GenFramework ctx)]
-> ([TriggerLimit -> WriterT [SpecItem] Identity ()],
    [TriggerLimit -> GenFramework ctx])
forall a b. (a -> b) -> a -> b
$ 
		Identity
  [(TriggerLimit -> WriterT [SpecItem] Identity (),
    TriggerLimit -> GenFramework ctx)]
-> [(TriggerLimit -> WriterT [SpecItem] Identity (),
     TriggerLimit -> GenFramework ctx)]
forall a. Identity a -> a
runIdentity (Identity
   [(TriggerLimit -> WriterT [SpecItem] Identity (),
     TriggerLimit -> GenFramework ctx)]
 -> [(TriggerLimit -> WriterT [SpecItem] Identity (),
      TriggerLimit -> GenFramework ctx)])
-> Identity
     [(TriggerLimit -> WriterT [SpecItem] Identity (),
       TriggerLimit -> GenFramework ctx)]
-> [(TriggerLimit -> WriterT [SpecItem] Identity (),
     TriggerLimit -> GenFramework ctx)]
forall a b. (a -> b) -> a -> b
$ StateT
  UniqueIds
  Identity
  [(TriggerLimit -> WriterT [SpecItem] Identity (),
    TriggerLimit -> GenFramework ctx)]
-> UniqueIds
-> Identity
     [(TriggerLimit -> WriterT [SpecItem] Identity (),
       TriggerLimit -> GenFramework ctx)]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (WriterT
  [(TriggerLimit -> WriterT [SpecItem] Identity (),
    TriggerLimit -> GenFramework ctx)]
  (State UniqueIds)
  a
-> StateT
     UniqueIds
     Identity
     [(TriggerLimit -> WriterT [SpecItem] Identity (),
       TriggerLimit -> GenFramework ctx)]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT WriterT
  [(TriggerLimit -> WriterT [SpecItem] Identity (),
    TriggerLimit -> GenFramework ctx)]
  (State UniqueIds)
  a
s) (Map String Integer -> UniqueIds
UniqueIds Map String Integer
forall a. Monoid a => a
mempty)
	f :: GenFramework ctx
f = [GenFramework ctx] -> GenFramework ctx
forall a. Monoid a => [a] -> a
mconcat (((TriggerLimit -> GenFramework ctx) -> GenFramework ctx)
-> [TriggerLimit -> GenFramework ctx] -> [GenFramework ctx]
forall a b. (a -> b) -> [a] -> [b]
map (\TriggerLimit -> GenFramework ctx
f' -> TriggerLimit -> GenFramework ctx
f' TriggerLimit
NoTriggerLimit) [TriggerLimit -> GenFramework ctx]
fs)
	-- Copilot will throw an ugly error if given a spec that does
	-- nothing at all, so return Nothing to avoid that.
	spec :: Maybe Spec
	spec :: Maybe (WriterT [SpecItem] Identity ())
spec = if [TriggerLimit -> WriterT [SpecItem] Identity ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TriggerLimit -> WriterT [SpecItem] Identity ()]
is
		then Maybe (WriterT [SpecItem] Identity ())
forall a. Maybe a
Nothing
		else WriterT [SpecItem] Identity ()
-> Maybe (WriterT [SpecItem] Identity ())
forall a. a -> Maybe a
Just (WriterT [SpecItem] Identity ()
 -> Maybe (WriterT [SpecItem] Identity ()))
-> WriterT [SpecItem] Identity ()
-> Maybe (WriterT [SpecItem] Identity ())
forall a b. (a -> b) -> a -> b
$ [WriterT [SpecItem] Identity ()] -> WriterT [SpecItem] Identity ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([WriterT [SpecItem] Identity ()]
 -> WriterT [SpecItem] Identity ())
-> [WriterT [SpecItem] Identity ()]
-> WriterT [SpecItem] Identity ()
forall a b. (a -> b) -> a -> b
$ ((TriggerLimit -> WriterT [SpecItem] Identity ())
 -> WriterT [SpecItem] Identity ())
-> [TriggerLimit -> WriterT [SpecItem] Identity ()]
-> [WriterT [SpecItem] Identity ()]
forall a b. (a -> b) -> [a] -> [b]
map (\TriggerLimit -> WriterT [SpecItem] Identity ()
i -> TriggerLimit -> WriterT [SpecItem] Identity ()
i TriggerLimit
NoTriggerLimit) [TriggerLimit -> WriterT [SpecItem] Identity ()]
is

-- | Extracts a copilot `Spec` from a `Sketch`.
--
-- This can be useful to intergrate with other libraries 
-- such as copilot-theorem.
sketchSpec :: Context ctx => GenSketch ctx a -> Spec
sketchSpec :: forall ctx a.
Context ctx =>
GenSketch ctx a -> WriterT [SpecItem] Identity ()
sketchSpec = WriterT [SpecItem] Identity ()
-> Maybe (WriterT [SpecItem] Identity ())
-> WriterT [SpecItem] Identity ()
forall a. a -> Maybe a -> a
fromMaybe (() -> WriterT [SpecItem] Identity ()
forall a. a -> WriterT [SpecItem] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Maybe (WriterT [SpecItem] Identity ())
 -> WriterT [SpecItem] Identity ())
-> (GenSketch ctx a -> Maybe (WriterT [SpecItem] Identity ()))
-> GenSketch ctx a
-> WriterT [SpecItem] Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (WriterT [SpecItem] Identity ()), GenFramework ctx)
-> Maybe (WriterT [SpecItem] Identity ())
forall a b. (a, b) -> a
fst ((Maybe (WriterT [SpecItem] Identity ()), GenFramework ctx)
 -> Maybe (WriterT [SpecItem] Identity ()))
-> (GenSketch ctx a
    -> (Maybe (WriterT [SpecItem] Identity ()), GenFramework ctx))
-> GenSketch ctx a
-> Maybe (WriterT [SpecItem] Identity ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenSketch ctx a
-> (Maybe (WriterT [SpecItem] Identity ()), GenFramework ctx)
forall ctx a.
Context ctx =>
GenSketch ctx a
-> (Maybe (WriterT [SpecItem] Identity ()), GenFramework ctx)
evalSketch