{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Tesla.Car.Command (
Time(..), mkTime, fromTime,
runCmd, runCmd', CommandResponse, Car,
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
type CommandResponse = Either Text ()
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)
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)
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 (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 :: 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
runCmd :: (MonadIO m, Postable p) => String -> p -> Car m CommandResponse
runCmd :: String -> p -> Car m CommandResponse
runCmd String
cmd p
p = do
VehicleID
v <- Car m VehicleID
forall (m :: * -> *). MonadReader CarEnv m => m VehicleID
currentVehicleID
Value
j :: Value <- String -> p -> Car m Value
forall (m :: * -> *) j a.
(HasTeslaAuth m, FromJSON j, Postable a, MonadIO m) =>
String -> a -> m j
jpostAuth (VehicleID -> ShowS
vehicleURL VehicleID
v ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"command/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
cmd) p
p
CommandResponse -> Car m CommandResponse
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
^? VehicleID -> Traversal' Value Value
forall t. AsValue t => VehicleID -> Traversal' t Value
key VehicleID
"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
. VehicleID -> Traversal' Value Value
forall t. AsValue t => VehicleID -> Traversal' t Value
key VehicleID
"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. AsPrimitive t => Prism' t Bool
_Bool of
Just Bool
True -> () -> CommandResponse
forall a b. b -> Either a b
Right ()
Maybe Bool
_ -> VehicleID -> CommandResponse
forall a b. a -> Either a b
Left (VehicleID -> CommandResponse) -> VehicleID -> CommandResponse
forall a b. (a -> b) -> a -> b
$ Value
j Value -> Getting VehicleID Value VehicleID -> VehicleID
forall s a. s -> Getting a s a -> a
^. VehicleID -> Traversal' Value Value
forall t. AsValue t => VehicleID -> Traversal' t Value
key VehicleID
"response" ((Value -> Const VehicleID Value)
-> Value -> Const VehicleID Value)
-> Getting VehicleID Value VehicleID
-> Getting VehicleID Value VehicleID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VehicleID -> Traversal' Value Value
forall t. AsValue t => VehicleID -> Traversal' t Value
key VehicleID
"reason" ((Value -> Const VehicleID Value)
-> Value -> Const VehicleID Value)
-> Getting VehicleID Value VehicleID
-> Getting VehicleID Value VehicleID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting VehicleID Value VehicleID
forall t. AsPrimitive t => Prism' t VehicleID
_String
runCmd' :: MonadIO m => String -> Car m CommandResponse
runCmd' :: String -> Car m CommandResponse
runCmd' String
cmd = String -> ByteString -> Car m CommandResponse
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"
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 (f :: * -> *) a. Applicative f => a -> f a
pure [
Name -> Type -> Dec
SigD (String -> Name
mkName String
s) ([TyVarBndr] -> Cxt -> Type -> Type
ForallT [Name -> TyVarBndr
PlainTV Name
m] [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 :: (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)
traverse a -> f b
f [a]
xs
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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Char
forall a. [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 (t :: * -> *) a. Foldable t => t a -> Bool
null f [a]
xs = []
| Bool
otherwise = ([a] -> a
forall a. [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. [a] -> [a]
tail ([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f [a]
xs)
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)