diff options
Diffstat (limited to 'xmobar')
| -rw-r--r-- | xmobar/extras/weather/src/Main.hs | 213 |
1 files changed, 213 insertions, 0 deletions
diff --git a/xmobar/extras/weather/src/Main.hs b/xmobar/extras/weather/src/Main.hs new file mode 100644 index 0000000..aa5a408 --- /dev/null +++ b/xmobar/extras/weather/src/Main.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} + +module Main where + +import Control.Monad (when) +import Control.Monad.Writer hiding (getFirst) +import Data.Aeson +import Data.Aeson.Types (Parser) +import qualified Data.ByteString.Lazy.Char8 +import qualified Data.Char +import qualified Data.Map +import Data.Maybe (fromMaybe) +import qualified Data.Text +import GHC.Generics +import Network.Curl +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import Text.Printf (printf) + +-- Date time that easily comparable. +data SillyTime = SillyTime + { sillyTimeDate :: String, + sillyTimeAMPM :: String, + sillyTimeTime :: String + } + deriving (Ord, Eq, Show) + +data CurrentCondition = CurrentCondition + { feelsLikeF :: String, + cloudCover :: String, + humidity :: String, + tempF :: String, + weatherDesc :: String, + windspeedMiles :: String, + winddir :: String, + observationTime :: SillyTime + } + deriving (Generic, Show) + +newtype NearestArea = NearestArea + { areaName :: String + } + deriving (Generic, Show) + +data Astronomy = Astronomy + { sunrise :: SillyTime, + sunset :: SillyTime + } + deriving (Generic, Show) + +data Weather = Weather + { currentCondition :: CurrentCondition, + nearestArea :: NearestArea, + astronomy :: Astronomy + } + deriving (Generic, Show) + +getFirst :: Parser [a] -> Parser a +getFirst ls = do + l <- ls + case l of + (a : _) -> return a + [] -> fail "No current conditions" + +instance FromJSON CurrentCondition where + parseJSON = withObject "CurrentCondition" $ \v -> + CurrentCondition <$> v .: "FeelsLikeF" + <*> v .: "cloudcover" + <*> v .: "humidity" + <*> v .: "temp_F" + <*> ( withArray + "WeatherDescriptions" + ( \vs -> do + concat <$> mapM (withObject "Description" (.: "value")) vs + ) + =<< (v .: "weatherDesc") + ) + <*> v .: "windspeedMiles" + <*> v .: "winddir16Point" + <*> ( withText + "observationTime" + ( \txt -> case Data.Text.unpack <$> Data.Text.words txt of + [a, b, c] -> return (SillyTime a c b) + _ -> fail $ printf "1 Failed to parse SillyTime [%s]" (Data.Text.unpack txt) + ) + =<< (v .: "localObsDateTime") + ) + +instance FromJSON NearestArea where + parseJSON = withObject "NearestArea" $ \v -> + fmap NearestArea $ do + (areaNames :: [Object]) <- v .: "areaName" + concat <$> mapM (.: "value") areaNames + +parseAstronomy :: String -> Value -> Parser Astronomy +parseAstronomy date = withObject "Astronomy" $ \v -> + Astronomy <$> (withText "sunrise" toSillyTime =<< (v .: "sunrise")) <*> (withText "sunset" toSillyTime =<< (v .: "sunset")) + where + toSillyTime str = + case Data.Text.unpack <$> Data.Text.words str of + [a, b] -> return $ SillyTime date b a + _ -> fail $ printf "2 Failed to parse SillyTime [%s]" (Data.Text.unpack str) + +instance FromJSON Weather where + parseJSON = withObject "Weather" $ \v -> + Weather + <$> getFirst (v .: "current_condition") + <*> getFirst (v .: "nearest_area") + <*> ( withObject + "Timeline" + ( \v -> do + d <- v .: "date" + parseAstronomy d =<< getFirst (v .: "astronomy") + ) + =<< getFirst (v .: "weather") + ) + +conditionsIconDay :: Data.Map.Map String String +conditionsIconDay = + Data.Map.fromList + [ ("overcast", fc "#808080" "\63070"), + ("fair", fc "a0a0a0" "🌑"), + ("clear", fc "#ddcf04" "\58125"), + ("sunny", fc "#ddcf04" "\58125"), + ("mostly clear", fc "#00a3c4" "\57894"), + ("mostly sunny", fc "#ddcf04" "\58124"), + ("partly sunny", fc "#ddcf04" "\58124"), + ("fair", fc "#a0a0a0" "\127761"), + ("cloudy", fc "#a0a0a0" "\64143"), + ("overcast", fc "#808080" "\63070"), + ("partly cloudy", fc "#a0a0a0" "\64148"), + ("mostly cloudy", fc "#808080" "\63070"), + ("considerable cloudiness", fc "#a0a0a0" "\64381") + ] + +conditionsIconNight :: Data.Map.Map String String +conditionsIconNight = + Data.Map.fromList + [ ("clear", fc "#00a3c4" "\61830"), + ("sunny", fc "#00a3c4" "\61830"), + ("mostly clear", fc "#00a3c4" "\57894"), + ("mostly sunny", fc "#00a3c4" "\57894"), + ("partly sunny", fc "#00a3c4" "\57894"), + ("fair", fc "#808080" "\127761"), + ("cloudy", fc "#808080" "\64143"), + ("overcast", fc "#404040" "\63070"), + ("partly cloudy", fc "#a0a0a0" "\57894"), + ("mostly cloudy", fc "#808080" "\63070"), + ("considerable cloudiness", fc "#a0a0a0" "\64381") + ] + +handleWeather :: Weather -> String +handleWeather w = execWriter $ do + tell $ lightGrey $ fn 3 $ areaName (nearestArea w) + tell " " + tell $ + lightGrey $ + fn 3 $ + case winddir (currentCondition w) of + "NE" -> "\62785" + "NNE" -> "\62785" + "ENE" -> "\62785" + "SE" -> "\62810" + "SSE" -> "\62810" + "ESE" -> "\62810" + "NW" -> "\62786" + "NNW" -> "\62786" + "WNW" -> "\62786" + "SW" -> "\62811" + "SSW" -> "\62811" + "WSW" -> "\62811" + "N" -> "\62788" + "S" -> "\62812" + "W" -> "\62803" + "E" -> "\62796" + _ -> "?" + + tell " " + tell $ lightGrey $ fn 3 $ windspeedMiles (currentCondition w) ++ "mph" + tell " " + + let conditions = if isNight then conditionsIconNight else conditionsIconDay + tell $ + fn 5 $ + fromMaybe "?" $ + Data.Map.lookup (map Data.Char.toLower $ weatherDesc (currentCondition w)) conditions + + tell " " + tell $ lightGrey $ fn 3 $ printf "%s°F" (tempF $ currentCondition w) + where + isNight = + observationTime (currentCondition w) < sunrise (astronomy w) + || observationTime (currentCondition w) > sunset (astronomy w) + + lightGrey = fc "#a0a0a0" + + fn :: Int -> String -> String + fn = printf "<fn=%d>%s</fn>" + +fc :: String -> String -> String +fc = printf "<fc=%s>%s</fc>" + +main :: IO () +main = do + (code, resp) <- curlGetString "https://wttr.in?format=j2" [] + when (code /= CurlOK) exitFailure + + case eitherDecode (Data.ByteString.Lazy.Char8.pack resp) of + Left err -> hPutStrLn stderr $ printf "Failure to parse [%s]" err + Right weather -> putStrLn $ handleWeather weather |