{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
{-|
Module      : Tesla.Car.Command
Description : Commands executed on a car.

Executing commands within the Car Monad.
-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Tesla.Car.Command (
  Time(..), mkTime, fromTime,
  runCmd, runCmd', CommandResponse, Car,
  (.=),
  -- * TH support for generating commands.
  mkCommand, mkCommands, mkNamedCommands) where

import           Control.Lens hiding ((.=))
import           Control.Monad.IO.Class (MonadIO (..))
import           Data.Aeson
import           Data.Aeson.Lens        (_Bool, _String, key)
import qualified Data.ByteString.Lazy   as BL
import           Data.Finite            (Finite, getFinite, modulo)
import           Data.Text              (Text)
import           GHC.TypeNats
import           Language.Haskell.TH
import           Network.Wreq.Types     (FormValue (..))
import           Text.Casing            (fromSnake, toCamel)

import           Tesla.Car
import           Tesla.Internal.HTTP
import Data.Aeson.Types (Pair)

-- | A CommandResponse wraps an Either such that Left represents a
-- failure message and Right suggests the command was successful.
type CommandResponse = Either Text ()

-- | Data type representing local time in minutes since midnight.
newtype Time = Time (Finite 1440)

instance Show Time where show :: Time -> String
show (Time Finite 1440
t) = forall a. Show a => a -> String
show (forall a. Integral a => a -> Integer
toInteger Finite 1440
t)

instance Num Time where
  fromInteger :: Integer -> Time
fromInteger = Finite 1440 -> Time
Time forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). KnownNat n => Integer -> Finite n
modulo
  abs :: Time -> Time
abs = forall a. a -> a
id
  signum :: Time -> Time
signum = forall a b. a -> b -> a
const Time
1
  (Time Finite 1440
f1) * :: Time -> Time -> Time
* (Time Finite 1440
f2) = Finite 1440 -> Time
Time (Finite 1440
f1 forall a. Num a => a -> a -> a
* Finite 1440
f2)
  (Time Finite 1440
f1) + :: Time -> Time -> Time
+ (Time Finite 1440
f2) = Finite 1440 -> Time
Time (Finite 1440
f1 forall a. Num a => a -> a -> a
+ Finite 1440
f2)
  (Time Finite 1440
f1) - :: Time -> Time -> Time
- (Time Finite 1440
f2) = Finite 1440 -> Time
Time (Finite 1440
f1 forall a. Num a => a -> a -> a
- Finite 1440
f2)

instance FormValue Time where
  renderFormValue :: Time -> ByteString
renderFormValue (Time Finite 1440
x) = forall a. FormValue a => a -> ByteString
renderFormValue (forall (n :: Nat). Finite n -> Integer
getFinite Finite 1440
x)

instance ToJSON Time where
  toJSON :: Time -> Value
toJSON (Time Finite 1440
x) = forall a. ToJSON a => a -> Value
toJSON (forall (n :: Nat). Finite n -> Integer
getFinite Finite 1440
x)

-- | Make a 'Time' with the given hours and minutes.
mkTime :: Finite 24 -> Finite 60 -> Time
mkTime :: Finite 24 -> Finite 60 -> Time
mkTime Finite 24
h Finite 60
m = Finite 1440 -> Time
Time forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). KnownNat n => Integer -> Finite n
modulo (forall a. Integral a => a -> Integer
toInteger Finite 24
h forall a. Num a => a -> a -> a
* Integer
60 forall a. Num a => a -> a -> a
+ forall a. Integral a => a -> Integer
toInteger Finite 60
m)

-- | Get the hours and minutes out of a 'Time'.
fromTime :: Time -> (Finite 24, Finite 60)
fromTime :: Time -> (Finite 24, Finite 60)
fromTime (Time Finite 1440
t) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall (m :: Nat) (n :: Nat).
(KnownNat m, KnownNat n, n <= m) =>
Finite m -> Finite n
f forall (m :: Nat) (n :: Nat).
(KnownNat m, KnownNat n, n <= m) =>
Finite m -> Finite n
f (Finite 1440
t forall a. Integral a => a -> a -> (a, a)
`divMod` Finite 1440
60)
  where
    f :: forall m n. (KnownNat m, KnownNat n, n <= m) => Finite m -> Finite n
    f :: forall (m :: Nat) (n :: Nat).
(KnownNat m, KnownNat n, n <= m) =>
Finite m -> Finite n
f = forall (n :: Nat). KnownNat n => Integer -> Finite n
modulo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger

-- | Run a command with a JSON payload.
runCmd :: MonadIO m => String -> [Pair] -> Car m CommandResponse
runCmd :: forall (m :: * -> *).
MonadIO m =>
String -> [Pair] -> Car m CommandResponse
runCmd String
cmd [Pair]
p = do
  Text
v <- forall (m :: * -> *). MonadReader CarEnv m => m Text
currentVehicleID
  Value
j :: Value <- forall (m :: * -> *) j a.
(HasTeslaAuth m, FromJSON j, Postable a, MonadIO m) =>
String -> a -> m j
jpostAuth (Text -> ShowS
vehicleURL Text
v forall a b. (a -> b) -> a -> b
$ String
"command/" forall a. Semigroup a => a -> a -> a
<> String
cmd) ([Pair] -> Value
object [Pair]
p)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Value
j forall s a. s -> Getting (First a) s a -> Maybe a
^? forall t. AsValue t => Key -> Traversal' t Value
key Key
"response" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Key -> Traversal' t Value
key Key
"result" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t Bool
_Bool of
    Just Bool
True -> forall a b. b -> Either a b
Right ()
    Maybe Bool
_         -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Value
j forall s a. s -> Getting a s a -> a
^. forall t. AsValue t => Key -> Traversal' t Value
key Key
"response" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Key -> Traversal' t Value
key Key
"reason" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t Text
_String


-- | Run command without a payload
runCmd' :: MonadIO m => String -> Car m CommandResponse
runCmd' :: forall (m :: * -> *). MonadIO m => String -> Car m CommandResponse
runCmd' String
cmd =  do
  Text
v <- forall (m :: * -> *). MonadReader CarEnv m => m Text
currentVehicleID
  Value
j :: Value <- forall (m :: * -> *) j a.
(HasTeslaAuth m, FromJSON j, Postable a, MonadIO m) =>
String -> a -> m j
jpostAuth (Text -> ShowS
vehicleURL Text
v forall a b. (a -> b) -> a -> b
$ String
"command/" forall a. Semigroup a => a -> a -> a
<> String
cmd) ByteString
BL.empty
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Value
j forall s a. s -> Getting (First a) s a -> Maybe a
^? forall t. AsValue t => Key -> Traversal' t Value
key Key
"response" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Key -> Traversal' t Value
key Key
"result" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t Bool
_Bool of
    Just Bool
True -> forall a b. b -> Either a b
Right ()
    Maybe Bool
_         -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Value
j forall s a. s -> Getting a s a -> a
^. forall t. AsValue t => Key -> Traversal' t Value
key Key
"response" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Key -> Traversal' t Value
key Key
"reason" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t Text
_String

instance FormValue Bool where
  renderFormValue :: Bool -> ByteString
renderFormValue Bool
True  = ByteString
"true"
  renderFormValue Bool
False = ByteString
"false"

-- | Build a simple named command car that posts to the given named endpoint.
mkCommand :: String -> String -> Q [Dec]
mkCommand :: String -> String -> Q [Dec]
mkCommand String
s String
u = do
  let m :: Name
m = String -> Name
mkName String
"m"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [
    Name -> Type -> Dec
SigD (String -> Name
mkName String
s) ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
m Specificity
inferredSpec] [Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName String
"MonadIO")) (Name -> Type
VarT Name
m)]
                     (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName String
"Car")) (Name -> Type
VarT Name
m)) (Name -> Type
ConT (String -> Name
mkName String
"CommandResponse")))),
    Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
s) [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
expr) []]]
  where expr :: Exp
expr = [Pat] -> Exp -> Exp
LamE [] (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (String -> Name
mkName String
"runCmd'")) (Lit -> Exp
LitE (String -> Lit
StringL String
u)))

cmapM :: (Monoid b, Applicative f) => (a -> f b) -> [a] -> f b
cmapM :: forall b (f :: * -> *) a.
(Monoid b, Applicative f) =>
(a -> f b) -> [a] -> f b
cmapM a -> f b
f [a]
xs = forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f [a]
xs

-- | Build a bunch of commands from a list of named endpoints, defining
-- functions by removing the common prefix.
mkCommands :: [String] -> Q [Dec]
mkCommands :: [String] -> Q [Dec]
mkCommands [String]
targets = forall b (f :: * -> *) a.
(Monoid b, Applicative f) =>
(a -> f b) -> [a] -> f b
cmapM String -> Q [Dec]
easyCMD [String]
targets
  where
    prefix :: String
prefix = [String] -> String
commonPrefix [String]
targets
    easyCMD :: String -> Q [Dec]
    easyCMD :: String -> Q [Dec]
easyCMD String
target = do
      let s :: String
s = forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix) String
target
          mn :: String
mn = (Identifier String -> String
toCamel forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
fromSnake) String
s
      String -> String -> Q [Dec]
mkCommand String
mn String
target

    commonPrefix :: [String] -> String
commonPrefix = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(Char
x:String
xs) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== Char
x) String
xs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {f :: * -> *} {a}. (Foldable f, Functor f) => f [a] -> [f a]
tp
      where
        tp :: f [a] -> [f a]
tp f [a]
xs
          | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall (t :: * -> *) a. Foldable t => t a -> Bool
null f [a]
xs = []
          | Bool
otherwise = (forall a. [a] -> a
head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f [a]
xs) forall a. a -> [a] -> [a]
: f [a] -> [f a]
tp (forall a. [a] -> [a]
tail forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f [a]
xs)

-- | Make commands with given names.
mkNamedCommands :: [(String, String)] -> Q [Dec]
mkNamedCommands :: [(String, String)] -> Q [Dec]
mkNamedCommands = forall b (f :: * -> *) a.
(Monoid b, Applicative f) =>
(a -> f b) -> [a] -> f b
cmapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> Q [Dec]
mkCommand)