diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -[![Build Status](https://travis-ci.org/hce/avutils.svg?branch=master)](https://travis-ci.org/hce/avutils) +[![Build Status](https://travis-ci.org/hce/avwx.svg?branch=master)](https://travis-ci.org/hce/avwx) avwx ==== @@ -48,5 +48,6 @@ , dewPoint = Just 15 , trend = NOSIG , remark = Nothing + , maintenance = False } ... diff --git a/avwx.cabal b/avwx.cabal --- a/avwx.cabal +++ b/avwx.cabal @@ -1,5 +1,5 @@ name: avwx -version: 0.1.0.1 +version: 0.2.0.0 synopsis: Parse METAR weather reports description: Parse METAR weather reports homepage: https://github.com/hce/avwx @@ -17,12 +17,16 @@ hs-source-dirs: src exposed-modules: Data.Aviation.WX , Data.Aviation.WX.Fetcher - -- other-modules: Data.Aviation.WX.Fetcher + build-depends: base >= 4.7 && < 5 - , attoparsec - , HTTP + , lens >= 4.1 && < 5 + , attoparsec >= 0.13 && < 1 + , parsers >= 0.12 && < 1 + , HTTP >= 4000 && < 5000 , text >= 1.2.2.1 && < 1.3 + default-language: Haskell2010 + ghc-options: -Wall executable metar hs-source-dirs: app @@ -38,6 +42,7 @@ hs-source-dirs: test main-is: Spec.hs build-depends: base + , attoparsec >= 0.13 && < 1 , avwx , text ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,16 @@ +# 0.2.0.0 + +Many improvements by Tony Morris: + +* Turn on GHC warnings +* The parser uses hackage/parsers library, so a user can choose the parser implementation e.g. attoparsec, parsec. +* A METAR optionally ends in $ or = instead of necessarily. +* Added a field to `Weather` for ending in $ (meaning the station requires maintenance). +* Added classy lenses to the data types. +* Updated the new noaa.gov METAR publication website for fetching. +* Moved parseWeather over to the `Fetcher` module so the parser does not ever import attoparsec. +* Make `Station` a newtype. + # Jun 28 2016 -First release. +* First release. diff --git a/src/Data/Aviation/WX.hs b/src/Data/Aviation/WX.hs --- a/src/Data/Aviation/WX.hs +++ b/src/Data/Aviation/WX.hs @@ -1,878 +1,1001 @@ -{-# LANGUAGE OverloadedStrings #-} --- | --- Module: Data.Aviation.WX --- Copyright: (C) 2014-2016, Hans-Christian Esperer --- License: MIT --- Maintainer: Hans-Christian Esperer --- Stability: experimental --- Portability: portable --- --- Parse aviation weather reports. A qualified import is recommended. -module Data.Aviation.WX - ( parseWeather - , weatherParser - , Weather(..) - , Date(..) - , Station(..) - , Flag(..) - , Wind(..) - , Visibility(..) - , Runway(..) - , VisTrend(..) - , RunwayCondition(..) - , WeatherPhenomenon(..) - , Cloud(..) - , Pressure(..) - , Trend(..) - , WPDesc(..) - , WPPrecipitation(..) - , WPObfuscation(..) - , WPOther(..) - , Distance(..) - , Direction(..) - , RwyCoverType(..) - , RunwayBraking(..) - , Vertical(..) - , WindDirection(..) - , Cover(..) - , CloudType(..) - , WPIntensity(..) - , Transition(..) - , Unit(..) - ) where - -import Control.Applicative -import Control.Monad -import Data.Attoparsec.Text -import Data.Maybe -import Data.Text (Text, pack) - --- | Aviation weather, currently only METARs are supported. -data Weather - = -- | A METeorological Aerodrome Report - METAR - { -- | The observation date. - date :: Date - , -- | The designation of the observing station. - station :: Station - , -- | A remark about the reported observation. - flags :: [Flag] - , -- | The observed wind. - wind :: Maybe Wind - , -- | The observed visibility. - visibility :: [Visibility] - , -- | The observed visibility for specific runways, - -- usually reported if the runway visibility significantly - -- differs from the general reported visibility. - runwayvis :: [(Runway, [Visibility], Maybe VisTrend)] - , -- | Surface or close conditions of a specific runway. - runwaycond :: [RunwayCondition] - , -- | Observed weather phenomena - wx :: [WeatherPhenomenon] - , -- | Observed cloud layers - clouds :: [Cloud] - , -- | Measured pressure - pressure :: Maybe Pressure - , -- | Measured pressure - temperature :: Maybe Int - , -- | Determined dew point - dewPoint :: Maybe Int - , -- | Expected changes within the next two hours - trend :: Trend - , -- | RMK section (Additional parts of a METAR report that are not - -- part of the official METAR message but are commonly used - -- in various parts of the world; unparsed) - remark :: Maybe Text } - | -- | An automatic terminal information service report - ATIS - | -- | A non-scheduled METAR - SPECI - | -- | A terminal aerodrome forecast - TAF - | -- | An aviation wx hazard message of moderate severity - AIRMET - | -- | A significant meteorological information message - SIGMET - | -- | A general aviation forecast message - GAMET - deriving (Eq, Show) - --- | A flag describing an aviation meteorological report -data Flag - = -- | A message has been corrected after the beginning of - -- its original validity period - COR - | -- | A message has been corrected prior to its - -- original validity period - AMD - | -- | A message has been generated fully automatic - -- without a plausibility check by a human - AUTO - deriving (Eq, Show) - --- | The trend part of a METAR message specifies expected --- changes in weather conditions within the next two hours. --- A Trend/Transition part of a TAF message specified expected --- changes in weather conditions within the specified range. -data Trend - = -- | A transition that will start within the defined - -- time frame and be completed at the end of the defined - -- time frame - BECMG [Transition] - | -- | A transition that will start within the defined - -- time frame and be finished at the end of the defined - -- time frame - TEMPO [Transition] - | -- | A probability specification. - -- As one of my FIs (ex-atc at EDDF) used to put it: - -- 30% means "I'm quite sure it won't happen but will still - -- put it in here, in case it does after all." - -- 40% means "I'm certain it will happen but will still - -- put it with 40%, in case it does not happen after all." - PROB Int Trend - | -- | NOSIG is only applicable to METARs. It means that - -- no significant changes are expected within the next - -- two hours. - NOSIG - | -- | NOTAVAIL is only applicable to METARs. It means that - -- the METAR message in question does not contain a TREND - -- section. - NOTAVAIL - deriving (Eq, Show) - --- | A transition in weather conditions. --- A transition can either be temporary or permanent; --- this will be encoded in the container structure. -data Transition - = -- | A change of wind strength or direction - TransWind Wind - | -- | A change of visibility - TransVis [Visibility] - | -- | A change of visibility for a specific runway - TransRunwayVis [(Runway, [Visibility], Maybe VisTrend)] - | -- | A change of weather phenomenon - TransWX [WeatherPhenomenon] - | -- | A change of ceiling or cloud layers - TransClouds [Cloud] - deriving (Eq, Show) - --- | A visibility trend specifically for runway conditions -data VisTrend - = -- | Visibility will improve (maybe do wait a bit) - VisTrendUpward - | -- | Visibility will deteriorate (still, don't rush - -- the take off and use proper phraseology at all times) - VisTrendDownward - | -- | No expected change in runway visibility conditions - VisTrendNoDistinctTendency - deriving (Eq, Show) - --- | A pressure value. This is intentionally coded --- individually and not converted to a specific reference. -data Pressure - = -- | The QNH value in hectopascals. QNH is the current - -- pressure at sea level, corrected for pressure and - -- temperature changes at the station level. - QNH Int - | -- | The same as QNH, only in inches - -- (Do you know the old joke?: - -- * ATC: Liner 1723 descend to 3,000ft, the QNH is 1013mb. - -- * Liner 1723: Uh, approach, can we have that in inches please? - -- * ATC: Liner 1723 descend to 36,000 inches, the QNH is 1013mb. - Altimeter Int - | -- | The current pressure at station level in hectopascals. - QFE Int - | -- | The current pressure at sea level in hectopascals. - QFF Int - deriving (Eq, Show) - --- | A weather phenomenon. --- This can be an observed phenomenon in the case of METARs or an --- expected phenomenon in the case of TAFs. -data WeatherPhenomenon - = Phenomenon - { -- | The intensity of the phenomenon. - intensity :: WPIntensity - , -- | The description of the weather phenomenon. - desc :: Maybe WPDesc - , -- | The precipitation type of the weather phenomenon. - prec :: Maybe WPPrecipitation - , -- | The effects of the phenomenon on the visibility - obfus :: Maybe WPObfuscation - , -- | Other details about the phenomenon. - other :: Maybe WPOther } - deriving (Eq, Show) - --- | The intensity of an observed or expected weather phenomenon. -data WPIntensity - = -- | Light - Light - | -- | Moderate - Moderate - | -- | Heavy - Heavy - | -- | Only applicable to METARs. The weather phenomenon was - -- observed in the vicinity of the observed area, not within - -- the observed area itself. - Vicinity - | -- | Only applicable to METARs. The weather phenomenon was - -- recently observed in the past, but was not observed at - -- the time the report was issued. - Recent - deriving (Enum, Eq, Show) - --- | The description of a weather phenomenon. -data WPDesc - = -- | Shallow. - Shallow - | -- | Patches. - Patches - | -- | Partial. - WXPartial - | -- | Low, drifting. - LowDrifting - | -- | Blowing. - Blowing - | -- | Shower. - Shower - | -- | Thunderstorm. - Thunderstorm - | -- | Freezing. - Freezing - deriving (Enum, Eq, Ord, Show) - --- | The type of the precipitation -data WPPrecipitation - = -- | Drizzle. - Drizzle - | -- | Rain. - Rain - | -- | Snow. - Snow - | -- | Snow grains. - ShowGrains - | -- | Ice crystals. - IceCrystals - | -- | Ice pellets. - IcePellets - | -- | Hail. - Hail - | -- | Snow pellets. - SnowPellets - | -- | Unknown type of precipitation. - UnknownPrecipitation - deriving (Enum, Eq, Ord, Show) - --- | Effects on the visibility by a weather phenomenon -data WPObfuscation - = -- | Mist. Visibility impaired but still greater than 1000m - Mist - | -- | Fog. Visibility less than 1000m. - Fog - | -- | Smoke. - Smoke - | -- | Volcanic ash. - VolcanicAsh - | -- | Dust. - Dust - | -- | Sand. - Sand - | -- | Haze. - Haze - deriving (Enum, Eq, Ord, Show) - --- | Other important information about a weather phenomenon. -data WPOther - = -- | Dust or sand whirls. - DustOrSandwhirls - | -- | Squalls. - Squalls - | -- | Tornado. - Tornado - | -- | Sand storm. - Sandstorm - | -- | Dust storm. - Duststorm - deriving (Enum, Eq, Ord, Show) - --- | The Distance. -data Distance - = -- | The distance in metres. - Metres Int - | -- | The distance in km. - KM Int - | -- | The distance in statute miles. - SM Int - | -- | The distance in nautical miles. - NM Int - deriving (Eq, Show) - --- | Vertical visibility. -data Visibility - = -- | Ten kilometres or more. - TenOrMore - | -- | Fifty metres or less. - FiftyMetresOrLess - | -- | Two kilometres or more. - TwoOrMore - | -- | A specific visibility. - Visibility Distance (Maybe Direction) - deriving (Eq, Show) - --- | Directions. -data Direction - = -- | North. - North - | -- | South. - South - | -- | East. - East - | -- | West. - West - | -- | Northwest. - NorthWest - | -- | Northeast. - NorthEast - | -- | Southwest. - SouthWest - | -- | Southeast. - SouthEast - | -- | Left runway for runways of the same QFU - -- (part of the runway designator) - RWYLeft - | -- | Right runway for runways of the same QFU - -- (part of the runway designator) - RWYRight - | -- | Centre runway for runways of the same QFU - -- (part of the runway designator) - RWYCenter - deriving (Eq, Show) - --- | Runway specification. -data Runway - = -- | All runways. - AllRunways - | -- | A specific runway. - Runway - { -- | The runway's magnetic orientation, divided by ten and rounded. - runwayQFU :: Int - , -- | For multiple runways with the same QFU, a left, right or centre - -- selector is added. - runwayDirection :: Maybe Direction } - deriving (Eq, Show) - --- | The runway contamination type. -data RwyCoverType - = -- | The runway is not contaminated. - RCTDry - | -- | The runway is moist. - RCTMoist - | -- | The runway is wet. - RCTWet - | -- | The runway is convered with rime. - RCTRime - | -- | The runway is covered with dry snow. - RCTDrySnow - | -- | The runway is covered with wet snow. - RCTWetSnow - | -- | The runway is covered with slush. - RCTSlush - | -- | The runway is covered with ice. - RCTIce - | -- | The runway is covered with frozen ruts or ridges. - RCTFZRut - | -- | The runway contamination type is unknown. - RCTUnknown - deriving (Eq, Show, Enum) - --- | Runway conditions. -data RunwayCondition - = -- | Specific runway conditions exist. - RunwayCondition - { -- | The runway for which specific conditions - -- have been observed. - rwcondRunway :: Runway - , -- | Whether and how the runway is contamindated. - rwcondCover :: RwyCoverType - , -- | The extent of the contamination in percent. - rwcondSpread :: Maybe Int - , -- | The height of the contamination in millimetres. - rwcondCoverHeight :: Maybe Int - , -- | The friction coefficient or braking action value. - rwcondBrkCoeff :: RunwayBraking } - | -- | The runway is closed. - RwyClosed - { -- | The runway that is closed. - rwclosedRunway :: Runway } - | -- | The whole aerodrome is closed. - ADClosed - deriving (Eq, Show) - --- | The measured brake efficiency of a specific runway. -data RunwayBraking - = -- | The friction coefficient. - BrakingFriction Int - | -- | The braking coefficient. - BrakingEffect Int - deriving (Eq, Show) - --- | An obersvation date. -data Date - = Date Int Int Int - deriving (Eq, Show) - --- | An aeronautical weather station designator. -data Station - = -- | The station as identified by its aerodrome's - -- ICAO code. - ICAO Text - deriving (Eq, Show) - --- | A vertical position specification. -data Vertical - = -- | A vertical position with reference to the ground - -- in feet. - Height Int - | -- | A vertical position with reference to the mean - -- sea level/QNH in feet. - Altitude Int - | -- | A pressure altitude with reference to the - -- standard QNH of 1013 hectopascals in hundrets of feet. - FlightLevel Int - | -- | Vertical position is not specified. - VertNotSpec - deriving (Eq, Show) - --- | Wind information. -data Wind - = Wind - { -- | The direction the wind is blowing from. - direction :: WindDirection - , -- | The wind speed. - velocity :: Unit - , -- | The strength of the observed gusts, if any. - gusts :: Maybe Int - } deriving (Eq, Show) - --- | The direction the wind is blowing from. -data WindDirection - = -- | The wind is blowing in equal or almost equal - -- strength from a wide variety of directions. - Variable - | -- | The wind is blowing from the specified direction. - -- Directions can be given with reference to true or - -- magnetic north, depending on the type of weather - -- observation/forecast message. - Degrees Int - | -- | The wind is blowing from a specific direction - -- range. - Varying - { -- | The mean direction the wind is blowing from. - mean :: Int - , -- | The minimum direction the wind is blowing from. - from :: Int - , -- | The maximum direction the wind is blowing from. - to :: Int - } deriving (Eq, Show) - - --- | A speed unit. -data Unit - = -- | Nautical miles per hour - Knots Int - | -- | Statute miles per hour - Miles Int - | -- | Kilometres per hour - KMH Int - deriving (Eq, Show) - --- | A cloud specification. -data Cloud - = -- | No specific clouds could be observed, because - -- the (given) ground visibility was too low or because - -- the ground is covered in clouds. - VVis (Maybe Int) - | -- | Clouds were observed. - Cloud Cover Vertical CloudType - deriving (Eq, Show) - --- | The type of cloud. -data CloudType - = -- | A cumulonimbus cloud. - Cumulonimbus - | -- | A developing cb cloud. - ToweringCumulus - | -- | A stratus cloud. - Stratus - | -- | A cumulus cloud. - Cumulus - | -- | A stratocumulus cloud. - Stratocumulus - | -- | An altostratus cloud. - Altostratus - | -- | An altocumulus cloud. - Altocumulus - | -- | A cirrostratus cloud. - Cirrostratus - | -- | A cirrus cloud. - Cirrus - | -- | An unclassified cloud. - Unclassified - deriving (Enum, Eq, Show) - --- | The area that is covered. -data Cover - = -- | 1-2 eights are covered. - FEW - | -- | 3-4 eights are covered. - SCT - | -- | 5-7 eights are covered. - BKN - | -- | More than 7 eights are covered. - OVC - | -- | Cover not specified - CoverNotSpecified - deriving (Enum, Eq, Ord, Show) - -stationParser :: Parser Station -stationParser = ICAO <$> Data.Attoparsec.Text.take 4 - -dateParser :: Parser Date -dateParser = Date <$> twin <*> twin <*> (twin <* "Z") - where twin = (\a b -> read [a, b]) <$> digit <*> digit - -variableWindParser :: WindDirection -> Parser WindDirection -variableWindParser (Degrees meanWind) = try $ do - dir1 <- (\a b c -> read [a, b, c]) <$> digit <*> digit <*> digit - _ <- char 'V' - dir2 <- (\a b c -> read [a, b, c]) <$> digit <*> digit <*> digit - return $ Varying meanWind dir1 dir2 -variableWindParser _ = fail "Erroneous parameters" - -windParser :: Parser Wind -windParser = do - dir <- choice [readwinddir, variablewind] - str <- readwindstr - gustsies <- option Nothing readgusts - unit <- readunit - dir2 <- option dir $ char ' ' >> variableWindParser dir - return $ Wind dir2 (unit str) gustsies - where - variablewind = "VRB" `means` Variable - readwinddir = (\a b c -> Degrees . read $ [a, b, c]) <$> digit <*> digit <*> digit - readwindstr = (\a b -> read [a, b]) <$> digit <*> digit - readunit = choice [ "KT" `means` Knots - , "MPH" `means` Miles - , "KM" `means` KMH] - readgusts = (\_ b c -> Just . read $ [b, c]) <$> char 'G' <*> digit <*> digit - -pressureParser :: Parser Pressure -pressureParser = choice [qnh, mmhg] - where - qnh = (\_ a b c d -> QNH $ read [a, b, c, d]) <$> char 'Q' <*> digit <*> digit <*> digit <*> digit - mmhg = (\_ a b c d -> Altimeter $ read [a, b, c, d]) <$> char 'A' <*> digit <*> digit <*> digit <*> digit - -wxParser :: Parser WeatherPhenomenon -wxParser = do - skipSpace - intsy <- intensityParser - dsc <- perhaps descParser - prc <- perhaps precipitationParser - obfs <- perhaps obfuscationParser - othr <- perhaps otherParser - when ( (== 0) . Prelude.length . Prelude.filter not $ - [ isNothing dsc, isNothing prc - , isNothing obfs, isNothing othr ] ) $ fail "" - return $ Phenomenon intsy dsc prc obfs othr - -perhaps :: Parser a -> Parser (Maybe a) -perhaps parser = option Nothing $ Just <$> parser - -perhaps_ :: Parser a -> Parser () -perhaps_ parser = void $ perhaps parser - -callsfor :: Text -> Parser a -> Parser a -a `callsfor` b = string a >> b - -means :: Text -> a -> Parser a -a `means` b = string a >> return b - -means' :: Text -> a -> Parser a -a `means'` b = try $ skipSpace >> string a >> skipSpace >> return b - -descParser :: Parser WPDesc -descParser = choice - [ "MI" `means` Shallow - , "BC" `means` Patches - , "PR" `means` WXPartial - , "DR" `means` LowDrifting - , "BL" `means` Blowing - , "SH" `means` Shower - , "TS" `means` Thunderstorm - , "FZ" `means` Freezing ] - -precipitationParser :: Parser WPPrecipitation -precipitationParser = choice - [ "DZ" `means` Drizzle - , "RA" `means` Rain - , "SN" `means` Snow - , "SG" `means` ShowGrains - , "IC" `means` IceCrystals - , "PL" `means` IcePellets - , "GR" `means` Hail - , "GS" `means` SnowPellets - , "UP" `means` UnknownPrecipitation ] - -obfuscationParser :: Parser WPObfuscation -obfuscationParser = choice - [ "BR" `means` Mist - , "FG" `means` Fog - , "FU" `means` Smoke - , "VA" `means` VolcanicAsh - , "DU" `means` Dust - , "SA" `means` Sand - , "HZ" `means` Haze ] - -otherParser :: Parser WPOther -otherParser = choice - [ "PO" `means` DustOrSandwhirls - , "SQ" `means` Squalls - , "FC" `means` Tornado - , "SS" `means` Sandstorm - , "DS" `means` Duststorm ] - -intensityParser :: Parser WPIntensity -intensityParser = option Moderate $ choice - [ char '-' >> return Light - , char '+' >> return Heavy - , "VC" `means` Vicinity - , "RE" `means` Recent ] - -visibilityParser :: Parser Visibility -visibilityParser = skipSpace >> choice [ tenormore, arb, arb1, metres ] - where - tenormore = string "9999" >> return TenOrMore - metres = (\a b c d dir -> Visibility (visunit $ read [a,b,c,d]) dir) <$> digit <*> digit <*> digit <*> digit <*> directionParser - visunit :: Int -> Distance - visunit n = if n > 5000 - then KM (n `quot` 1000) - else Metres n - arb = (\a b unit -> Visibility (unit $ read [a,b])) <$> digit <*> digit <*> distanceUnitParser <*> directionParser - arb1 = (\a unit -> Visibility (unit $ read ['0', a])) <$> digit <*> distanceUnitParser <*> directionParser - -directionParser :: Parser (Maybe Direction) -directionParser = Nothing `option` (Just <$> choice - [ "NE" `means` NorthEast, "NW" `means` NorthWest - , "SE" `means` SouthEast, "SW" `means` SouthWest - , "N" `means` North, "S" `means` South - , "E" `means` East, "W" `means` West ]) - -distanceUnitParser :: Parser (Int -> Distance) -distanceUnitParser = choice - [ "KM" `means` KM - , "SM" `means` SM - , "NM" `means` NM ] - -cloudParser :: Parser [Cloud] -cloudParser = choice [(:[]) <$> vvisParser, nsc, cavok, clr, sepBy1' clds (char ' ')] - where - clds = do - perhaps_ space - intsy <- cloudIntensityParser - height <- choice - [ "///" `means` VertNotSpec - , (\a b c -> Height $ (* 100) $ read [a, b, c]) <$> digit <*> digit <*> digit ] - - cloudType <- cloudTypeParser - return $ Cloud intsy height cloudType - cavok = skipSpace >> "CAVOK" `means` [] - nsc = skipSpace >> "NSC" `means` [] - clr = skipSpace >> "CLR" `means` [] - -vvisParser :: Parser Cloud -vvisParser = do - _ <- string "VV" - choice - [ "///" `means` VVis Nothing - , (\a b c -> VVis . Just . read $ [a,b,c]) <$> digit <*> digit <*> digit ] - -cloudIntensityParser :: Parser Cover -cloudIntensityParser = choice - [ "FEW" `means` FEW - , "SCT" `means` SCT - , "BKN" `means` BKN - , "OVC" `means` OVC - , "///" `means` CoverNotSpecified ] - -cloudTypeParser :: Parser CloudType -cloudTypeParser = option Unclassified $ choice - [ "CB" `means` Cumulonimbus - , "TCU" `means` ToweringCumulus - , "ST" `means` Stratus - , "CU" `means` Cumulus - , "SC" `means` Stratocumulus - , "AS" `means` Altostratus - , "AC" `means` Altocumulus - , "CS" `means` Cirrostratus - , "CI" `means` Cirrus - , "///" `means` Unclassified] - -perhapsMinus :: Parser String -perhapsMinus = "" `option` (char 'M' >> return "-") - -tdParser :: Parser (Int, Int) -tdParser = do - tmpr <- (\pm a b -> read (pm ++ [a, b]) :: Int) <$> perhapsMinus <*> digit <*> digit - _ <- char '/' - dewpoint <- (\pm a b -> read (pm ++ [a, b]) :: Int) <$> perhapsMinus <*> digit <*> digit - return (tmpr, dewpoint) - -flagsParser :: Parser [Flag] -flagsParser = many' $ choice - [ "COR" `means'` COR - , "AMD" `means'` AMD - , "AUTO" `means'` AUTO ] - -runwayvisParser :: Parser (Runway, [Visibility], Maybe VisTrend) -runwayvisParser = do - runway <- runwayDesignationParser - _ <- char '/' - vis <- parseRwyVis - vistrend <- Nothing `option` (Just <$> choice - [ "D" `means` VisTrendDownward - , "N" `means` VisTrendNoDistinctTendency - , "U" `means` VisTrendUpward ] ) - return (runway, vis, vistrend) - where - parseRwyVis :: Parser [Visibility] - parseRwyVis = do - worstvis <- Nothing `option` (Just <$> choice visspec <* "V") - vis <- Just <$> choice visspec - return $ catMaybes [worstvis, vis] - - visspec = - [ "M0050" `means` FiftyMetresOrLess - , "P2000" `means` TwoOrMore - , fourDigits >>= \a -> return $ Visibility (Metres a) Nothing - , trieDigits >>= \a -> return $ Visibility (Metres a) Nothing ] - -runwayconditionParser :: Parser RunwayCondition -runwayconditionParser = do - runway <- runwayDesignationParser - _ <- char '/' - choice - [ "SNOCLO" `means` ADClosed - , rwycond runway ] - - where - rwycond runway = do - cover <- RCTUnknown `option` ((toEnum . read . (:[])) <$> digit) - spread <- choice - [ char '/' >> return Nothing - , (Just . read . (:[])) <$> digit ] - spreadheight <- choice - [ string "//" >> return Nothing - , Just <$> tuhDigits ] - rkorbw <- tuhDigits - let coff = if rkorbw <= 90 - then BrakingFriction rkorbw - else BrakingEffect rkorbw - return $ RunwayCondition runway cover spread spreadheight coff - -fourDigits :: Parser Int -fourDigits = (\a b c d -> read [a,b,c,d]) <$> digit <*> digit <*> digit <*> digit - -trieDigits :: Parser Int -trieDigits = (\a b c -> read [a,b,c]) <$> digit <*> digit <*> digit - -tuhDigits :: Parser Int -tuhDigits = (\a b -> read [a,b]) <$> digit <*> digit - -runwayDesignationParser :: Parser Runway -runwayDesignationParser = choice ["R88" `means` AllRunways, oneRunway] - where - oneRunway = do - _ <- char 'R' - magheading <- (\a b -> read [a,b]) <$> digit <*> digit :: Parser Int - dir <- Nothing `option` (Just <$> choice - [ "L" `means` RWYLeft - , "R" `means` RWYRight - , "C" `means` RWYCenter ]) - return $ Runway magheading dir - -trendParser :: Parser Trend -trendParser = choice - [ "NOSIG" `means` NOSIG - , changeParser ] - where - changeParser :: Parser Trend - changeParser = do - changes <- changesParser :: Parser [Trend] - when (length changes /= 1) $ fail "A METAR contains exactly one transition" - return $ head changes - -changesParser :: Parser [Trend] -changesParser = many1 $ skipSpace >> transitionTypeParser - where - transitionTypeParser :: Parser Trend - transitionTypeParser = choice - [ "TEMPO" `callsfor` (TEMPO <$> transitionParser) - , "BECMG" `callsfor` (BECMG <$> transitionParser) - , "PROB" `callsfor` (PROB <$> twoDigits <*> (head <$> changesParser)) ] - transitionParser :: Parser [Transition] - transitionParser = sepBy1' oneTransition (char ' ') - oneTransition = do - skipSpace - choice . map try $ - [ TransClouds <$> cloudParser - , TransWind <$> windParser - , TransVis <$> many1' visibilityParser - , TransWX <$> count 1 wxParser - , TransRunwayVis <$> sepBy' runwayvisParser (char ' ') ] - -twoDigits :: Parser Int -twoDigits = (\a b -> read [a,b]) <$> digit <*> digit - -metarParser :: Parser Weather -metarParser = do - _ <- string "METAR" - reportflags <- flagsParser - identifier <- skipSpace >> stationParser - reportdate <- skipSpace >> dateParser - reportflags2 <- flagsParser - reportwind <- Nothing `option` (skipSpace >> Just <$> windParser) - skipSpace - reportvis <- [TenOrMore] `option` many1 visibilityParser - skipSpace - reportrunwaycond <- sepBy' runwayconditionParser (char ' ') - reportrunwayvis <- sepBy' runwayvisParser (char ' ') - reportwx <- many' wxParser - reportclouds <- [] `option` (skipSpace >> cloudParser) - (reporttemp, reportdewpoint) <- (Nothing, Nothing) `option` (skipSpace >> tdParser >>= \(w,d) -> return (Just w, Just d)) - reportpressure <- Nothing `option` (skipSpace >> Just <$> pressureParser) - void $ many' $ skipSpace >> pressureParser -- Sometimes, multiple pressure values are offered - skipSpace - reporttrend <- NOTAVAIL `option` trendParser - reportrmk <- maybeRMK - skipSpace - _ <- choice $ map char "=$" - return $ METAR reportdate identifier (reportflags ++ reportflags2) - reportwind reportvis reportrunwayvis reportrunwaycond reportwx - reportclouds reportpressure reporttemp reportdewpoint - reporttrend reportrmk - -maybeRMK :: Parser (Maybe Text) -maybeRMK = Nothing `option` do - void $ choice [ string "RMK ", string " RMK " ] - Just . pack <$> many1 (satisfy (notInClass "$=")) - --- | An attoparsec parser that can parse METAR messages. -weatherParser :: Parser Weather -weatherParser = metarParser - -maybeOneSpace :: Parser () -maybeOneSpace = perhaps_ space - --- | Parse the given METAR text. -parseWeather :: Text -> Either String Weather -parseWeather = parseOnly weatherParser +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module: Data.Aviation.WX +-- Copyright: (C) 2014-2016, Hans-Christian Esperer +-- License: MIT +-- Maintainer: Hans-Christian Esperer +-- Stability: experimental +-- Portability: portable +-- +-- Parse aviation weather reports. A qualified import is recommended. +module Data.Aviation.WX( + weatherParser + , Weather(..) + , HasWeather(..) + , AsWeather(..) + , Date(..) + , HasDate(..) + , Station(..) + , Flag(..) + , HasFlag(..) + , AsFlag(..) + , Wind(..) + , HasWind(..) + , Visibility(..) + , HasVisibility(..) + , AsVisibility(..) + , Runway(..) + , HasRunway(..) + , AsRunway(..) + , VisTrend(..) + , HasVisTrend(..) + , AsVisTrend(..) + , RunwayCondition(..) + , HasRunwayCondition(..) + , AsRunwayCondition(..) + , WeatherPhenomenon(..) + , HasWeatherPhenomenon(..) + , Cloud(..) + , HasCloud(..) + , AsCloud(..) + , Pressure(..) + , HasPressure(..) + , AsPressure(..) + , Trend(..) + , HasTrend(..) + , AsTrend(..) + , WPDesc(..) + , HasWPDesc(..) + , AsWPDesc(..) + , WPPrecipitation(..) + , HasWPPrecipitation(..) + , AsWPPrecipitation(..) + , WPObfuscation(..) + , HasWPObfuscation(..) + , AsWPObfuscation(..) + , WPOther(..) + , HasWPOther(..) + , AsWPOther(..) + , Distance(..) + , HasDistance(..) + , AsDistance(..) + , Direction(..) + , HasDirection(..) + , AsDirection(..) + , RwyCoverType(..) + , HasRwyCoverType(..) + , AsRwyCoverType(..) + , RunwayBraking(..) + , HasRunwayBraking(..) + , AsRunwayBraking(..) + , Vertical(..) + , HasVertical(..) + , AsVertical(..) + , WindDirection(..) + , HasWindDirection(..) + , AsWindDirection(..) + , Cover(..) + , HasCover(..) + , AsCover(..) + , CloudType(..) + , HasCloudType(..) + , AsCloudType(..) + , WPIntensity(..) + , HasWPIntensity(..) + , AsWPIntensity(..) + , Transition(..) + , HasTransition(..) + , AsTransition(..) + , Unit(..) + , HasUnit(..) + , AsUnit(..) + ) where + +import Control.Applicative(Alternative((<|>), some, many), optional) +import Control.Lens(makeClassy, makeClassyPrisms, makeWrapped) +import Control.Monad(when, void) +import Data.Maybe(isNothing, catMaybes) +import Data.Text(Text, pack) +import Text.Parser.Char(CharParsing, space, spaces, char, satisfy, text, digit, anyChar) +import Text.Parser.Combinators(try, option, choice, sepBy, sepBy1, count) + +takeChars :: + CharParsing f => + Int + -> f Text +takeChars n = + pack <$> count n anyChar + +-- | Aviation weather, currently only METARs are supported. +data Weather + = -- | A METeorological Aerodrome Report + METAR + { -- | The observation date. + _metardate :: Date + , -- | The designation of the observing station. + _station :: Station + , -- | A remark about the reported observation. + _flags :: [Flag] + , -- | The observed wind. + _metarwind :: Maybe Wind + , -- | The observed visibility. + _metarvisibility :: [Visibility] + , -- | The observed visibility for specific runways, + -- usually reported if the runway visibility significantly + -- differs from the general reported visibility. + _runwayvis :: [(Runway, [Visibility], Maybe VisTrend)] + , -- | Surface or close conditions of a specific runway. + _runwaycond :: [RunwayCondition] + , -- | Observed weather phenomena + _wx :: [WeatherPhenomenon] + , -- | Observed cloud layers + _clouds :: [Cloud] + , -- | Measured pressure + _metarpressure :: Maybe Pressure + , -- | Measured pressure + _temperature :: Maybe Int + , -- | Determined dew point + _dewPoint :: Maybe Int + , -- | Expected changes within the next two hours + _weathertrend :: Trend + , -- | RMK section (Additional parts of a METAR report that are not + -- part of the official METAR message but are commonly used + -- in various parts of the world; unparsed) + _remark :: Maybe Text + , -- + _maintenance :: Bool } + | -- | An automatic terminal information service report + ATIS + | -- | A non-scheduled METAR + SPECI + | -- | A terminal aerodrome forecast + TAF + | -- | An aviation wx hazard message of moderate severity + AIRMET + | -- | A significant meteorological information message + SIGMET + | -- | A general aviation forecast message + GAMET + deriving (Eq, Show) + +-- | A flag describing an aviation meteorological report +data Flag + = -- | A message has been corrected after the beginning of + -- its original validity period + COR + | -- | A message has been corrected prior to its + -- original validity period + AMD + | -- | A message has been generated fully automatic + -- without a plausibility check by a human + AUTO + deriving (Eq, Show) + +-- | The trend part of a METAR message specifies expected +-- changes in weather conditions within the next two hours. +-- A Trend/Transition part of a TAF message specified expected +-- changes in weather conditions within the specified range. +data Trend + = -- | A transition that will start within the defined + -- time frame and be completed at the end of the defined + -- time frame + BECMG [Transition] + | -- | A transition that will start within the defined + -- time frame and be finished at the end of the defined + -- time frame + TEMPO [Transition] + | -- | A probability specification. + -- As one of my FIs (ex-atc at EDDF) used to put it: + -- 30% means "I'm quite sure it won't happen but will still + -- put it in here, in case it does after all." + -- 40% means "I'm certain it will happen but will still + -- put it with 40%, in case it does not happen after all." + PROB Int Trend + | -- | NOSIG is only applicable to METARs. It means that + -- no significant changes are expected within the next + -- two hours. + NOSIG + | -- | NOTAVAIL is only applicable to METARs. It means that + -- the METAR message in question does not contain a TREND + -- section. + NOTAVAIL + deriving (Eq, Show) + +-- | A transition in weather conditions. +-- A transition can either be temporary or permanent; +-- this will be encoded in the container structure. +data Transition + = -- | A change of wind strength or direction + TransWind Wind + | -- | A change of visibility + TransVis [Visibility] + | -- | A change of visibility for a specific runway + TransRunwayVis [(Runway, [Visibility], Maybe VisTrend)] + | -- | A change of weather phenomenon + TransWX [WeatherPhenomenon] + | -- | A change of ceiling or cloud layers + TransClouds [Cloud] + deriving (Eq, Show) + +-- | A visibility trend specifically for runway conditions +data VisTrend + = -- | Visibility will improve (maybe do wait a bit) + VisTrendUpward + | -- | Visibility will deteriorate (still, don't rush + -- the take off and use proper phraseology at all times) + VisTrendDownward + | -- | No expected change in runway visibility conditions + VisTrendNoDistinctTendency + deriving (Eq, Show) + +-- | A pressure value. This is intentionally coded +-- individually and not converted to a specific reference. +data Pressure + = -- | The QNH value in hectopascals. QNH is the current + -- pressure at sea level, corrected for pressure and + -- temperature changes at the station level. + QNH Int + | -- | The same as QNH, only in inches + -- (Do you know the old joke?: + -- * ATC: Liner 1723 descend to 3,000ft, the QNH is 1013mb. + -- * Liner 1723: Uh, approach, can we have that in inches please? + -- * ATC: Liner 1723 descend to 36,000 inches, the QNH is 1013mb. + Altimeter Int + | -- | The current pressure at station level in hectopascals. + QFE Int + | -- | The current pressure at sea level in hectopascals. + QFF Int + deriving (Eq, Show) + +-- | A weather phenomenon. +-- This can be an observed phenomenon in the case of METARs or an +-- expected phenomenon in the case of TAFs. +data WeatherPhenomenon + = Phenomenon + { -- | The intensity of the phenomenon. + _intensity :: WPIntensity + , -- | The description of the weather phenomenon. + _desc :: Maybe WPDesc + , -- | The precipitation type of the weather phenomenon. + _prec :: Maybe WPPrecipitation + , -- | The effects of the phenomenon on the visibility + _obfus :: Maybe WPObfuscation + , -- | Other details about the phenomenon. + _other :: Maybe WPOther } + deriving (Eq, Show) + +-- | The intensity of an observed or expected weather phenomenon. +data WPIntensity + = -- | Light + Light + | -- | Moderate + Moderate + | -- | Heavy + Heavy + | -- | Only applicable to METARs. The weather phenomenon was + -- observed in the vicinity of the observed area, not within + -- the observed area itself. + Vicinity + | -- | Only applicable to METARs. The weather phenomenon was + -- recently observed in the past, but was not observed at + -- the time the report was issued. + Recent + deriving (Enum, Eq, Show) + +-- | The description of a weather phenomenon. +data WPDesc + = -- | Shallow. + Shallow + | -- | Patches. + Patches + | -- | Partial. + WXPartial + | -- | Low, drifting. + LowDrifting + | -- | Blowing. + Blowing + | -- | Shower. + Shower + | -- | Thunderstorm. + Thunderstorm + | -- | Freezing. + Freezing + deriving (Enum, Eq, Ord, Show) + +-- | The type of the precipitation +data WPPrecipitation + = -- | Drizzle. + Drizzle + | -- | Rain. + Rain + | -- | Snow. + Snow + | -- | Snow grains. + ShowGrains + | -- | Ice crystals. + IceCrystals + | -- | Ice pellets. + IcePellets + | -- | Hail. + Hail + | -- | Snow pellets. + SnowPellets + | -- | Unknown type of precipitation. + UnknownPrecipitation + deriving (Enum, Eq, Ord, Show) + +-- | Effects on the visibility by a weather phenomenon +data WPObfuscation + = -- | Mist. Visibility impaired but still greater than 1000m + Mist + | -- | Fog. Visibility less than 1000m. + Fog + | -- | Smoke. + Smoke + | -- | Volcanic ash. + VolcanicAsh + | -- | Dust. + Dust + | -- | Sand. + Sand + | -- | Haze. + Haze + deriving (Enum, Eq, Ord, Show) + +-- | Other important information about a weather phenomenon. +data WPOther + = -- | Dust or sand whirls. + DustOrSandwhirls + | -- | Squalls. + Squalls + | -- | Tornado. + Tornado + | -- | Sand storm. + Sandstorm + | -- | Dust storm. + Duststorm + deriving (Enum, Eq, Ord, Show) + +-- | The Distance. +data Distance + = -- | The distance in metres. + Metres Int + | -- | The distance in km. + KM Int + | -- | The distance in statute miles. + SM Int + | -- | The distance in nautical miles. + NM Int + deriving (Eq, Show) + +-- | Vertical visibility. +data Visibility + = -- | Ten kilometres or more. + TenOrMore + | -- | Fifty metres or less. + FiftyMetresOrLess + | -- | Two kilometres or more. + TwoOrMore + | -- | A specific visibility. + SpecificVisibility Distance (Maybe Direction) + deriving (Eq, Show) + +-- | Directions. +data Direction + = -- | North. + North + | -- | South. + South + | -- | East. + East + | -- | West. + West + | -- | Northwest. + NorthWest + | -- | Northeast. + NorthEast + | -- | Southwest. + SouthWest + | -- | Southeast. + SouthEast + | -- | Left runway for runways of the same QFU + -- (part of the runway designator) + RWYLeft + | -- | Right runway for runways of the same QFU + -- (part of the runway designator) + RWYRight + | -- | Centre runway for runways of the same QFU + -- (part of the runway designator) + RWYCenter + deriving (Eq, Show) + +-- | Runway specification. +data Runway + = -- | All runways. + AllRunways + | -- | A specific runway. + SpecificRunway + { -- | The runway's magnetic orientation, divided by ten and rounded. + _runwayQFU :: Int + , -- | For multiple runways with the same QFU, a left, right or centre + -- selector is added. + _runwayDirection :: Maybe Direction } + deriving (Eq, Show) + +-- | The runway contamination type. +data RwyCoverType + = -- | The runway is not contaminated. + RCTDry + | -- | The runway is moist. + RCTMoist + | -- | The runway is wet. + RCTWet + | -- | The runway is convered with rime. + RCTRime + | -- | The runway is covered with dry snow. + RCTDrySnow + | -- | The runway is covered with wet snow. + RCTWetSnow + | -- | The runway is covered with slush. + RCTSlush + | -- | The runway is covered with ice. + RCTIce + | -- | The runway is covered with frozen ruts or ridges. + RCTFZRut + | -- | The runway contamination type is unknown. + RCTUnknown + deriving (Eq, Show, Enum) + +-- | Runway conditions. +data RunwayCondition + = -- | Specific runway conditions exist. + SpecificRunwayCondition + { -- | The runway for which specific conditions + -- have been observed. + _rwcondRunway :: Runway + , -- | Whether and how the runway is contamindated. + _rwcondCover :: RwyCoverType + , -- | The extent of the contamination in percent. + _rwcondSpread :: Maybe Int + , -- | The height of the contamination in millimetres. + _rwcondCoverHeight :: Maybe Int + , -- | The friction coefficient or braking action value. + _rwcondBrkCoeff :: RunwayBraking } + | -- | The runway is closed. + RwyClosed + { -- | The runway that is closed. + _rwclosedRunway :: Runway } + | -- | The whole aerodrome is closed. + ADClosed + deriving (Eq, Show) + +-- | The measured brake efficiency of a specific runway. +data RunwayBraking + = -- | The friction coefficient. + BrakingFriction Int + | -- | The braking coefficient. + BrakingEffect Int + deriving (Eq, Show) + +-- | An obersvation date. +data Date + = Date { + _dayOfMonth :: Int + , _hour :: Int + , _minute :: Int + } deriving (Eq, Show) + +-- | An aeronautical weather station designator. +newtype Station + = -- | The station as identified by its aerodrome's + -- ICAO code. + ICAO Text + deriving (Eq, Show) + +-- | A vertical position specification. +data Vertical + = -- | A vertical position with reference to the ground + -- in feet. + Height Int + | -- | A vertical position with reference to the mean + -- sea level/QNH in feet. + Altitude Int + | -- | A pressure altitude with reference to the + -- standard QNH of 1013 hectopascals in hundrets of feet. + FlightLevel Int + | -- | Vertical position is not specified. + VertNotSpec + deriving (Eq, Show) + +-- | Wind information. +data Wind + = Wind + { -- | The direction the wind is blowing from. + _winddirection :: WindDirection + , -- | The wind speed. + _velocity :: Unit + , -- | The strength of the observed gusts, if any. + _gusts :: Maybe Int + } deriving (Eq, Show) + +-- | The direction the wind is blowing from. +data WindDirection + = -- | The wind is blowing in equal or almost equal + -- strength from a wide variety of directions. + Variable + | -- | The wind is blowing from the specified direction. + -- Directions can be given with reference to true or + -- magnetic north, depending on the type of weather + -- observation/forecast message. + Degrees Int + | -- | The wind is blowing from a specific direction + -- range. + Varying + { -- | The mean direction the wind is blowing from. + _windmean :: Int + , -- | The minimum direction the wind is blowing from. + _windfrom :: Int + , -- | The maximum direction the wind is blowing from. + _windto :: Int + } deriving (Eq, Show) + + +-- | A speed unit. +data Unit + = -- | Nautical miles per hour + Knots Int + | -- | Statute miles per hour + Miles Int + | -- | Kilometres per hour + KMH Int + deriving (Eq, Show) + +-- | A cloud specification. +data Cloud + = -- | No specific clouds could be observed, because + -- the (given) ground visibility was too low or because + -- the ground is covered in clouds. + VVis (Maybe Int) + | -- | Clouds were observed. + ObservedCloud Cover Vertical CloudType + deriving (Eq, Show) + +-- | The type of cloud. +data CloudType + = -- | A cumulonimbus cloud. + Cumulonimbus + | -- | A developing cb cloud. + ToweringCumulus + | -- | A stratus cloud. + Stratus + | -- | A cumulus cloud. + Cumulus + | -- | A stratocumulus cloud. + Stratocumulus + | -- | An altostratus cloud. + Altostratus + | -- | An altocumulus cloud. + Altocumulus + | -- | A cirrostratus cloud. + Cirrostratus + | -- | A cirrus cloud. + Cirrus + | -- | An unclassified cloud. + Unclassified + deriving (Enum, Eq, Show) + +-- | The area that is covered. +data Cover + = -- | 1-2 eights are covered. + FEW + | -- | 3-4 eights are covered. + SCT + | -- | 5-7 eights are covered. + BKN + | -- | More than 7 eights are covered. + OVC + | -- | Cover not specified + CoverNotSpecified + deriving (Enum, Eq, Ord, Show) + +makeClassy ''Weather +makeClassyPrisms ''Weather +makeClassy ''Flag +makeClassyPrisms ''Flag +makeClassy ''Trend +makeClassyPrisms ''Trend +makeClassy ''Transition +makeClassyPrisms ''Transition +makeClassy ''VisTrend +makeClassyPrisms ''VisTrend +makeClassy ''Pressure +makeClassyPrisms ''Pressure +makeClassy ''WeatherPhenomenon +makeClassy ''WPIntensity +makeClassyPrisms ''WPIntensity +makeClassy ''WPDesc +makeClassyPrisms ''WPDesc +makeClassy ''WPPrecipitation +makeClassyPrisms ''WPPrecipitation +makeClassy ''WPObfuscation +makeClassyPrisms ''WPObfuscation +makeClassy ''WPOther +makeClassyPrisms ''WPOther +makeClassy ''Distance +makeClassyPrisms ''Distance +makeClassy ''Visibility +makeClassyPrisms ''Visibility +makeClassy ''Direction +makeClassyPrisms ''Direction +makeClassy ''Runway +makeClassyPrisms ''Runway +makeClassy ''RwyCoverType +makeClassyPrisms ''RwyCoverType +makeClassy ''RunwayCondition +makeClassyPrisms ''RunwayCondition +makeClassy ''RunwayBraking +makeClassyPrisms ''RunwayBraking +makeClassy ''Date +makeWrapped ''Station +makeClassy ''Vertical +makeClassyPrisms ''Vertical +makeClassy ''Wind +makeClassy ''WindDirection +makeClassyPrisms ''WindDirection +makeClassy ''Unit +makeClassyPrisms ''Unit +makeClassy ''Cloud +makeClassyPrisms ''Cloud +makeClassy ''CloudType +makeClassyPrisms ''CloudType +makeClassy ''Cover +makeClassyPrisms ''Cover + +instance HasWPIntensity WeatherPhenomenon where + wPIntensity = + intensity . wPIntensity + +instance HasWindDirection Wind where + windDirection = + winddirection . windDirection + +instance HasUnit Wind where + unit = + velocity . unit + +stationParser :: CharParsing f => f Station +stationParser = ICAO <$> takeChars 4 + +dateParser :: CharParsing f => f Date +dateParser = Date <$> twin <*> twin <*> (twin <* text "Z") + where twin = (\a b -> read [a, b]) <$> digit <*> digit + +variableWindParser :: (Monad f, CharParsing f) => WindDirection -> f WindDirection +variableWindParser (Degrees meanWind) = try $ do + dir1 <- (\a b c -> read [a, b, c]) <$> digit <*> digit <*> digit + _ <- char 'V' + dir2 <- (\a b c -> read [a, b, c]) <$> digit <*> digit <*> digit + return $ Varying meanWind dir1 dir2 +variableWindParser _ = fail "Erroneous parameters" + +windParser :: (Monad f, CharParsing f) => f Wind +windParser = do + dir <- choice [readwinddir, variablewind] + str <- readwindstr + gustsies <- option Nothing readgusts + unit' <- readunit + dir2 <- option dir $ char ' ' >> variableWindParser dir + return $ Wind dir2 (unit' str) gustsies + where + variablewind = "VRB" `means` Variable + readwinddir = (\a b c -> Degrees . read $ [a, b, c]) <$> digit <*> digit <*> digit + readwindstr = (\a b -> read [a, b]) <$> digit <*> digit + readunit = choice [ "KT" `means` Knots + , "MPH" `means` Miles + , "KM" `means` KMH] + readgusts = (\_ b c -> Just . read $ [b, c]) <$> char 'G' <*> digit <*> digit + +pressureParser :: CharParsing f => f Pressure +pressureParser = choice [qnh, mmhg] + where + qnh = (\_ a b c d -> QNH $ read [a, b, c, d]) <$> char 'Q' <*> digit <*> digit <*> digit <*> digit + mmhg = (\_ a b c d -> Altimeter $ read [a, b, c, d]) <$> char 'A' <*> digit <*> digit <*> digit <*> digit + +wxParser :: (Monad f, CharParsing f) => f WeatherPhenomenon +wxParser = do + spaces + intsy <- intensityParser + dsc <- perhaps descParser + prc <- perhaps precipitationParser + obfs <- perhaps obfuscationParser + othr <- perhaps otherParser + when ( (== 0) . Prelude.length . Prelude.filter not $ + [ isNothing dsc, isNothing prc + , isNothing obfs, isNothing othr ] ) $ fail "" + return $ Phenomenon intsy dsc prc obfs othr + +perhaps :: Alternative m => m a -> m (Maybe a) +perhaps parser = option Nothing $ Just <$> parser + +perhaps_ :: Alternative f => f a -> f () +perhaps_ parser = void $ perhaps parser + +callsfor :: (CharParsing m, Monad m) => Text -> m b -> m b +a `callsfor` b = text a >> b + +means :: (CharParsing m, Monad m) => Text -> b -> m b +a `means` b = text a >> return b + +means' :: (CharParsing m, Monad m) => Text -> a -> m a +a `means'` b = try $ spaces >> text a >> spaces >> return b + +descParser :: (Monad f, CharParsing f) => f WPDesc +descParser = choice + [ "MI" `means` Shallow + , "BC" `means` Patches + , "PR" `means` WXPartial + , "DR" `means` LowDrifting + , "BL" `means` Blowing + , "SH" `means` Shower + , "TS" `means` Thunderstorm + , "FZ" `means` Freezing ] + +precipitationParser :: (Monad f, CharParsing f) => f WPPrecipitation +precipitationParser = choice + [ "DZ" `means` Drizzle + , "RA" `means` Rain + , "SN" `means` Snow + , "SG" `means` ShowGrains + , "IC" `means` IceCrystals + , "PL" `means` IcePellets + , "GR" `means` Hail + , "GS" `means` SnowPellets + , "UP" `means` UnknownPrecipitation ] + +obfuscationParser :: (Monad f, CharParsing f) => f WPObfuscation +obfuscationParser = choice + [ "BR" `means` Mist + , "FG" `means` Fog + , "FU" `means` Smoke + , "VA" `means` VolcanicAsh + , "DU" `means` Dust + , "SA" `means` Sand + , "HZ" `means` Haze ] + +otherParser :: (Monad f, CharParsing f) => f WPOther +otherParser = choice + [ "PO" `means` DustOrSandwhirls + , "SQ" `means` Squalls + , "FC" `means` Tornado + , "SS" `means` Sandstorm + , "DS" `means` Duststorm ] + +intensityParser :: (Monad f, CharParsing f) => f WPIntensity +intensityParser = option Moderate $ choice + [ char '-' >> return Light + , char '+' >> return Heavy + , "VC" `means` Vicinity + , "RE" `means` Recent ] + +visibilityParser :: (Monad f, CharParsing f) => f Visibility +visibilityParser = spaces >> choice [ tenormore, arb, arb1, metres ] + where + tenormore = text "9999" >> return TenOrMore + metres = (\a b c d dir -> SpecificVisibility (visunit $ read [a,b,c,d]) dir) <$> digit <*> digit <*> digit <*> digit <*> directionParser + visunit :: Int -> Distance + visunit n = if n > 5000 + then KM (n `quot` 1000) + else Metres n + arb = (\a b unit' -> SpecificVisibility (unit' $ read [a,b])) <$> digit <*> digit <*> distanceUnitParser <*> directionParser + arb1 = (\a unit' -> SpecificVisibility (unit' $ read ['0', a])) <$> digit <*> distanceUnitParser <*> directionParser + +directionParser :: (Monad f, CharParsing f) => f (Maybe Direction) +directionParser = Nothing `option` (Just <$> choice + [ "NE" `means` NorthEast, "NW" `means` NorthWest + , "SE" `means` SouthEast, "SW" `means` SouthWest + , "N" `means` North, "S" `means` South + , "E" `means` East, "W" `means` West ]) + +distanceUnitParser :: (Monad f, CharParsing f) => f (Int -> Distance) +distanceUnitParser = choice + [ "KM" `means` KM + , "SM" `means` SM + , "NM" `means` NM ] + +cloudParser :: (Monad f, CharParsing f) => f [Cloud] +cloudParser = choice [(:[]) <$> vvisParser, nsc, cavok, clr, sepBy1 clds (char ' ')] + where + clds = do + perhaps_ space + intsy <- cloudIntensityParser + height <- choice + [ "///" `means` VertNotSpec + , (\a b c -> Height $ (* 100) $ read [a, b, c]) <$> digit <*> digit <*> digit ] + + cloudType' <- cloudTypeParser + return $ ObservedCloud intsy height cloudType' + cavok = spaces >> "CAVOK" `means` [] + nsc = spaces >> "NSC" `means` [] + clr = spaces >> "CLR" `means` [] + +vvisParser :: (Monad f, CharParsing f) => f Cloud +vvisParser = do + _ <- text "VV" + choice + [ "///" `means` VVis Nothing + , (\a b c -> VVis . Just . read $ [a,b,c]) <$> digit <*> digit <*> digit ] + +cloudIntensityParser :: (Monad f, CharParsing f) => f Cover +cloudIntensityParser = choice + [ "FEW" `means` FEW + , "SCT" `means` SCT + , "BKN" `means` BKN + , "OVC" `means` OVC + , "///" `means` CoverNotSpecified ] + +cloudTypeParser :: (Monad f, CharParsing f) => f CloudType +cloudTypeParser = option Unclassified $ choice + [ "CB" `means` Cumulonimbus + , "TCU" `means` ToweringCumulus + , "ST" `means` Stratus + , "CU" `means` Cumulus + , "SC" `means` Stratocumulus + , "AS" `means` Altostratus + , "AC" `means` Altocumulus + , "CS" `means` Cirrostratus + , "CI" `means` Cirrus + , "///" `means` Unclassified] + +perhapsMinus :: (Monad f, CharParsing f) => f String +perhapsMinus = "" `option` (char 'M' >> return "-") + +tdParser :: (Monad f, CharParsing f) => f (Int, Int) +tdParser = do + tmpr <- (\pm a b -> read (pm ++ [a, b]) :: Int) <$> perhapsMinus <*> digit <*> digit + _ <- char '/' + dewpoint <- (\pm a b -> read (pm ++ [a, b]) :: Int) <$> perhapsMinus <*> digit <*> digit + return (tmpr, dewpoint) + +flagsParser :: (Monad f, CharParsing f) => f [Flag] +flagsParser = many $ choice + [ "COR" `means'` COR + , "AMD" `means'` AMD + , "AUTO" `means'` AUTO ] + +runwayvisParser :: (Monad f, CharParsing f) => f (Runway, [Visibility], Maybe VisTrend) +runwayvisParser = do + runway' <- runwayDesignationParser + _ <- char '/' + vis <- parseRwyVis + vistrend <- Nothing `option` (Just <$> choice + [ "D" `means` VisTrendDownward + , "N" `means` VisTrendNoDistinctTendency + , "U" `means` VisTrendUpward ] ) + return (runway', vis, vistrend) + where + parseRwyVis = do + worstvis <- Nothing `option` (Just <$> choice visspec <* text "V") + vis <- Just <$> choice visspec + return $ catMaybes [worstvis, vis] + + visspec = + [ "M0050" `means` FiftyMetresOrLess + , "P2000" `means` TwoOrMore + , fourDigits >>= \a -> return $ SpecificVisibility (Metres a) Nothing + , trieDigits >>= \a -> return $ SpecificVisibility (Metres a) Nothing ] + +runwayconditionParser :: (Monad f, CharParsing f) => f RunwayCondition +runwayconditionParser = do + runway' <- runwayDesignationParser + _ <- char '/' + choice + [ "SNOCLO" `means` ADClosed + , rwycond runway' ] + + where + rwycond runway' = do + cover' <- RCTUnknown `option` ((toEnum . read . (:[])) <$> digit) + spread <- choice + [ char '/' >> return Nothing + , (Just . read . (:[])) <$> digit ] + spreadheight <- choice + [ text "//" >> return Nothing + , Just <$> tuhDigits ] + rkorbw <- tuhDigits + let coff = if rkorbw <= 90 + then BrakingFriction rkorbw + else BrakingEffect rkorbw + return $ SpecificRunwayCondition runway' cover' spread spreadheight coff + +fourDigits :: CharParsing f => f Int +fourDigits = (\a b c d -> read [a,b,c,d]) <$> digit <*> digit <*> digit <*> digit + +trieDigits :: CharParsing f => f Int +trieDigits = (\a b c -> read [a,b,c]) <$> digit <*> digit <*> digit + +tuhDigits :: CharParsing f => f Int +tuhDigits = (\a b -> read [a,b]) <$> digit <*> digit + +runwayDesignationParser :: (Monad f, CharParsing f) => f Runway +runwayDesignationParser = choice ["R88" `means` AllRunways, oneRunway] + where + oneRunway = do + _ <- char 'R' + magheading <- (\a b -> read [a,b]) <$> digit <*> digit + dir <- Nothing `option` (Just <$> choice + [ "L" `means` RWYLeft + , "R" `means` RWYRight + , "C" `means` RWYCenter ]) + return $ SpecificRunway magheading dir + +trendParser :: (Monad f, CharParsing f) => f Trend +trendParser = choice + [ "NOSIG" `means` NOSIG + , changeParser ] + where + changeParser = do + changes <- changesParser + when (length changes /= 1) $ fail "A METAR contains exactly one transition" + return $ head changes + +changesParser :: (Monad f, CharParsing f) => f [Trend] +changesParser = some $ spaces >> transitionTypeParser + where + transitionTypeParser = choice + [ "TEMPO" `callsfor` (TEMPO <$> transitionParser) + , "BECMG" `callsfor` (BECMG <$> transitionParser) + , "PROB" `callsfor` (PROB <$> twoDigits <*> (head <$> changesParser)) ] + transitionParser = sepBy1 oneTransition (char ' ') + oneTransition = do + spaces + choice . map try $ + [ TransClouds <$> cloudParser + , TransWind <$> windParser + , TransVis <$> some visibilityParser + , TransWX <$> count 1 wxParser + , TransRunwayVis <$> sepBy runwayvisParser (char ' ') ] + +twoDigits :: CharParsing f => f Int +twoDigits = (\a b -> read [a,b]) <$> digit <*> digit + +metarParser :: (Monad f, CharParsing f) => f Weather +metarParser = do + _ <- text "METAR" + reportflags <- flagsParser + identifier <- spaces >> stationParser + reportdate <- spaces >> dateParser + reportflags2 <- flagsParser + reportwind <- Nothing `option` (spaces >> Just <$> windParser) + spaces + reportvis <- [TenOrMore] `option` some visibilityParser + spaces + reportrunwaycond <- sepBy runwayconditionParser (char ' ') + reportrunwayvis <- sepBy runwayvisParser (char ' ') + reportwx <- many wxParser + reportclouds <- [] `option` (spaces >> cloudParser) + (reporttemp, reportdewpoint) <- (Nothing, Nothing) `option` (spaces >> tdParser >>= \(w,d) -> return (Just w, Just d)) + reportpressure <- Nothing `option` (spaces >> Just <$> pressureParser) + void $ many $ spaces >> pressureParser -- Sometimes, multiple pressure values are offered + spaces + reporttrend <- NOTAVAIL `option` trendParser + reportrmk <- maybeRMK + spaces + maintenance' <- or <$> optional (True <$ char '$' <|> False <$ char '=') + return $ METAR reportdate identifier (reportflags ++ reportflags2) + reportwind reportvis reportrunwayvis reportrunwaycond reportwx + reportclouds reportpressure reporttemp reportdewpoint + reporttrend reportrmk maintenance' + +maybeRMK :: (Monad f, CharParsing f) => f (Maybe Text) +maybeRMK = Nothing `option` do + void $ choice [ text "RMK ", text " RMK " ] + Just . pack <$> some (satisfy (`notElem` ("$=" :: String))) + +-- | An attoparsec parser that can parse METAR messages. +weatherParser :: (Monad f, CharParsing f) => f Weather +weatherParser = metarParser diff --git a/src/Data/Aviation/WX/Fetcher.hs b/src/Data/Aviation/WX/Fetcher.hs --- a/src/Data/Aviation/WX/Fetcher.hs +++ b/src/Data/Aviation/WX/Fetcher.hs @@ -1,21 +1,30 @@ -module Data.Aviation.WX.Fetcher where +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} -import Data.Char -import Data.List (filter) -import Data.Text (pack) -import Network.HTTP +module Data.Aviation.WX.Fetcher( + parseWeather +, fetchMetar +) where -import Data.Aviation.WX +import Data.Attoparsec.Text(parseOnly) +import Data.Aviation.WX(Weather, weatherParser) +import Data.Char(toUpper, isAlpha) +import Data.Text(Text, pack) +import Network.HTTP(simpleHTTP, getRequest, getResponseBody) type ICAOStationDesignator = String +-- | Parse the given METAR text. +parseWeather :: Text -> Either String Weather +parseWeather = parseOnly weatherParser + fetchMetar :: ICAOStationDesignator -> IO (Either String Weather) fetchMetar icao = do let icao' = map toUpper . filter isAlpha $ icao metarString <- simpleHTTP (getRequest $ url icao') >>= getResponseBody - let wx = pack $ "METAR " ++ relLine metarString ++ "=" - putStrLn $ "Parsing " ++ show wx - return $ parseWeather wx + let wx' = pack $ "METAR " ++ relLine metarString + putStrLn $ "Parsing " ++ show wx' + return $ parseWeather wx' where - url designator = "http://weather.noaa.gov/pub/data/observations/metar/stations/" ++ designator ++ ".TXT" + url designator = "http://tgftp.nws.noaa.gov/data/observations/metar/stations/" ++ designator ++ ".TXT" relLine s = Prelude.lines s !! 1 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,10 +4,15 @@ ) where import Control.Monad +import Data.Attoparsec.Text (parseOnly) import Data.Text import Data.Aviation.WX +-- | Parse the given METAR text. +parseWeather :: Text -> Either String Weather +parseWeather = parseOnly weatherParser + frankfurt :: Text frankfurt = "METAR EDDF 010203Z 14032KT 130V240 9999 FEW017 SCT023CB BKN042 42/23 Q1029 NOSIG=" @@ -20,13 +25,13 @@ main :: IO () main = do let Right frankfurt' = parseWeather frankfurt - unless (temperature frankfurt' == Just 42) $ error "Temperature Frankfurt should be 42 degrees" - unless (dewPoint frankfurt' == Just 23) $ error "Dew point Frankfurt should be 23 degrees" + unless (_temperature frankfurt' == Just 42) $ error "Temperature Frankfurt should be 42 degrees" + unless (_dewPoint frankfurt' == Just 23) $ error "Dew point Frankfurt should be 23 degrees" let Right juliana' = parseWeather juliana - unless (temperature juliana' == Just 29) $ error "It's 29 degrees in St. Maarten!" - unless (dewPoint juliana' == Just 24) $ error "What's with the dew point in St. Maarten?" + unless (_temperature juliana' == Just 29) $ error "It's 29 degrees in St. Maarten!" + unless (_dewPoint juliana' == Just 24) $ error "What's with the dew point in St. Maarten?" let Right loxt' = parseWeather loxt - unless (temperature loxt' == Just 27) $ error "Temperature LOXT should be 27 degrees centigrade!" - unless (dewPoint loxt' == Just 12) $ error "Dew point LOXT should be 12 degrees centigrade!" + unless (_temperature loxt' == Just 27) $ error "Temperature LOXT should be 27 degrees centigrade!" + unless (_dewPoint loxt' == Just 12) $ error "Dew point LOXT should be 12 degrees centigrade!"