{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# 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,
  Percent(..), mkPercent,
  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           Data.Finite                     (Finite, getFinite, modulo, packFinite)
import           Data.Text                       (Text)
import           GHC.Read
import           GHC.TypeNats
import           Language.Haskell.TH
import           Network.Wreq.Types              (FormValue (..))
import           Text.Casing                     (fromSnake, toCamel)

import           Data.Aeson.Types                (Pair)
import           Tesla.Car
import           Tesla.Internal.HTTP
import qualified Text.ParserCombinators.ReadPrec as TextParser

-- | 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) = Integer -> String
forall a. Show a => a -> String
show (Finite 1440 -> Integer
forall a. Integral a => a -> Integer
toInteger Finite 1440
t)

instance Num Time where
  fromInteger :: Integer -> Time
fromInteger = Finite 1440 -> Time
Time (Finite 1440 -> Time)
-> (Integer -> Finite 1440) -> Integer -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Finite 1440
forall (n :: Nat). KnownNat n => Integer -> Finite n
modulo
  abs :: Time -> Time
abs = Time -> Time
forall a. a -> a
id
  signum :: Time -> Time
signum = Time -> Time -> Time
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 Finite 1440 -> Finite 1440 -> Finite 1440
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 Finite 1440 -> Finite 1440 -> Finite 1440
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 Finite 1440 -> Finite 1440 -> Finite 1440
forall a. Num a => a -> a -> a
- Finite 1440
f2)

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

instance ToJSON Time where
  toJSON :: Time -> Value
toJSON (Time Finite 1440
x) = Integer -> Value
forall a. ToJSON a => a -> Value
toJSON (Finite 1440 -> Integer
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 (Finite 1440 -> Time) -> Finite 1440 -> Time
forall a b. (a -> b) -> a -> b
$ Integer -> Finite 1440
forall (n :: Nat). KnownNat n => Integer -> Finite n
modulo (Finite 24 -> Integer
forall a. Integral a => a -> Integer
toInteger Finite 24
h Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Finite 60 -> Integer
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) = (Finite 1440 -> Finite 24)
-> (Finite 1440 -> Finite 60)
-> (Finite 1440, Finite 1440)
-> (Finite 24, Finite 60)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Finite 1440 -> Finite 24
forall (m :: Nat) (n :: Nat).
(KnownNat m, KnownNat n, n <= m) =>
Finite m -> Finite n
f Finite 1440 -> Finite 60
forall (m :: Nat) (n :: Nat).
(KnownNat m, KnownNat n, n <= m) =>
Finite m -> Finite n
f (Finite 1440
t Finite 1440 -> Finite 1440 -> (Finite 1440, Finite 1440)
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 = Integer -> Finite n
forall (n :: Nat). KnownNat n => Integer -> Finite n
modulo (Integer -> Finite n)
-> (Finite m -> Integer) -> Finite m -> Finite n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Finite m -> Integer
forall a. Integral a => a -> Integer
toInteger

-- | A type representing a whole number percnetage between 0 and 100 (inclusive).
newtype Percent = Percent (Finite 101)

instance Read Percent where
    readPrec :: ReadPrec Percent
readPrec = Int -> ReadPrec Percent -> ReadPrec Percent
forall a. Int -> ReadPrec a -> ReadPrec a
TextParser.prec Int
10 (ReadPrec Percent
-> (Percent -> ReadPrec Percent)
-> Maybe Percent
-> ReadPrec Percent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReadPrec Percent
forall a. ReadPrec a
TextParser.pfail Percent -> ReadPrec Percent
forall a. a -> ReadPrec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Percent -> ReadPrec Percent)
-> (Int -> Maybe Percent) -> Int -> ReadPrec Percent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Integral n => n -> Maybe Percent
mkPercent @Int (Int -> ReadPrec Percent) -> ReadPrec Int -> ReadPrec Percent
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReadPrec Int
forall a. Read a => ReadPrec a
readPrec)

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

mkPercent :: Integral n => n -> Maybe Percent
mkPercent :: forall n. Integral n => n -> Maybe Percent
mkPercent = (Finite 101 -> Percent) -> Maybe (Finite 101) -> Maybe Percent
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Finite 101 -> Percent
Percent (Maybe (Finite 101) -> Maybe Percent)
-> (n -> Maybe (Finite 101)) -> n -> Maybe Percent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Maybe (Finite 101)
forall (n :: Nat). KnownNat n => Integer -> Maybe (Finite n)
packFinite (Integer -> Maybe (Finite 101))
-> (n -> Integer) -> n -> Maybe (Finite 101)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Integer
forall a. Integral a => a -> Integer
toInteger

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

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

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"
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [
    Name -> Type -> Dec
SigD (String -> Name
mkName String
s) ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [Name -> Specificity -> TyVarBndr Specificity
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 = [b] -> b
forall a. Monoid a => [a] -> a
mconcat ([b] -> b) -> f [b] -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 = (String -> Q [Dec]) -> [String] -> Q [Dec]
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 = Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix) String
target
          mn :: String
mn = (Identifier String -> String
toCamel (Identifier String -> String)
-> (String -> Identifier String) -> ShowS
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 = (String -> Char) -> [String] -> String
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Char
forall a. HasCallStack => [a] -> a
head ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(Char
x:String
xs) -> (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
x) String
xs) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall {f :: * -> *} {a}. (Foldable f, Functor f) => f [a] -> [f a]
tp
      where
        tp :: f [a] -> [f a]
tp f [a]
xs
          | ([a] -> Bool) -> f [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null f [a]
xs = []
          | Bool
otherwise = ([a] -> a
forall a. HasCallStack => [a] -> a
head ([a] -> a) -> f [a] -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f [a]
xs) f a -> [f a] -> [f a]
forall a. a -> [a] -> [a]
: f [a] -> [f a]
tp ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail ([a] -> [a]) -> f [a] -> f [a]
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 = ((String, String) -> Q [Dec]) -> [(String, String)] -> Q [Dec]
forall b (f :: * -> *) a.
(Monoid b, Applicative f) =>
(a -> f b) -> [a] -> f b
cmapM ((String -> String -> Q [Dec]) -> (String, String) -> Q [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> Q [Dec]
mkCommand)