{-# 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
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 (..), Postable)
import           Text.Casing            (fromSnake, toCamel)

import           Tesla.Car
import           Tesla.Internal.HTTP

-- | 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)

-- | 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 payload.
runCmd :: (MonadIO m, Postable p) => String -> p -> Car m CommandResponse
runCmd :: forall (m :: * -> *) p.
(MonadIO m, Postable p) =>
String -> p -> Car m CommandResponse
runCmd String
cmd p
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) p
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 = forall (m :: * -> *) p.
(MonadIO m, Postable p) =>
String -> p -> Car m CommandResponse
runCmd String
cmd ByteString
BL.empty

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)