diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -1,77 +1,31 @@ -CSIRO Open Source Software License Agreement (variation of the BSD / MIT -License) - -Copyright (c) 2016, Commonwealth Scientific and Industrial Research Organisation +Copyright 2017,2018 Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. -All rights reserved. CSIRO is willing to grant you a license to this -aemo-webservice on the following terms, except where otherwise indicated for -third party material. - -Redistribution and use of this software in source and binary forms, with or -without modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright notice, this - list of conditions and the following disclaimer in the documentation and/or - other materials provided with the distribution. - -* Neither the name of CSIRO nor the names of its contributors may be used to - endorse or promote products derived from this software without specific prior - written permission of CSIRO. - -EXCEPT AS EXPRESSLY STATED IN THIS AGREEMENT AND TO THE FULL EXTENT PERMITTED BY -APPLICABLE LAW, THE SOFTWARE IS PROVIDED "AS-IS". CSIRO MAKES NO -REPRESENTATIONS, WARRANTIES OR CONDITIONS OF ANY KIND, EXPRESS OR IMPLIED, -INCLUDING BUT NOT LIMITED TO ANY REPRESENTATIONS, WARRANTIES OR CONDITIONS -REGARDING THE CONTENTS OR ACCURACY OF THE SOFTWARE, OR OF TITLE, -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, NON-INFRINGEMENT, THE ABSENCE -OF LATENT OR OTHER DEFECTS, OR THE PRESENCE OR ABSENCE OF ERRORS, WHETHER OR NOT -DISCOVERABLE. - -TO THE FULL EXTENT PERMITTED BY APPLICABLE LAW, IN NO EVENT SHALL CSIRO BE -LIABLE ON ANY LEGAL THEORY (INCLUDING, WITHOUT LIMITATION, IN AN ACTION FOR -BREACH OF CONTRACT, NEGLIGENCE OR OTHERWISE) FOR ANY CLAIM, LOSS, DAMAGES OR -OTHER LIABILITY HOWSOEVER INCURRED. WITHOUT LIMITING THE SCOPE OF THE PREVIOUS -SENTENCE THE EXCLUSION OF LIABILITY SHALL INCLUDE: LOSS OF PRODUCTION OR -OPERATION TIME, LOSS, DAMAGE OR CORRUPTION OF DATA OR RECORDS; OR LOSS OF -ANTICIPATED SAVINGS, OPPORTUNITY, REVENUE, PROFIT OR GOODWILL, OR OTHER ECONOMIC -LOSS; OR ANY SPECIAL, INCIDENTAL, INDIRECT, CONSEQUENTIAL, PUNITIVE OR EXEMPLARY -DAMAGES, ARISING OUT OF OR IN CONNECTION WITH THIS AGREEMENT, ACCESS OF THE -SOFTWARE OR ANY OTHER DEALINGS WITH THE SOFTWARE, EVEN IF CSIRO HAS BEEN ADVISED -OF THE POSSIBILITY OF SUCH CLAIM, LOSS, DAMAGES OR OTHER LIABILITY. - -APPLICABLE LEGISLATION SUCH AS THE AUSTRALIAN CONSUMER LAW MAY APPLY -REPRESENTATIONS, WARRANTIES, OR CONDITIONS, OR IMPOSES OBLIGATIONS OR LIABILITY -ON CSIRO THAT CANNOT BE EXCLUDED, RESTRICTED OR MODIFIED TO THE FULL EXTENT SET -OUT IN THE EXPRESS TERMS OF THIS CLAUSE ABOVE "CONSUMER GUARANTEES". TO THE -EXTENT THAT SUCH CONSUMER GUARANTEES CONTINUE TO APPLY, THEN TO THE FULL EXTENT -PERMITTED BY THE APPLICABLE LEGISLATION, THE LIABILITY OF CSIRO UNDER THE -RELEVANT CONSUMER GUARANTEE IS LIMITED (WHERE PERMITTED AT CSIRO'S OPTION) TO -ONE OF FOLLOWING REMEDIES OR SUBSTANTIALLY EQUIVALENT REMEDIES: - -(a) THE REPLACEMENT OF THE SOFTWARE, THE SUPPLY OF EQUIVALENT - SOFTWARE, OR SUPPLYING RELEVANT SERVICES AGAIN; -(b) THE REPAIR OF THE SOFTWARE; -(c) THE PAYMENT OF THE COST OF REPLACING THE - SOFTWARE, OF ACQUIRING EQUIVALENT SOFTWARE, HAVING THE - RELEVANT SERVICES SUPPLIED AGAIN, OR HAVING THE SOFTWARE - REPAIRED. +All rights reserved. -IN THIS CLAUSE, CSIRO INCLUDES ANY THIRD PARTY AUTHOR OR OWNER OF ANY PART OF -THE SOFTWARE OR MATERIAL DISTRIBUTED WITH IT. CSIRO MAY ENFORCE ANY RIGHTS ON -BEHALF OF THE RELEVANT THIRD PARTY. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: -Third Party Components + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. -The following third party components are distributed with the Software. You -agree to comply with the license terms for these components as part of accessing -the Software. Other third party software may also be identified in separate -files distributed with the Software. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. -___________________________________________________________________ + * Neither the name of QFPL nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. -___________________________________________________________________ +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) -import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) -import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) -import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) -import Distribution.Verbosity ( Verbosity ) -import System.FilePath ( () ) - -main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - } - -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule verbosity pkg lbi = do - let dir = autogenModulesDir lbi - createDirectoryIfMissingVerbose verbosity True dir - withLibLBI pkg lbi $ \_ libcfg -> do - withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" - , "deps :: [String]" - , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) - ] - where - formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) - -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys - -\end{code} diff --git a/aip.cabal b/aip.cabal --- a/aip.cabal +++ b/aip.cabal @@ -1,35 +1,35 @@ name: aip -version: 0.0.1 +version: 0.1.0 license: BSD3 license-file: LICENCE author: Queensland Functional Programming Lab maintainer: Queensland Functional Programming Lab -copyright: Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. +copyright: Copyright (c) 2018, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. synopsis: Aeronautical Information Package (AIP) category: Data, Aviation description: <> . - Document managament for the airservices Aeronautical Information Package (AIP). + Document management for the airservices Aeronautical Information Package (AIP). homepage: https://github.com/qfpl/aip bug-reports: https://github.com/qfpl/aip/issues cabal-version: >= 1.10 -build-type: Custom -extra-source-files: changelog +build-type: Simple +extra-source-files: changelog.md source-repository head type: git location: git@github.com:qfpl/aip.git -flag small_base - description: Choose the new, split-up base package. - library default-language: Haskell2010 build-depends: base >= 4.8 && < 5 + , aeson >= 1.4.0.0 && < 1.5 + , aeson-pretty >= 0.8 && < 0.9 + , unordered-containers >= 0.2.9.0 && < 0.3 , HTTP >= 4000 && < 5000 , network-uri >= 2.6 && < 3 , tagsoup >= 0.13 && < 0.15 @@ -37,12 +37,15 @@ , transformers >= 0.5 && < 0.6 , parsers >= 0.12 && < 0.13 , parsec >= 3.1 && < 3.2 - , digit >= 0.2 && < 0.3 , bytestring >= 0.10 && < 0.11 , filepath >= 1.4 && < 1.5 , directory >= 1.3 && < 1.4 , lens >= 4 && < 5 - , papa >= 0.3 && < 0.4 + , time >= 1.6 && < 1.9 + , utf8-string >= 1.0.1.1 && < 1.1 + , Crypto >= 4.2.5.1 && < 4.3 + , exceptions >= 0.10.0 && < 1 + , optparse-applicative >= 0.13.2 && < 0.15 ghc-options: -Wall @@ -56,19 +59,39 @@ exposed-modules: Data.Aviation.Aip + Data.Aviation.Aip.AfterDownload + Data.Aviation.Aip.Aip_SUP_and_AIC + Data.Aviation.Aip.Aip_SUP_and_AICs + Data.Aviation.Aip.AipCon Data.Aviation.Aip.AipDate Data.Aviation.Aip.AipDocument Data.Aviation.Aip.AipDocuments - Data.Aviation.Aip.AipHref - Data.Aviation.Aip.AipPg + Data.Aviation.Aip.AipOptions + Data.Aviation.Aip.AipRecord + Data.Aviation.Aip.AipRecords + Data.Aviation.Aip.Amendment + Data.Aviation.Aip.Cache Data.Aviation.Aip.ConnErrorHttp4xx - Data.Aviation.Aip.Day + Data.Aviation.Aip.DAPDoc + Data.Aviation.Aip.DAPDocs + Data.Aviation.Aip.DAPEntries + Data.Aviation.Aip.DAPEntry + Data.Aviation.Aip.DAPType + Data.Aviation.Aip.DocumentNumber Data.Aviation.Aip.Ersa - Data.Aviation.Aip.Ersas + Data.Aviation.Aip.ErsaAerodrome + Data.Aviation.Aip.ErsaAerodromes + Data.Aviation.Aip.Href Data.Aviation.Aip.HttpRequest - Data.Aviation.Aip.Month - Data.Aviation.Aip.Year + Data.Aviation.Aip.ListItemLink + Data.Aviation.Aip.ListItemLinks + Data.Aviation.Aip.ListItemLinks1 + Data.Aviation.Aip.Log + Data.Aviation.Aip.SHA1 + Data.Aviation.Aip.Title + Data.Aviation.Aip.Txt + executable aip main-is: Main.hs @@ -78,20 +101,8 @@ build-depends: base >= 4.8 && < 5 - , HTTP >= 4000 && < 5000 - , network-uri >= 2.6 && < 3 - , tagsoup >= 0.13 && < 0.15 - , tagsoup-selection >= 0.1 && < 0.2 - , transformers >= 0.5 && < 0.6 - , parsers >= 0.12 && < 0.13 - , parsec >= 3.1 && < 3.2 - , digit >= 0.2 && < 0.3 - , bytestring >= 0.10 && < 0.11 - , filepath >= 1.4 && < 1.5 - , directory >= 1.3 && < 1.4 - , lens >= 4 && < 5 - , papa >= 0.3 && < 0.4 - + , aip + ghc-options: -Wall @@ -99,31 +110,30 @@ NoImplicitPrelude hs-source-dirs: - src + src-exe -test-suite doctests - type: +test-suite tests + + build-depends: QuickCheck >=2.9.2 && <2.11 + , base >=4.8 && < 5 + , checkers >=0.4.6 && <0.5 + , aip + , lens >=4.15 && <4.16 + , tasty >=0.11 && <0.12 + , tasty-hunit >=0.9 && <0.10 + , tasty-quickcheck >=0.8.4 && <0.10 + + type: exitcode-stdio-1.0 - main-is: - doctests.hs + main-is: + Tests.hs - default-language: - Haskell2010 + hs-source-dirs: + test - build-depends: - base < 5 && >= 3 - , doctest >= 0.9.7 - , filepath >= 1.3 - , directory >= 1.1 - , QuickCheck >= 2.0 - , template-haskell >= 2.8 - , parsec >= 3.1 - , quickcheck-text + default-language: + Haskell2010 - ghc-options: + ghc-options: -Wall - -threaded - - hs-source-dirs: - test diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,3 +0,0 @@ -0.0.1 - -* Initial release diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,11 @@ +0.1.0 + +* Complete rewrite that fetches each document explicitly using HTML parsing. + +0.0.2 + +* Factor out `main` to `distributeAipDocuments`. + +0.0.1 + +* Initial release diff --git a/src-exe/Main.hs b/src-exe/Main.hs new file mode 100644 --- /dev/null +++ b/src-exe/Main.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Main( + main +) where + +import Data.Aviation.Aip(run, nothingAfterDownload) +import System.IO(IO) + +main :: + IO () +main = + run nothingAfterDownload diff --git a/src/Data/Aviation/Aip.hs b/src/Data/Aviation/Aip.hs --- a/src/Data/Aviation/Aip.hs +++ b/src/Data/Aviation/Aip.hs @@ -2,15 +2,33 @@ module A ) where +import Data.Aviation.Aip.AfterDownload as A +import Data.Aviation.Aip.Aip_SUP_and_AIC as A +import Data.Aviation.Aip.Aip_SUP_and_AICs as A +import Data.Aviation.Aip.AipCon as A import Data.Aviation.Aip.AipDate as A import Data.Aviation.Aip.AipDocument as A import Data.Aviation.Aip.AipDocuments as A -import Data.Aviation.Aip.AipHref as A -import Data.Aviation.Aip.AipPg as A +import Data.Aviation.Aip.AipOptions as A +import Data.Aviation.Aip.AipRecord as A +import Data.Aviation.Aip.AipRecords as A +import Data.Aviation.Aip.Amendment as A +import Data.Aviation.Aip.Cache as A import Data.Aviation.Aip.ConnErrorHttp4xx as A -import Data.Aviation.Aip.Day as A -import Data.Aviation.Aip.Ersa as A -import Data.Aviation.Aip.Ersas as A +import Data.Aviation.Aip.DAPDoc as A +import Data.Aviation.Aip.DAPDocs as A +import Data.Aviation.Aip.DAPEntries as A +import Data.Aviation.Aip.DAPEntry as A +import Data.Aviation.Aip.DAPType as A import Data.Aviation.Aip.HttpRequest as A -import Data.Aviation.Aip.Month as A -import Data.Aviation.Aip.Year as A +import Data.Aviation.Aip.Ersa as A +import Data.Aviation.Aip.ErsaAerodrome as A +import Data.Aviation.Aip.ErsaAerodromes as A +import Data.Aviation.Aip.Href as A +import Data.Aviation.Aip.ListItemLink as A +import Data.Aviation.Aip.ListItemLinks as A +import Data.Aviation.Aip.ListItemLinks1 as A +import Data.Aviation.Aip.Log as A +import Data.Aviation.Aip.SHA1 as A +import Data.Aviation.Aip.Title as A +import Data.Aviation.Aip.Txt as A diff --git a/src/Data/Aviation/Aip/AfterDownload.hs b/src/Data/Aviation/Aip/AfterDownload.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/AfterDownload.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Aviation.Aip.AfterDownload( + AfterDownload(..) +, nothingAfterDownload +, filePathAfterDownload +, hrefAfterDownload +, AfterDownloadAipCon +) where + +import Control.Category((.)) +import Control.Applicative(Applicative(pure, (<*>))) +import Control.Lens +import Control.Monad(Monad(return, (>>=))) +import Data.Aviation.Aip.AipCon(AipCon) +import Data.Aviation.Aip.Href(Href) +import Data.Functor(Functor(fmap)) +import System.FilePath(FilePath) + +newtype AfterDownload f a = + AfterDownload + (FilePath -> Href -> f a) + +instance Functor f => Functor (AfterDownload f) where + fmap f (AfterDownload x) = + AfterDownload (\p h -> fmap f (x p h)) + +instance Applicative f => Applicative (AfterDownload f) where + pure = + AfterDownload . pure . pure . pure + AfterDownload f <*> AfterDownload a = + AfterDownload (\p h -> f p h <*> a p h) + +instance Monad f => Monad (AfterDownload f) where + return = + pure + AfterDownload x >>= f = + AfterDownload (\p h -> x p h >>= \a -> let g = f a ^. _Wrapped in g p h) + +instance AfterDownload f a ~ x => + Rewrapped (AfterDownload g k) x + +instance Wrapped (AfterDownload f k) where + type Unwrapped (AfterDownload f k) = + FilePath + -> Href + -> f k + _Wrapped' = + iso + (\(AfterDownload x) -> x) + AfterDownload + +nothingAfterDownload :: + Applicative f => AfterDownload f () +nothingAfterDownload = + pure () + +filePathAfterDownload :: + Applicative f => AfterDownload f FilePath +filePathAfterDownload = + AfterDownload (\p _ -> pure p) + +hrefAfterDownload :: + Applicative f => AfterDownload f Href +hrefAfterDownload = + AfterDownload (\_ h -> pure h) + +type AfterDownloadAipCon a = + AfterDownload AipCon a diff --git a/src/Data/Aviation/Aip/AipCon.hs b/src/Data/Aviation/Aip/AipCon.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/AipCon.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Data.Aviation.Aip.AipCon( + AipCon(..) +) where + +import Control.Category((.)) +import Control.Applicative(Applicative(pure, (<*>))) +import Control.Lens +import Control.Monad(Monad(return, (>>=))) +import Control.Monad.Catch(MonadThrow(throwM), MonadCatch(catch)) +import Control.Monad.IO.Class(MonadIO(liftIO)) +import Control.Monad.Trans.Except(ExceptT) +import Data.Aviation.Aip.ConnErrorHttp4xx(ConnErrorHttp4xx) +import Data.Bool(Bool) +import Data.Functor(Functor(fmap)) +import System.IO(IO) + +newtype AipCon a = + AipCon (Bool -> ExceptT ConnErrorHttp4xx IO a) + +instance AipCon a ~ r => + Rewrapped (AipCon b) r + +instance Wrapped (AipCon x) where + type Unwrapped (AipCon x) = + Bool + -> ExceptT ConnErrorHttp4xx IO x + _Wrapped' = + iso + (\(AipCon x) -> x) + AipCon + +instance Functor AipCon where + fmap f (AipCon x) = + AipCon (fmap (fmap f) x) + +instance Applicative AipCon where + pure = + AipCon . pure . pure + AipCon f <*> AipCon a = + AipCon (\b -> f b <*> a b) + +instance Monad AipCon where + return = + pure + AipCon x >>= f = + AipCon (\b -> x b >>= \a -> let r = f a ^. _Wrapped in r b) + +instance MonadIO AipCon where + liftIO = + AipCon . pure . liftIO + +instance MonadThrow AipCon where + throwM e = + AipCon (\_ -> throwM e) + +instance MonadCatch AipCon where + catch (AipCon x) k = + AipCon (\b -> catch (x b) (\z -> let r = k z ^. _Wrapped in r b)) diff --git a/src/Data/Aviation/Aip/AipDate.hs b/src/Data/Aviation/Aip/AipDate.hs --- a/src/Data/Aviation/Aip/AipDate.hs +++ b/src/Data/Aviation/Aip/AipDate.hs @@ -1,65 +1,192 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DefaultSignatures #-} module Data.Aviation.Aip.AipDate( AipDate(..) -, parseAipDate -, uriAipDate +, AsAipDate(..) +, FoldAipDate(..) +, GetAipDate(..) +, SetAipDate(..) +, ManyAipDate(..) , HasAipDate(..) +, IsAipDate(..) ) where -import Data.Aviation.Aip.Day(Day(Day), HasDay(day), parseDay) -import Data.Aviation.Aip.Month(Month, HasMonth(month), parseMonth) -import Data.Aviation.Aip.Year(Year(Year), HasYear(year), parseYear) -import Text.Parser.Char(CharParsing, char) -import Papa +import Control.Category((.), id) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON)) +import Data.Char(Char) +import Data.Eq(Eq) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Data.String(String) +import Prelude(Show) -data AipDate = - AipDate { - _aipday :: - Day - , _aipmonth :: - Month - , _aipyear :: - Year - } deriving (Eq, Ord, Show) +newtype AipDate = + AipDate + String + deriving (Eq, Ord, Show) -makeClassy ''AipDate +instance FromJSON AipDate where + parseJSON v = + AipDate <$> parseJSON v -parseAipDate :: - (CharParsing p, Monad p) => - p AipDate -parseAipDate = - AipDate <$> parseDay <* char '-' <*> parseMonth <* char '-' <*> parseYear +instance ToJSON AipDate where + toJSON (AipDate x) = + toJSON x -instance HasDay AipDate where - day = - aipday . day +instance Semigroup AipDate where + AipDate x <> AipDate y = + AipDate (x <> y) + +instance Monoid AipDate where + mappend = + (<>) + mempty = + AipDate mempty + +instance Cons AipDate AipDate Char Char where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc AipDate AipDate Char Char where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each AipDate AipDate Char Char where + each = + _Wrapped . each + +instance Reversing AipDate where + reversing = + _Wrapped %~ reversing + +instance Plated AipDate where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue AipDate = Char +type instance Index AipDate = Int +instance Ixed AipDate where + ix i = + _Wrapped . ix i + +instance Wrapped AipDate where + type Unwrapped AipDate = String + _Wrapped' = + iso + (\(AipDate x) -> x) + AipDate + +instance AipDate ~ a => + Rewrapped AipDate a + +class ManyAipDate a => AsAipDate a where + _AipDate :: + Prism' a AipDate + default _AipDate :: + IsAipDate a => + Prism' a AipDate + _AipDate = + _IsAipDate + +instance AsAipDate AipDate where + _AipDate = + id + +instance AsAipDate String where + _AipDate = + from _Wrapped + +class FoldAipDate a where + _FoldAipDate :: + Fold a AipDate -instance HasMonth AipDate where - month = - aipmonth . month +instance FoldAipDate AipDate where + _FoldAipDate = + id -instance HasYear AipDate where - year = - aipyear . year +instance FoldAipDate String where + _FoldAipDate = + from _Wrapped -uriAipDate :: - AipDate - -> String -uriAipDate (AipDate (Day d1 d2) m (Year y1 y2 y3 y4)) = - concat - [ - show d1 - , show d2 - , "-" - , show m - , "-" - , show y1 - , show y2 - , show y3 - , show y4 - ] +class FoldAipDate a => GetAipDate a where + _GetAipDate :: + Getter a AipDate + default _GetAipDate :: + HasAipDate a => + Getter a AipDate + _GetAipDate = + aipDate + +instance GetAipDate AipDate where + _GetAipDate = + id + +instance GetAipDate String where + _GetAipDate = + from _Wrapped + +class SetAipDate a where + _SetAipDate :: + Setter' a AipDate + default _SetAipDate :: + ManyAipDate a => + Setter' a AipDate + _SetAipDate = + _ManyAipDate + +instance SetAipDate AipDate where + _SetAipDate = + id + +instance SetAipDate String where + _SetAipDate = + from _Wrapped + +class (FoldAipDate a, SetAipDate a) => ManyAipDate a where + _ManyAipDate :: + Traversal' a AipDate + +instance ManyAipDate AipDate where + _ManyAipDate = + id + +instance ManyAipDate String where + _ManyAipDate = + from _Wrapped + +class (GetAipDate a, ManyAipDate a) => HasAipDate a where + aipDate :: + Lens' a AipDate + default aipDate :: + IsAipDate a => + Lens' a AipDate + aipDate = + _IsAipDate + +instance HasAipDate AipDate where + aipDate = + id + +instance HasAipDate String where + aipDate = + from _Wrapped + +class (HasAipDate a, AsAipDate a) => IsAipDate a where + _IsAipDate :: + Iso' a AipDate + +instance IsAipDate AipDate where + _IsAipDate = + id + +instance IsAipDate String where + _IsAipDate = + from _Wrapped diff --git a/src/Data/Aviation/Aip/AipDocument.hs b/src/Data/Aviation/Aip/AipDocument.hs --- a/src/Data/Aviation/Aip/AipDocument.hs +++ b/src/Data/Aviation/Aip/AipDocument.hs @@ -1,64 +1,646 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DefaultSignatures #-} module Data.Aviation.Aip.AipDocument( AipDocument(..) -, requestAipDocument +, AipDocument1 +, AipDocument2 +, AsAipDocument(..) +, FoldAipDocument(..) +, GetAipDocument(..) +, SetAipDocument(..) +, ManyAipDocument(..) , HasAipDocument(..) +, IsAipDocument(..) +, runBook +, runCharts +, runSUP_AIC +, runDAP +, runERSA +, runAipDocument ) where -import Data.ByteString(ByteString) -import qualified Data.ByteString as ByteString(writeFile) -import Network.HTTP(Request, HasHeaders(..), rqURI) -import System.Directory(createDirectoryIfMissing) -import System.FilePath(takeDirectory) -import System.IO(Handle, hPutStrLn) -import Control.Monad.Trans.Except(runExceptT) -import Data.Aviation.Aip.ConnErrorHttp4xx(ConnErrorHttp4xx(IsConnError, Http4xx)) -import Data.Aviation.Aip.HttpRequest(doRequest) -import Papa +import Control.Category((.), id) +import Control.Applicative(pure, (<*>)) +import Control.Lens hiding ((.=)) +import Control.Monad(fail, (>=>), (>>=), join, mapM) +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), Value(Object), object, (.=)) +import Data.Aviation.Aip.Aip_SUP_and_AIC(Aip_SUP_and_AIC(Aip_SUP_and_AIC)) +import Data.Aviation.Aip.Aip_SUP_and_AICs(Aip_SUP_and_AICs(Aip_SUP_and_AICs)) +import Data.Aviation.Aip.AipCon(AipCon) +import Data.Aviation.Aip.AipDate(AipDate(AipDate)) +import Data.Aviation.Aip.Amendment(Amendment(Amendment)) +import Data.Aviation.Aip.DAPType(DAPType', DAPType(SpecNotManTOCDAP, ChecklistTOCDAP, LegendInfoTablesTOCDAP, AeroProcChartsTOCDAP)) +import Data.Aviation.Aip.DAPEntries(DAPEntries(DAPEntries)) +import Data.Aviation.Aip.DAPEntry(DAPEntry(DAPEntry)) +import Data.Aviation.Aip.DAPDoc(DAPDoc(DAPDoc)) +import Data.Aviation.Aip.DAPDocs(DAPDocs(DAPDocs)) +import Data.Aviation.Aip.DocumentNumber(DocumentNumber(DocumentNumber)) +import Data.Aviation.Aip.Ersa(Ersa(Ersa)) +import Data.Aviation.Aip.Href(Href(Href), SetHref, FoldHref(_FoldHref), ManyHref(_ManyHref), dropHrefFile) +import Data.Aviation.Aip.HttpRequest(doGetRequest) +import Data.Aviation.Aip.ListItemLink(ListItemLink(ListItemLink)) +import Data.Aviation.Aip.ListItemLinks(ListItemLinks(ListItemLinks)) +import Data.Aviation.Aip.ListItemLinks1(ListItemLinks1(ListItemLinks1)) +import Data.Aviation.Aip.ErsaAerodrome(ErsaAerodrome(ErsaAerodrome)) +import Data.Aviation.Aip.ErsaAerodromes(ErsaAerodromes(ErsaAerodromes)) +import Data.Aviation.Aip.Title(Title(Title)) +import Data.Aviation.Aip.Txt(Txt(Txt)) +import Data.Bool(Bool(True)) +import Data.Char(isSpace) +import Data.Either(Either(Left, Right)) +import Data.Eq(Eq) +import Data.Foldable(foldMap) +import Data.Function(($)) +import Data.Functor((<$>)) +import Data.List(isSuffixOf, dropWhile) +import Data.List.NonEmpty(NonEmpty((:|))) +import Data.Maybe(Maybe(Just, Nothing)) +import qualified Data.HashMap.Strict as HashMap(toList) +import Data.Monoid(Monoid(mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Data.String(String) +import Network.TCP(HStream) +import Prelude(Show) +import Text.HTML.TagSoup(Tag(TagText, TagOpen)) +import Text.HTML.TagSoup.Tree(TagTree(TagBranch, TagLeaf), parseTree) +import Text.HTML.TagSoup.Tree.Zipper(TagTreePos(TagTreePos), fromTagTree, traverseTree) +import Text.StringLike(StringLike) -data AipDocument ty = - AipDocument { - _aipRequest :: - Request ty - , _aipDocumentPath :: - FilePath - } deriving Show +data AipDocument book charts sup_aic dap ersa = + Aip_Book Href AipDate book + | Aip_Charts Href AipDate charts + | Aip_SUP_AIC Href sup_aic + | Aip_Summary_SUP_AIC Href AipDate + | Aip_DAP Href AipDate dap + | Aip_DAH Href AipDate + | Aip_ERSA Href AipDate ersa + | Aip_AandB_Charts Href + deriving (Eq, Ord, Show) -makeClassy ''AipDocument +type AipDocument1 = + AipDocument () () () () () -instance HasHeaders (AipDocument ty) where - getHeaders (AipDocument r _) = - getHeaders r - setHeaders (AipDocument r p) h = - AipDocument (setHeaders r h) p +type AipDocument2 = + AipDocument ListItemLinks ListItemLinks1 Aip_SUP_and_AICs DAPDocs Ersa -requestAipDocument :: - Handle -- ^ log error - -> Handle -- ^ log out - -> AipDocument ByteString - -> IO (Maybe FilePath) -requestAipDocument err outlog (AipDocument r p) = - do z <- runExceptT (doRequest r) - case z of - Left e -> - let logmsg (IsConnError ee) = - show ee - logmsg (Http4xx x y) = - concat - [ - "HTTP error 4" - , show x - , show y - , " " - , show (rqURI r) - ] - in Nothing <$ hPutStrLn err (logmsg e) - Right s -> - do createDirectoryIfMissing True . takeDirectory $ p - ByteString.writeFile p $ s - hPutStrLn outlog (concat ["uri ", show (rqURI r), " created file ", p]) - pure (Just p) +class ManyAipDocument a => AsAipDocument a where + _AipDocument :: + Prism (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocument book charts sup_aic dap ersa) (AipDocument book' charts' sup_aic' dap' ersa') + default _AipDocument :: + IsAipDocument a => + Prism (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocument book charts sup_aic dap ersa) (AipDocument book' charts' sup_aic' dap' ersa') + _AipDocument = + _IsAipDocument + _Aip_Book :: + Prism (a book charts sup_aic dap ersa) (a book' charts sup_aic dap ersa) (Href, AipDate, book) (Href, AipDate, book') + _Aip_Book = + _AipDocument . + prism + (\(u, t, x) -> Aip_Book u t x) + (\a -> case a of + Aip_Book u t x -> + Right (u, t, x) + Aip_Charts u t x -> + Left (Aip_Charts u t x) + Aip_SUP_AIC u x -> + Left (Aip_SUP_AIC u x) + Aip_Summary_SUP_AIC u x -> + Left (Aip_Summary_SUP_AIC u x) + Aip_DAP u t x -> + Left (Aip_DAP u t x) + Aip_DAH u x -> + Left (Aip_DAH u x) + Aip_ERSA u t x -> + Left (Aip_ERSA u t x) + Aip_AandB_Charts x -> + Left (Aip_AandB_Charts x)) + _Aip_Charts :: + Prism (a book charts sup_aic dap ersa) (a book charts' sup_aic dap ersa) (Href, AipDate, charts) (Href, AipDate, charts') + _Aip_Charts = + _AipDocument . + prism + (\(u, t, x) -> Aip_Charts u t x) + (\a -> case a of + Aip_Book u t x -> + Left (Aip_Book u t x) + Aip_Charts u t x -> + Right (u, t, x) + Aip_SUP_AIC u x -> + Left (Aip_SUP_AIC u x) + Aip_Summary_SUP_AIC u x -> + Left (Aip_Summary_SUP_AIC u x) + Aip_DAP u t x -> + Left (Aip_DAP u t x) + Aip_DAH u x -> + Left (Aip_DAH u x) + Aip_ERSA u t x -> + Left (Aip_ERSA u t x) + Aip_AandB_Charts x -> + Left (Aip_AandB_Charts x)) + _Aip_SUP_AIC :: + Prism (a book charts sup_aic dap ersa) (a book charts sup_aic' dap ersa) (Href, sup_aic) (Href, sup_aic') + _Aip_SUP_AIC = + _AipDocument . + prism + (\(u, x) -> Aip_SUP_AIC u x) + (\a -> case a of + Aip_Book u t x -> + Left (Aip_Book u t x) + Aip_Charts u t x -> + Left (Aip_Charts u t x) + Aip_SUP_AIC u x -> + Right (u, x) + Aip_Summary_SUP_AIC u x -> + Left (Aip_Summary_SUP_AIC u x) + Aip_DAP u t x -> + Left (Aip_DAP u t x) + Aip_DAH u x -> + Left (Aip_DAH u x) + Aip_ERSA u t x -> + Left (Aip_ERSA u t x) + Aip_AandB_Charts x -> + Left (Aip_AandB_Charts x)) + _Aip_Summary_SUP_AIC :: + Prism (a book charts sup_aic dap ersa) (a book charts sup_aic dap ersa) (Href, AipDate) (Href, AipDate) + _Aip_Summary_SUP_AIC = + _AipDocument . + prism + (\(u, x) -> Aip_Summary_SUP_AIC u x) + (\a -> case a of + Aip_Book u t x -> + Left (Aip_Book u t x) + Aip_Charts u t x -> + Left (Aip_Charts u t x) + Aip_SUP_AIC u x -> + Left (Aip_SUP_AIC u x) + Aip_Summary_SUP_AIC u x -> + Right (u, x) + Aip_DAP u t x -> + Left (Aip_DAP u t x) + Aip_DAH u x -> + Left (Aip_DAH u x) + Aip_ERSA u t x -> + Left (Aip_ERSA u t x) + Aip_AandB_Charts x -> + Left (Aip_AandB_Charts x)) + _Aip_DAP :: + Prism (a book charts sup_aic dap ersa) (a book charts sup_aic dap' ersa) (Href, AipDate, dap) (Href, AipDate, dap') + _Aip_DAP = + _AipDocument . + prism + (\(u, t, x) -> Aip_DAP u t x) + (\a -> case a of + Aip_Book u t x -> + Left (Aip_Book u t x) + Aip_Charts u t x -> + Left (Aip_Charts u t x) + Aip_SUP_AIC u x -> + Left (Aip_SUP_AIC u x) + Aip_Summary_SUP_AIC u x -> + Left (Aip_Summary_SUP_AIC u x) + Aip_DAP u t x -> + Right (u, t, x) + Aip_DAH u x -> + Left (Aip_DAH u x) + Aip_ERSA u t x -> + Left (Aip_ERSA u t x) + Aip_AandB_Charts x -> + Left (Aip_AandB_Charts x)) + _Aip_DAH :: + Prism (a book charts sup_aic dap ersa) (a book charts sup_aic dap ersa) (Href, AipDate) (Href, AipDate) + _Aip_DAH = + _AipDocument . + prism + (\(u, x) -> Aip_DAH u x) + (\a -> case a of + Aip_Book u t x -> + Left (Aip_Book u t x) + Aip_Charts u t x -> + Left (Aip_Charts u t x) + Aip_SUP_AIC u x -> + Left (Aip_SUP_AIC u x) + Aip_Summary_SUP_AIC u x -> + Left (Aip_Summary_SUP_AIC u x) + Aip_DAP u t x -> + Left (Aip_DAP u t x) + Aip_DAH u x -> + Right (u, x) + Aip_ERSA u t x -> + Left (Aip_ERSA u t x) + Aip_AandB_Charts x -> + Left (Aip_AandB_Charts x)) + _Aip_ERSA :: + Prism (a book charts sup_aic dap ersa) (a book charts sup_aic dap ersa') (Href, AipDate, ersa) (Href, AipDate, ersa') + _Aip_ERSA = + _AipDocument . + prism + (\(u, t, x) -> Aip_ERSA u t x) + (\a -> case a of + Aip_Book u t x -> + Left (Aip_Book u t x) + Aip_Charts u t x -> + Left (Aip_Charts u t x) + Aip_SUP_AIC u x -> + Left (Aip_SUP_AIC u x) + Aip_Summary_SUP_AIC u x -> + Left (Aip_Summary_SUP_AIC u x) + Aip_DAP u t x -> + Left (Aip_DAP u t x) + Aip_DAH u x -> + Left (Aip_DAH u x) + Aip_ERSA u t x -> + Right (u, t, x) + Aip_AandB_Charts x -> + Left (Aip_AandB_Charts x)) + _Aip_AandB_Charts :: + Prism (a book charts sup_aic dap ersa) (a book charts sup_aic dap ersa) Href Href + _Aip_AandB_Charts = + _AipDocument . + prism + (\x -> Aip_AandB_Charts x) + (\a -> case a of + Aip_Book u t x -> + Left (Aip_Book u t x) + Aip_Charts u t x -> + Left (Aip_Charts u t x) + Aip_SUP_AIC u x -> + Left (Aip_SUP_AIC u x) + Aip_Summary_SUP_AIC u x -> + Left (Aip_Summary_SUP_AIC u x) + Aip_DAP u t x -> + Left (Aip_DAP u t x) + Aip_DAH u x -> + Left (Aip_DAH u x) + Aip_ERSA u t x -> + Left (Aip_ERSA u t x) + Aip_AandB_Charts x -> + Right x) + +instance AsAipDocument AipDocument where + _AipDocument = + id + +class FoldAipDocument a where + _FoldAipDocument :: + Fold (a book charts sup_aic dap ersa) (AipDocument book charts sup_aic dap ersa) + +instance FoldAipDocument AipDocument where + _FoldAipDocument = + id + +class FoldAipDocument a => GetAipDocument a where + _GetAipDocument :: + Getter (a book charts sup_aic dap ersa) (AipDocument book charts sup_aic dap ersa) + default _GetAipDocument :: + HasAipDocument a => + Getter (a book charts sup_aic dap ersa) (AipDocument book charts sup_aic dap ersa) + _GetAipDocument = + aipDocument + +instance GetAipDocument AipDocument where + _GetAipDocument = + id + +class SetAipDocument a where + _SetAipDocument :: + Setter (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocument book charts sup_aic dap ersa) (AipDocument book' charts' sup_aic' dap' ersa') + default _SetAipDocument :: + ManyAipDocument a => + Setter (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocument book charts sup_aic dap ersa) (AipDocument book' charts' sup_aic' dap' ersa') + _SetAipDocument = + _ManyAipDocument + +instance SetAipDocument AipDocument where + _SetAipDocument = + id + +class (FoldAipDocument a, SetAipDocument a) => ManyAipDocument a where + _ManyAipDocument :: + Traversal (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocument book charts sup_aic dap ersa) (AipDocument book' charts' sup_aic' dap' ersa') + +instance ManyAipDocument AipDocument where + _ManyAipDocument = + id + +class (GetAipDocument a, ManyAipDocument a) => HasAipDocument a where + aipDocument :: + Lens (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocument book charts sup_aic dap ersa) (AipDocument book' charts' sup_aic' dap' ersa') + default aipDocument :: + IsAipDocument a => + Lens (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocument book charts sup_aic dap ersa) (AipDocument book' charts' sup_aic' dap' ersa') + aipDocument = + _IsAipDocument + +instance HasAipDocument AipDocument where + aipDocument = + id + +class (HasAipDocument a, AsAipDocument a) => IsAipDocument a where + _IsAipDocument :: + Iso (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocument book charts sup_aic dap ersa) (AipDocument book' charts' sup_aic' dap' ersa') + +instance IsAipDocument AipDocument where + _IsAipDocument = + id + +instance (FromJSON book, FromJSON charts, FromJSON sup_aic, FromJSON dap, FromJSON ersa) => FromJSON (AipDocument book charts sup_aic dap ersa) where + parseJSON (Object z) = + case HashMap.toList z of + [("Aip_Book", q)] -> + (\(u, t, x) -> Aip_Book u t x) <$> parseJSON q + [("Aip_Charts", q)] -> + (\(u, t, x) -> Aip_Charts u t x) <$> parseJSON q + [("Aip_SUP_AIC", q)] -> + (\(u, x) -> Aip_SUP_AIC u x) <$> parseJSON q + [("Aip_Summary_SUP_AIC", q)] -> + (\(u, x) -> Aip_Summary_SUP_AIC u x) <$> parseJSON q + [("Aip_DAP", q)] -> + (\(u, t, x) -> Aip_DAP u t x) <$> parseJSON q + [("Aip_DAH", q)] -> + (\(u, x) -> Aip_DAH u x) <$> parseJSON q + [("Aip_ERSA", q)] -> + (\(u, t, x) -> Aip_ERSA u t x) <$> parseJSON q + [("Aip_AandB_Charts", q)] -> + Aip_AandB_Charts <$> parseJSON q + _ -> + fail "AipDocument" + parseJSON _ = + fail "AipDocument" + +instance (ToJSON book, ToJSON charts, ToJSON sup_aic, ToJSON dap, ToJSON ersa) => ToJSON (AipDocument book charts sup_aic dap ersa) where + toJSON (Aip_Book u t x) = + object ["Aip_Book" .= toJSON (u, t, x)] + toJSON (Aip_Charts u t x) = + object ["Aip_Charts" .= toJSON (u, t, x)] + toJSON (Aip_SUP_AIC u x) = + object ["Aip_SUP_AIC" .= toJSON (u, x)] + toJSON (Aip_Summary_SUP_AIC u x) = + object ["Aip_Summary_SUP_AIC" .= toJSON (u, x)] + toJSON (Aip_DAP u t x) = + object ["Aip_DAP" .= toJSON (u, t, x)] + toJSON (Aip_DAH u x) = + object ["Aip_DAH" .= toJSON (u, x)] + toJSON (Aip_ERSA u t x) = + object ["Aip_ERSA" .= toJSON (u, t, x)] + toJSON (Aip_AandB_Charts q) = + object ["Aip_AandB_Charts" .= toJSON q] + +instance (ManyHref book, ManyHref charts, ManyHref sup_aic, ManyHref dap, ManyHref ersa) => SetHref (AipDocument book charts sup_aic dap ersa) where +instance (ManyHref book, ManyHref charts, ManyHref sup_aic, ManyHref dap, ManyHref ersa) => FoldHref (AipDocument book charts sup_aic dap ersa) where + _FoldHref = + _ManyHref + +instance (ManyHref book, ManyHref charts, ManyHref sup_aic, ManyHref dap, ManyHref ersa) => ManyHref (AipDocument book charts sup_aic dap ersa) where + _ManyHref f (Aip_Book u d b) = + Aip_Book <$> f u <*> pure d <*> _ManyHref f b + _ManyHref f (Aip_Charts u d c) = + Aip_Charts <$> f u <*> pure d <*> _ManyHref f c + _ManyHref f (Aip_Summary_SUP_AIC u d) = + Aip_Summary_SUP_AIC <$> f u <*> pure d + _ManyHref f (Aip_SUP_AIC u c) = + Aip_SUP_AIC <$> f u <*> _ManyHref f c + _ManyHref f (Aip_DAP u d c) = + Aip_DAP <$> f u <*> pure d <*> _ManyHref f c + _ManyHref _ (Aip_DAH u c) = + Aip_DAH <$> pure u <*> pure c + _ManyHref f (Aip_ERSA u d b) = + Aip_ERSA <$> f u <*> pure d <*> _ManyHref f b + _ManyHref _ (Aip_AandB_Charts d) = + Aip_AandB_Charts <$> pure d + +runBook :: + AipDocument book charts sup_aic dap ersa + -> AipCon (AipDocument ListItemLinks charts sup_aic dap ersa) +runBook (Aip_Book u t _) = + Aip_Book u t <$> traverseAipHtmlRequestGet (traverseListItems (isSuffixOf ".pdf")) u +runBook (Aip_Charts u t x) = + pure (Aip_Charts u t x) +runBook (Aip_SUP_AIC u x) = + pure (Aip_SUP_AIC u x) +runBook (Aip_Summary_SUP_AIC u x) = + pure (Aip_Summary_SUP_AIC u x) +runBook (Aip_DAP u t x) = + pure (Aip_DAP u t x) +runBook (Aip_DAH u x) = + pure (Aip_DAH u x) +runBook (Aip_ERSA u t x) = + pure (Aip_ERSA u t x) +runBook (Aip_AandB_Charts x) = + pure (Aip_AandB_Charts x) + +runCharts :: + AipDocument book charts sup_aic dap ersa + -> AipCon (AipDocument book ListItemLinks1 sup_aic dap ersa) +runCharts (Aip_Book u t x) = + pure (Aip_Book u t x) +runCharts (Aip_Charts u t _) = + do i <- traverseAipHtmlRequestGet (traverseListItems (pure True)) u + p <- traverse (\l@(ListItemLink u' _) -> + do n <- traverseAipHtmlRequestGet (traverseListItems (isSuffixOf ".pdf")) u' + pure (l :| n ^. _Wrapped)) (i ^. _Wrapped) + pure (Aip_Charts u t (ListItemLinks1 p)) +runCharts (Aip_SUP_AIC u x) = + pure (Aip_SUP_AIC u x) +runCharts (Aip_Summary_SUP_AIC u x) = + pure (Aip_Summary_SUP_AIC u x) +runCharts (Aip_DAP u t x) = + pure (Aip_DAP u t x) +runCharts (Aip_DAH u x) = + pure (Aip_DAH u x) +runCharts (Aip_ERSA u t x) = + pure (Aip_ERSA u t x) +runCharts (Aip_AandB_Charts x) = + pure (Aip_AandB_Charts x) + +runSUP_AIC :: + AipDocument book charts sup_aic dap ersa + -> AipCon (AipDocument book charts Aip_SUP_and_AICs dap ersa) +runSUP_AIC (Aip_Book u t x) = + pure (Aip_Book u t x) +runSUP_AIC (Aip_Charts u t x) = + pure (Aip_Charts u t x) +runSUP_AIC (Aip_SUP_AIC u _) = + let traverseAip_SUP_AIC :: + TagTreePos String + -> Aip_SUP_and_AICs + traverseAip_SUP_AIC (TagTreePos (TagBranch "tr" _ (TagLeaf (TagText _) : TagBranch "td" [] [TagLeaf (TagText docnum)] : TagLeaf (TagText _): TagBranch "td" [] [TagBranch "a" [("href", hf)] [TagLeaf (TagText title)]] : TagLeaf (TagText _) : TagBranch "td" [("align","center")] [TagLeaf (TagText pubdate)] : TagLeaf (TagText _) : TagBranch "td" [("align","center")] [TagLeaf (TagText effdate)] : _)) _ _ _) = + Aip_SUP_and_AICs [Aip_SUP_and_AIC (DocumentNumber docnum) (Href hf) (Title title) (AipDate pubdate) (AipDate effdate)] + traverseAip_SUP_AIC _ = + mempty + in Aip_SUP_AIC u <$> traverseAipHtmlRequestGet traverseAip_SUP_AIC u +runSUP_AIC (Aip_Summary_SUP_AIC u x) = + pure (Aip_Summary_SUP_AIC u x) +runSUP_AIC (Aip_DAP u t x) = + pure (Aip_DAP u t x) +runSUP_AIC (Aip_DAH u x) = + pure (Aip_DAH u x) +runSUP_AIC (Aip_ERSA u t x) = + pure (Aip_ERSA u t x) +runSUP_AIC (Aip_AandB_Charts x) = + pure (Aip_AandB_Charts x) + +runDAP :: + AipDocument book charts sup_aic dap ersa + -> AipCon (AipDocument book charts sup_aic DAPDocs ersa) +runDAP (Aip_Book u t x) = + pure (Aip_Book u t x) +runDAP (Aip_Charts u t x) = + pure (Aip_Charts u t x) +runDAP (Aip_SUP_AIC u x) = + pure (Aip_SUP_AIC u x) +runDAP (Aip_Summary_SUP_AIC u x) = + pure (Aip_Summary_SUP_AIC u x) +runDAP (Aip_DAP u t _) = + let eachDAP :: + AipCon DAPDocs + eachDAP = + let trimSpaces = + dropWhile isSpace + traverseDAP :: + TagTreePos String + -> [(DAPType', Href)] + traverseDAP (TagTreePos (TagBranch "li" [] [TagBranch "a" [("href", hrefSpecNotManTOC)] [TagLeaf (TagText "Special Notices & Manuscript")]]) _ _ _) = + [(SpecNotManTOCDAP, Href hrefSpecNotManTOC)] + traverseDAP (TagTreePos (TagBranch "li" [] [TagBranch "a" [("href", hrefChecklistTOC)] [TagLeaf (TagText "Checklist")]]) _ _ _) = + [(ChecklistTOCDAP, Href hrefChecklistTOC)] + + traverseDAP (TagTreePos (TagBranch "li" [] [TagBranch "a" [("href", hrefLegendInfoTablesTOC)] [TagLeaf (TagText "Legend. Info & Tables")]]) _ _ _) = + [(LegendInfoTablesTOCDAP, Href hrefLegendInfoTablesTOC)] + + traverseDAP (TagTreePos (TagBranch "li" [] [TagBranch "a" [("href", hrefAeroProcChartsTOC)] [TagLeaf (TagText "Aerodrome & Procedure Charts")]]) _ _ _) = + [(AeroProcChartsTOCDAP (), Href hrefAeroProcChartsTOC)] + traverseDAP _ = + [] + traverseDAP2 :: + Href + -> TagTreePos String + -> DAPEntries + traverseDAP2 u' (TagTreePos (TagBranch "tr" [] [TagLeaf (TagText _),TagLeaf (TagOpen "td" _),TagLeaf (TagText _),TagBranch "td" _ [TagBranch "a" [("href",hf)] [TagLeaf (TagText tx)]],TagLeaf (TagText _),TagBranch "td" _ [TagLeaf (TagText date),TagBranch "span" _ [TagLeaf (TagText amend)]],TagLeaf (TagText _)]) _ _ _) = + DAPEntries [DAPEntry (dropHrefFile u' <> Href hf) (Txt tx) (AipDate date) (Amendment (trimSpaces amend))] + traverseDAP2 _ _ = + mempty + traverseAeroProcChartsTOCDAP :: + Href + -> TagTreePos String + -> [(String, DAPEntries)] + traverseAeroProcChartsTOCDAP u' (TagTreePos (TagBranch "h3" _ [TagLeaf (TagText aerodrome)]) _ (TagLeaf (TagText _) : TagBranch "table" _ es : _) _) = + [(aerodrome, _Wrapped # (fromTagTree <$> es >>= (^. _Wrapped) . traverseTree (traverseDAP2 u')))] + traverseAeroProcChartsTOCDAP _ _ = + mempty + in do dap1 <- traverseAipHtmlRequestGet traverseDAP u + let ts :: + (DAPType', Href) + -> AipCon [DAPDoc] + ts (t', u') = + let noaerodrome dt = + (\x -> [DAPDoc dt u' x]) <$> traverseAipHtmlRequestGet (traverseDAP2 u') u' + in case t' of + SpecNotManTOCDAP -> + noaerodrome SpecNotManTOCDAP + ChecklistTOCDAP -> + noaerodrome ChecklistTOCDAP + LegendInfoTablesTOCDAP -> + noaerodrome LegendInfoTablesTOCDAP + AeroProcChartsTOCDAP () -> + do f <- doGetRequest u' "" + let es :: + TagTree String + -> [(String, DAPEntries)] + es = + traverseTree (traverseAeroProcChartsTOCDAP u') . fromTagTree + docs :: + [DAPDoc] + docs = + parseTree f >>= \x -> + es x >>= \(s', e') -> + pure (DAPDoc (AeroProcChartsTOCDAP s') u' e') + pure docs + DAPDocs . join <$> mapM ts dap1 + in Aip_DAP u t <$> eachDAP +runDAP (Aip_DAH u x) = + pure (Aip_DAH u x) +runDAP (Aip_ERSA u t x) = + pure (Aip_ERSA u t x) +runDAP (Aip_AandB_Charts x) = + pure (Aip_AandB_Charts x) + +runERSA :: + AipDocument book charts sup_aic dap ersa + -> AipCon (AipDocument book charts sup_aic dap Ersa) +runERSA (Aip_Book u t x) = + pure (Aip_Book u t x) +runERSA (Aip_Charts u t x) = + pure (Aip_Charts u t x) +runERSA (Aip_SUP_AIC u x) = + pure (Aip_SUP_AIC u x) +runERSA (Aip_Summary_SUP_AIC u x) = + pure (Aip_Summary_SUP_AIC u x) +runERSA (Aip_DAP u t x) = + pure (Aip_DAP u t x) +runERSA (Aip_DAH u x) = + pure (Aip_DAH u x) +runERSA (Aip_ERSA u t _) = + let traverseErsaAerodromes :: + TagTreePos String + -> ErsaAerodromes + traverseErsaAerodromes (TagTreePos (TagBranch "tr" [] (TagLeaf (TagText _) : TagBranch "td" _ [TagLeaf (TagText aerodrome)] : TagLeaf (TagText _) : TagBranch "td" _ [TagLeaf (TagText _), TagBranch "a" [("href", fac_href)] [TagLeaf (TagText "FAC")], TagLeaf (TagText _)] : r)) _ _ _) = + ErsaAerodromes [ + ErsaAerodrome + aerodrome + (Href fac_href) $ + case r of + TagLeaf (TagText _) : TagBranch "td" _ [TagLeaf (TagText _), TagBranch "a" [("href", rds_href)] [TagLeaf (TagText "RDS")], TagLeaf (TagText _)] : _ : _ -> + Just (Href rds_href) + _ -> + Nothing] + traverseErsaAerodromes _ = + ErsaAerodromes [] + traverseErsaDocs :: + TagTreePos String + -> ListItemLinks + traverseErsaDocs = + traverseListItems (isSuffixOf ".pdf") + traverseErsaCompletes :: + TagTreePos String + -> [Href] + traverseErsaCompletes (TagTreePos (TagBranch "td" _ [TagLeaf (TagText _),TagBranch "a" [("href", u')] [TagLeaf (TagText "ERSA Complete")],TagLeaf (TagText _)]) _ _ _) = + [Href u' ] + traverseErsaCompletes _ = + [] + in Aip_ERSA u t <$> traverseAipHtmlRequestGet (Ersa <$> traverseErsaDocs <*> traverseErsaAerodromes <*> traverseErsaCompletes) u +runERSA (Aip_AandB_Charts x) = + pure (Aip_AandB_Charts x) + +runAipDocument :: + AipDocument book charts sup_aic dap ersa + -> AipCon AipDocument2 +runAipDocument = + runBook >=> runCharts >=> runSUP_AIC >=> runDAP >=> runERSA + +traverseListItems :: + (String -> Bool) + -> TagTreePos String + -> ListItemLinks +traverseListItems p (TagTreePos (TagBranch "ul" [] x) _ _ _) = + let li (TagBranch "li" [] [TagBranch "a" [("href", hf)] [TagLeaf (TagText tx)]]) = + if p hf + then + [ListItemLink (Href hf) (Txt tx)] + else + [] + li _ = + [] + in ListItemLinks (x >>= li) +traverseListItems _ _ = + ListItemLinks [] + +traverseAipHtmlRequestGet :: + (HStream str, Monoid a, Text.StringLike.StringLike str) => + (TagTreePos str -> a) + -> Href + -> AipCon a +traverseAipHtmlRequestGet k (Href u) = + foldMap (traverseTree k . fromTagTree) . parseTree <$> doGetRequest (Href u) "" diff --git a/src/Data/Aviation/Aip/AipDocuments.hs b/src/Data/Aviation/Aip/AipDocuments.hs --- a/src/Data/Aviation/Aip/AipDocuments.hs +++ b/src/Data/Aviation/Aip/AipDocuments.hs @@ -1,1197 +1,190 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Data.Aviation.Aip.AipDocuments( - AipDocuments(..) -, writeAipDocuments -, requestAipDocuments -, getAipDocuments -) where - -import Control.Monad.IO.Class(liftIO) -import Data.ByteString(ByteString) -import Data.Maybe(maybeToList) -import System.FilePath(()) -import System.IO(Handle) -import Control.Monad.Trans.Except(ExceptT) -import Data.Aviation.Aip.AipDate(uriAipDate) -import Data.Aviation.Aip.AipDocument(AipDocument(AipDocument), requestAipDocument) -import Data.Aviation.Aip.ConnErrorHttp4xx(ConnErrorHttp4xx) -import Data.Aviation.Aip.Ersa(Ersa(Ersa)) -import Data.Aviation.Aip.Ersas(Ersas(Ersas), parseAipTree) -import Data.Aviation.Aip.HttpRequest(requestAipContents, aipRequestGet) -import Papa - -newtype AipDocuments ty = - AipDocuments - [AipDocument ty] - deriving Show - -makeWrapped ''AipDocuments - -writeAipDocuments :: - Handle -- ^ log error - -> Handle -- ^ log out - -> FilePath - -> ExceptT ConnErrorHttp4xx IO [FilePath] -writeAipDocuments errlog outlog dir = - requestAipContents >>= liftIO . requestAipDocuments errlog outlog . getAipDocuments dir . parseAipTree - -requestAipDocuments :: - Handle -- ^ log error - -> Handle -- ^ log out - -> AipDocuments ByteString - -> IO [FilePath] -requestAipDocuments errlog outlog (AipDocuments ds) = - (>>= maybeToList) <$> mapM (requestAipDocument errlog outlog) ds - -getAipDocuments :: - FilePath -- output directory - -> Ersas - -> AipDocuments ByteString -getAipDocuments dir (Ersas ersas) = - let simpleAipDocuments = - [ - -- AIP Book - "aip/complete.pdf" - , "aip/general.pdf" - , "aip/enroute.pdf" - , "aip/aerodrome.pdf" - , "aip/cover.pdf" - , "aip/index.pdf" - -- AIP Charts (current) - , "aipchart/erch/erch1.pdf" - , "aipchart/erch/erch2.pdf" - , "aipchart/erch/erch3.pdf" - , "aipchart/erch/erch4.pdf" - , "aipchart/erch/erch5.pdf" - , "aipchart/ercl/ercl1.pdf" - , "aipchart/ercl/ercl2.pdf" - , "aipchart/ercl/ercl3.pdf" - , "aipchart/ercl/ercl4.pdf" - , "aipchart/ercl/ercl5.pdf" - , "aipchart/ercl/ercl6.pdf" - , "aipchart/ercl/ercl7.pdf" - , "aipchart/ercl/ercl8.pdf" - , "aipchart/pca/PCA_back.pdf" - , "aipchart/pca/PCA_front.pdf" - , "aipchart/tac/tac1.pdf" - , "aipchart/tac/tac2.pdf" - , "aipchart/tac/tac3.pdf" - , "aipchart/tac/tac4.pdf" - , "aipchart/tac/tac5.pdf" - , "aipchart/tac/tac6.pdf" - , "aipchart/tac/tac7.pdf" - , "aipchart/tac/tac8.pdf" - , "aipchart/vnc/Adelaide_VNC.pdf" - , "aipchart/vnc/Brisbane_VNC.pdf" - , "aipchart/vnc/Bundaberg_VNC.pdf" - , "aipchart/vnc/Cairns_VNC.pdf" - , "aipchart/vnc/Darwin_VNC.pdf" - , "aipchart/vnc/Deniliquin_VNC.pdf" - , "aipchart/vnc/Hobart_VNC.pdf" - , "aipchart/vnc/Launceston_VNC.pdf" - , "aipchart/vnc/Melbourne_VNC.pdf" - , "aipchart/vnc/Newcastle_VNC.pdf" - , "aipchart/vnc/Perth_VNC.pdf" - , "aipchart/vnc/Rockhampton_VNC.pdf" - , "aipchart/vnc/Sydney_VNC.pdf" - , "aipchart/vnc/Tindal_VNC.pdf" - , "aipchart/vnc/Townsville_VNC.pdf" - , "aipchart/vtc/Adelaide_VTC.pdf" - , "aipchart/vtc/Albury_VTC.pdf" - , "aipchart/vtc/AliceSprings_Uluru_VTC.pdf" - , "aipchart/vtc/Brisbane_Sunshine_VTC.pdf" - , "aipchart/vtc/Broome_VTC.pdf" - , "aipchart/vtc/Cairns_VTC.pdf" - , "aipchart/vtc/Canberra_VTC.pdf" - , "aipchart/vtc/Coffs_Harbour_VTC.pdf" - , "aipchart/vtc/Darwin_VTC.pdf" - , "aipchart/vtc/Gold_Coast_VTC.pdf" - , "aipchart/vtc/Hobart_VTC.pdf" - , "aipchart/vtc/Karratha_VTC.pdf" - , "aipchart/vtc/Launceston_VTC.pdf" - , "aipchart/vtc/Mackay_VTC.pdf" - , "aipchart/vtc/Melbourne_VTC.pdf" - , "aipchart/vtc/Newcastle_Williamtown_VTC.pdf" - , "aipchart/vtc/Oakey_Bris_VTC.pdf" - , "aipchart/vtc/perth_legend.pdf" - , "aipchart/vtc/Perth_VTC.pdf" - , "aipchart/vtc/Rockhampton_VTC.pdf" - , "aipchart/vtc/Sydney_VTC.pdf" - , "aipchart/vtc/Tamworth_VTC.pdf" - , "aipchart/vtc/Townsville_VTC.pdf" - , "aipchart/vtc/Whitsunday_VTC.pdf" - -- DAP - , "dap/SpecNotManTOC.htm" - , "dap/ChecklistTOC.htm" - , "dap/LegendInfoTablesTOC.htm" - , "dap/AeroProcChartsTOC.htm" - -- DAH - , "dah/dah.pdf" - -- Precision Approach Terrain Charts and Type A & Type B Obstacle Charts - , "chart/TypeAandBCharts.pdf" - ] - ersaprelim = - [ - "GUID_ersa-fac-1-3" - , "GUID_ersa-fac-1-4" - , "GUID_ersa-fac-1-5" - , "PRD_" - , "LND_" - , "IFR_" - , "VFR_" - , "GUID_ersa-fac-2-2" - , "GUID_ersa-fac-2-3" - , "GUID_ersa-fac-2-4" - , "GUID_ersa-fac-2-5" - , "GUID_ersa-fac-2-6" - , "GUID_ersa-fac-2-7" - , "GUID_ersa-fac-2-8" - , "GUID_ersa-fac-2-9" - , "GUID_ersa-fac-2-10" - , "GUID_ersa-fac-2-11" - , "GUID_ersa-fac-2-12" - , "GUID_ersa-fac-2-14" - ] - ersafac = - [ - "FAC_YADY" - , "FAC_ADAC" - , "FAC_YPAD" - , "FAC_YPPF" - , "FAC_YALG" - , "FAC_YABA" - , "FAC_YMAY" - , "FAC_YADG" - , "FAC_YBAS" - , "FAC_YAPH" - , "FAC_YAMT" - , "FAC_YAMB" - , "FAC_YANK" - , "FAC_YAMC" - , "FAC_YARA" - , "FAC_YARS" - , "FAC_YARG" - , "FAC_YARK" - , "FAC_YARM" - , "FAC_YARY" - , "FAC_YATN" - , "FAC_YAUG" - , "FAC_YAGD" - , "FAC_YAUR" - , "FAC_YMAV" - , "FAC_YAYE" - , "FAC_YAYR" - , "FAC_YBSS" - , "FAC_YBAU" - , "FAC_YBNS" - , "FAC_YBLC" - , "FAC_YBGO" - , "FAC_YBLT" - , "FAC_YLLE" - , "FAC_YBIU" - , "FAC_YBNA" - , "FAC_YBRN" - , "FAC_YBMY" - , "FAC_YBAD" - , "FAC_YBAB" - , "FAC_YBAR" - , "FAC_YBRY" - , "FAC_YBWX" - , "FAC_YBRS" - , "FAC_YBYL" - , "FAC_YBTH" - , "FAC_YBTI" - , "FAC_YBFT" - , "FAC_YBIE" - , "FAC_YBEB" - , "FAC_YBLU" - , "FAC_YBLA" - , "FAC_YBDG" - , "FAC_YBEO" - , "FAC_YBEE" - , "FAC_YBYS" - , "FAC_YBHL" - , "FAC_YBIR" - , "FAC_YBDV" - , "FAC_YBCK" - , "FAC_YBTR" - , "FAC_YBLP" - , "FAC_YBOI" - , "FAC_YBLL" - , "FAC_YBOM" - , "FAC_YBOC" - , "FAC_YBGD" - , "FAC_YBMI" - , "FAC_YBOA" - , "FAC_YBBT" - , "FAC_YBOR" - , "FAC_YBRL" - , "FAC_YBOU" - , "FAC_YBKE" - , "FAC_YBWN" - , "FAC_YBPI" - , "FAC_YBRW" - , "FAC_YBGR" - , "FAC_BNAC" - , "FAC_YBWW" - , "FAC_YBBN" - , "FAC_YBAF" - , "FAC_YBHI" - , "FAC_BML" - , "FAC_YBRM" - , "FAC_YBUN" - , "FAC_YBUD" - , "FAC_YBKT" - , "FAC_YBLN" - , "FAC_YCAB" - , "FAC_YCDH" - , "FAC_YCAG" - , "FAC_YBCS" - , "FAC_YCDR" - , "FAC_YCVG" - , "FAC_YSCN" - , "FAC_YCMH" - , "FAC_YCMW" - , "FAC_YSCB" - , "FAC_YCLQ" - , "FAC_YCEL" - , "FAC_YCAV" - , "FAC_YCDW" - , "FAC_YCAR" - , "FAC_YCAS" - , "FAC_YCTN" - , "FAC_YCDU" - , "FAC_YCNY" - , "FAC_YCES" - , "FAC_YCNK" - , "FAC_YBCV" - , "FAC_YCHT" - , "FAC_YCGO" - , "FAC_YCCA" - , "FAC_YCHK" - , "FAC_YPXM" - , "FAC_YCVA" - , "FAC_YCMT" - , "FAC_YCEE" - , "FAC_YCFN" - , "FAC_YCCY" - , "FAC_YUNY" - , "FAC_YCBA" - , "FAC_YCDE" - , "FAC_YCCT" - , "FAC_YPCC" - , "FAC_YCOE" - , "FAC_YCFS" - , "FAC_YCOH" - , "FAC_YOLA" - , "FAC_YCEM" - , "FAC_YCBR" - , "FAC_YCSV" - , "FAC_YCDO" - , "FAC_YCBP" - , "FAC_YCOO" - , "FAC_YCKN" - , "FAC_YCAH" - , "FAC_YCXA" - , "FAC_YPFT" - , "FAC_YCOM" - , "FAC_YBCM" - , "FAC_YCBB" - , "FAC_YCNM" - , "FAC_YCWA" - , "FAC_YCTM" - , "FAC_YCOR" - , "FAC_YCRG" - , "FAC_YCWL" - , "FAC_YCWR" - , "FAC_YCRN" - , "FAC_YCKI" - , "FAC_YCRL" - , "FAC_YCRY" - , "FAC_YCUE" - , "FAC_YCMM" - , "FAC_YCUN" - , "FAC_YCMU" - , "FAC_YCIN" - , "FAC_YDAY" - , "FAC_YDLO" - , "FAC_YDNI" - , "FAC_DNAC" - , "FAC_YPDN" - , "FAC_YDPD" - , "FAC_YDGU" - , "FAC_YDWF" - , "FAC_YDLV" - , "FAC_YDLT" - , "FAC_YDLQ" - , "FAC_YDEK" - , "FAC_YDBY" - , "FAC_YDPO" - , "FAC_YDBI" - , "FAC_YDOC" - , "FAC_YDVR" - , "FAC_YDOD" - , "FAC_YDOP" - , "FAC_YDMG" - , "FAC_YDOR" - , "FAC_YDRN" - , "FAC_YDRD" - , "FAC_YSDU" - , "FAC_YDKG" - , "FAC_YDBR" - , "FAC_YDKI" - , "FAC_YDUN" - , "FAC_YDRH" - , "FAC_YDRI" - , "FAC_YDYS" - , "FAC_YEJI" - , "FAC_YMES" - , "FAC_YECH" - , "FAC_YECB" - , "FAC_YPED" - , "FAC_YESD" - , "FAC_YELD" - , "FAC_YEQY" - , "FAC_YELN" - , "FAC_YESE" - , "FAC_YEML" - , "FAC_YMKT" - , "FAC_YEMP" - , "FAC_YENO" - , "FAC_YEHP" - , "FAC_YERN" - , "FAC_YEMG" - , "FAC_YESC" - , "FAC_YESP" - , "FAC_YEUO" - , "FAC_YEUA" - , "FAC_YEVD" - , "FAC_YEXM" - , "FAC_YFDN" - , "FAC_YFTZ" - , "FAC_YFLI" - , "FAC_YFBS" - , "FAC_YFRT" - , "FAC_YFTA" - , "FAC_YFDF" - , "FAC_YFRG" - , "FAC_YGAD" - , "FAC_YGPT" - , "FAC_YGAS" - , "FAC_YGAW" - , "FAC_YGAY" - , "FAC_YGTO" - , "FAC_YGTN" - , "FAC_YGEL" - , "FAC_YGIB" - , "FAC_YGLS" - , "FAC_YGIL" - , "FAC_YGIA" - , "FAC_YGIG" - , "FAC_YGLA" - , "FAC_YGLI" - , "FAC_YGNB" - , "FAC_YGLO" - , "FAC_YBCG" - , "FAC_YGGE" - , "FAC_YGDA" - , "FAC_YGWA" - , "FAC_YGDI" - , "FAC_YGLB" - , "FAC_YPGV" - , "FAC_YGFN" - , "FAC_YGRS" - , "FAC_YGKL" - , "FAC_YGRL" - , "FAC_YGDS" - , "FAC_YGTH" - , "FAC_YGTE" - , "FAC_YGDO" - , "FAC_YGDH" - , "FAC_YGYM" - , "FAC_YHAA" - , "FAC_YHLC" - , "FAC_YHML" - , "FAC_YBHM" - , "FAC_YHAW" - , "FAC_YHAY" - , "FAC_YHEC" - , "FAC_YHCS" - , "FAC_YHMB" - , "FAC_YHBA" - , "FAC_YHLS" - , "FAC_YMHB" - , "FAC_YCBG" - , "FAC_YHBK" - , "FAC_YSHW" - , "FAC_YHON" - , "FAC_YHOO" - , "FAC_YHPN" - , "FAC_YHID" - , "FAC_YHSM" - , "FAC_YHUG" - , "FAC_YHRD" - , "FAC_YIFY" - , "FAC_YILF" - , "FAC_YIGM" - , "FAC_YINJ" - , "FAC_YIKM" - , "FAC_YINN" - , "FAC_YIMT" - , "FAC_YIFL" - , "FAC_YIVL" - , "FAC_YISF" - , "FAC_YIVO" - , "FAC_YJAB" - , "FAC_YJAC" - , "FAC_YJST" - , "FAC_YJER" - , "FAC_YJBY" - , "FAC_YJIN" - , "FAC_YJLC" - , "FAC_YJDA" - , "FAC_YJUN" - , "FAC_YJNB" - , "FAC_YKDI" - , "FAC_YKBR" - , "FAC_YPKG" - , "FAC_YKKG" - , "FAC_YKAL" - , "FAC_YKBL" - , "FAC_YKML" - , "FAC_YKAR" - , "FAC_YPKA" - , "FAC_YKMB" - , "FAC_YKNG" - , "FAC_YKAT" - , "FAC_YKMP" - , "FAC_YKER" - , "FAC_YKHO" - , "FAC_YKDM" - , "FAC_YKID" - , "FAC_YKCY" - , "FAC_YKLE" - , "FAC_YIMB" - , "FAC_YKKN" - , "FAC_YKII" - , "FAC_YKRY" - , "FAC_YKCS" - , "FAC_YKSC" - , "FAC_YKIG" - , "FAC_YKBN" - , "FAC_YKOW" - , "FAC_YKUB" - , "FAC_YPKU" - , "FAC_YKTN" - , "FAC_YLCG" - , "FAC_YLEV" - , "FAC_YLJN" - , "FAC_YKEP" - , "FAC_YLMQ" - , "FAC_YLKE" - , "FAC_YLAK" - , "FAC_YLCK" - , "FAC_YLTV" - , "FAC_YMLT" - , "FAC_YLTN" - , "FAC_YLAW" - , "FAC_YLAH" - , "FAC_YPLM" - , "FAC_YLGU" - , "FAC_YLEC" - , "FAC_YLST" - , "FAC_YLEG" - , "FAC_YLEO" - , "FAC_YLED" - , "FAC_YLRD" - , "FAC_YLIL" - , "FAC_YLIS" - , "FAC_YLZI" - , "FAC_YLHR" - , "FAC_YLCS" - , "FAC_YLRE" - , "FAC_YLHI" - , "FAC_YLOR" - , "FAC_YLOH" - , "FAC_YLOX" - , "FAC_YLYK" - , "FAC_YMAA" - , "FAC_YBMK" - , "FAC_YMND" - , "FAC_YMLD" - , "FAC_YMCO" - , "FAC_YMNG" - , "FAC_YMGD" - , "FAC_YMJM" - , "FAC_YMFD" - , "FAC_YMBL" - , "FAC_YMBA" - , "FAC_YMGT" - , "FAC_YMGR" - , "FAC_YALA" - , "FAC_YMRE" - , "FAC_YMYB" - , "FAC_YMBU" - , "FAC_YMHU" - , "FAC_YMEK" - , "FAC_MLAC" - , "FAC_YMML" - , "FAC_YMEN" - , "FAC_YMMB" - , "FAC_YMEL" - , "FAC_YMET" - , "FAC_YMEI" - , "FAC_YMER" - , "FAC_YMDN" - , "FAC_YMMU" - , "FAC_YMIA" - , "FAC_YMLS" - , "FAC_YMGB" - , "FAC_YMIO" - , "FAC_YMCT" - , "FAC_YMMN" - , "FAC_YMDR" - , "FAC_YMPA" - , "FAC_YMIB" - , "FAC_YMIT" - , "FAC_YITT" - , "FAC_YMIG" - , "FAC_YMMO" - , "FAC_YMOD" - , "FAC_YMNK" - , "FAC_YMTO" - , "FAC_YOOM" - , "FAC_YMOO" - , "FAC_YMRB" - , "FAC_YMRW" - , "FAC_YMOR" - , "FAC_YMNY" - , "FAC_YMTI" - , "FAC_YMRY" - , "FAC_YMBT" - , "FAC_YMDY" - , "FAC_YMCL" - , "FAC_YMTG" - , "FAC_YGON" - , "FAC_YMHL" - , "FAC_YHOT" - , "FAC_YMHO" - , "FAC_YMHW" - , "FAC_YBMA" - , "FAC_YMNE" - , "FAC_YMOG" - , "FAC_YMSF" - , "FAC_YMOU" - , "FAC_YMDG" - , "FAC_YMWA" - , "FAC_YMDA" - , "FAC_YMGI" - , "FAC_YLMU" - , "FAC_YMRG" - , "FAC_YMBD" - , "FAC_YMUL" - , "FAC_YMAE" - , "FAC_YMMI" - , "FAC_YMUR" - , "FAC_YMTB" - , "FAC_YMYU" - , "FAC_YNKR" - , "FAC_YNGW" - , "FAC_YNAP" - , "FAC_YNRC" - , "FAC_YNRB" - , "FAC_YNBR" - , "FAC_YNAR" - , "FAC_YNRG" - , "FAC_YNRM" - , "FAC_YNEY" - , "FAC_YNRH" - , "FAC_YNWN" - , "FAC_YNGU" - , "FAC_YNHL" - , "FAC_YCNF" - , "FAC_YNSH" - , "FAC_YSNF" - , "FAC_YNTN" - , "FAC_YNSM" - , "FAC_YNWF" - , "FAC_YNTM" - , "FAC_YNPE" - , "FAC_YNOV" - , "FAC_YSNW" - , "FAC_YNUL" - , "FAC_YNUB" - , "FAC_YNUM" - , "FAC_YNYN" - , "FAC_YBOK" - , "FAC_YOAY" - , "FAC_YOCA" - , "FAC_YOEN" - , "FAC_YOLD" - , "FAC_YOLW" - , "FAC_YOOD" - , "FAC_YORG" - , "FAC_YOEH" - , "FAC_YORB" - , "FAC_YORR" - , "FAC_YOSB" - , "FAC_YPAC" - , "FAC_YPAM" - , "FAC_YPAY" - , "FAC_YPBO" - , "FAC_YPKS" - , "FAC_YPEA" - , "FAC_YPEF" - , "FAC_PHAC" - , "FAC_YPPH" - , "FAC_YPJT" - , "FAC_YPTB" - , "FAC_YPBH" - , "FAC_YPID" - , "FAC_YPNN" - , "FAC_YPWH" - , "FAC_YPLU" - , "FAC_YMPC" - , "FAC_YPCE" - , "FAC_YPOK" - , "FAC_YPMP" - , "FAC_YPAG" - , "FAC_POCA" - , "FAC_YPPD" - , "FAC_YPKT" - , "FAC_YPLC" - , "FAC_YPMQ" - , "FAC_YPIR" - , "FAC_YPOD" - , "FAC_YPMH" - , "FAC_YBPN" - , "FAC_YPKL" - , "FAC_YPUG" - , "FAC_YQNS" - , "FAC_YQLP" - , "FAC_YQDI" - , "FAC_YQRN" - , "FAC_YRNG" - , "FAC_YNRV" - , "FAC_YRYP" - , "FAC_YRED" - , "FAC_YREN" - , "FAC_YSRI" - , "FAC_YRMD" - , "FAC_YRID" - , "FAC_YRBE" - , "FAC_YRBK" - , "FAC_YROB" - , "FAC_YROI" - , "FAC_YBRK" - , "FAC_YRLL" - , "FAC_YROM" - , "FAC_YRSY" - , "FAC_YRAY" - , "FAC_YRSB" - , "FAC_YRSH" - , "FAC_YRTI" - , "FAC_YRNS" - , "FAC_YRPA" - , "FAC_YRTP" - , "FAC_YRYL" - , "FAC_YSII" - , "FAC_YSTA" - , "FAC_YSGE" - , "FAC_YSTH" - , "FAC_YSAM" - , "FAC_YBSG" - , "FAC_YSCO" - , "FAC_YSCA" - , "FAC_YSLK" - , "FAC_YSEN" - , "FAC_YSHK" - , "FAC_YSHG" - , "FAC_YSHT" - , "FAC_YSHR" - , "FAC_YSGT" - , "FAC_YSMI" - , "FAC_YSNB" - , "FAC_YSOL" - , "FAC_YSMB" - , "FAC_YSGW" - , "FAC_YGBI" - , "FAC_YSGR" - , "FAC_YSCR" - , "FAC_YSPT" - , "FAC_YSPK" - , "FAC_YSPI" - , "FAC_YSPE" - , "FAC_YSWL" - , "FAC_YSFG" - , "FAC_YSTO" - , "FAC_YSRN" - , "FAC_YKBY" - , "FAC_YSNY" - , "FAC_YSRD" - , "FAC_YBSU" - , "FAC_YSRT" - , "FAC_YSWB" - , "FAC_YSWH" - , "FAC_YSSY" - , "FAC_YSBK" - , "FAC_YTMB" - , "FAC_YSTW" - , "FAC_YTMN" - , "FAC_YTAA" - , "FAC_YTRE" - , "FAC_YTAM" - , "FAC_YTEF" - , "FAC_YTEM" - , "FAC_YTNK" - , "FAC_YTNG" - , "FAC_YTGM" - , "FAC_YTGT" - , "FAC_YLKS" - , "FAC_YTMO" - , "FAC_YVAL" - , "FAC_YTDR" - , "FAC_YTHY" - , "FAC_YTIB" - , "FAC_YTLP" - , "FAC_YTBR" - , "FAC_YPTN" - , "FAC_YTOC" - , "FAC_YTDN" - , "FAC_YTKS" - , "FAC_YTWN" - , "FAC_YTWB" - , "FAC_YTQY" - , "FAC_YTOT" - , "FAC_YBTL" - , "FAC_YTEE" - , "FAC_YTRA" - , "FAC_YTTI" - , "FAC_YTFA" - , "FAC_YTST" - , "FAC_YTUY" - , "FAC_YTBB" - , "FAC_YTMU" - , "FAC_YTPK" - , "FAC_YTYA" - , "FAC_YTYH" - , "FAC_YUDA" - , "FAC_YUDG" - , "FAC_YVRS" - , "FAC_YVRD" - , "FAC_YSWG" - , "FAC_YWHG" - , "FAC_YWKI" - , "FAC_YWCH" - , "FAC_YWLG" - , "FAC_YWAG" - , "FAC_YWGT" - , "FAC_YWBR" - , "FAC_YWRL" - , "FAC_YWKW" - , "FAC_YWVA" - , "FAC_YWBS" - , "FAC_YWBI" - , "FAC_YWKB" - , "FAC_YWRN" - , "FAC_YWBL" - , "FAC_YWCK" - , "FAC_YWTL" - , "FAC_YWTB" - , "FAC_YWSG" - , "FAC_YWAV" - , "FAC_YWBN" - , "FAC_YBWP" - , "FAC_YWEL" - , "FAC_YWTO" - , "FAC_YANG" - , "FAC_WMD" - , "FAC_YWSL" - , "FAC_YWWL" - , "FAC_YWST" - , "FAC_YWHC" - , "FAC_YWHA" - , "FAC_YWCA" - , "FAC_YWMC" - , "FAC_YWIS" - , "FAC_YWLM" - , "FAC_YWLU" - , "FAC_YWDG" - , "FAC_YWDH" - , "FAC_YWTN" - , "FAC_YWVR" - , "FAC_YWOL" - , "FAC_YWHP" - , "FAC_YWND" - , "FAC_YWDL" - , "FAC_YWWI" - , "FAC_YPWR" - , "FAC_YWMP" - , "FAC_YWUD" - , "FAC_YWYA" - , "FAC_YWYF" - , "FAC_YWYM" - , "FAC_YWYY" - , "FAC_YWYR" - , "FAC_YYMI" - , "FAC_YYBK" - , "FAC_YYRM" - , "FAC_YYWG" - , "FAC_YYKI" - , "FAC_YYNG" - , "FAC_YYND" - ] - ersards = - [ - "RDS_YPAD" - , "RDS_YPPF" - , "RDS_YABA" - , "RDS_YMAY" - , "RDS_YBAS" - , "RDS_YAPH" - , "RDS_YAMB" - , "RDS_YARA" - , "RDS_YARG" - , "RDS_YARM" - , "RDS_YAUR" - , "RDS_YMAV" - , "RDS_YAYE" - , "RDS_YBNS" - , "RDS_YBGO" - , "RDS_YBLT" - , "RDS_YLLE" - , "RDS_YBNA" - , "RDS_YBRN" - , "RDS_YBAR" - , "RDS_YBRY" - , "RDS_YBWX" - , "RDS_YBTH" - , "RDS_YBTI" - , "RDS_YBIE" - , "RDS_YBLU" - , "RDS_YBLA" - , "RDS_YBDG" - , "RDS_YBIR" - , "RDS_YBDV" - , "RDS_YBCK" - , "RDS_YBGD" - , "RDS_YBOU" - , "RDS_YBKE" - , "RDS_YBWN" - , "RDS_YBRW" - , "RDS_YBWW" - , "RDS_YBBN" - , "RDS_YBAF" - , "RDS_YBHI" - , "RDS_YBRM" - , "RDS_YBUN" - , "RDS_YBUD" - , "RDS_YBKT" - , "RDS_YBLN" - , "RDS_YBCS" - , "RDS_YSCN" - , "RDS_YCMW" - , "RDS_YSCB" - , "RDS_YCAR" - , "RDS_YCDU" - , "RDS_YCNY" - , "RDS_YCNK" - , "RDS_YBCV" - , "RDS_YCHT" - , "RDS_YCGO" - , "RDS_YCCA" - , "RDS_YCHK" - , "RDS_YPXM" - , "RDS_YCMT" - , "RDS_YCEE" - , "RDS_YCCY" - , "RDS_YCBA" - , "RDS_YPCC" - , "RDS_YCOE" - , "RDS_YCFS" - , "RDS_YCDO" - , "RDS_YCBP" - , "RDS_YCKN" - , "RDS_YCAH" - , "RDS_YCOM" - , "RDS_YCBB" - , "RDS_YCNM" - , "RDS_YCWA" - , "RDS_YCTM" - , "RDS_YCOR" - , "RDS_YCRG" - , "RDS_YCWR" - , "RDS_YCKI" - , "RDS_YCUN" - , "RDS_YCMU" - , "RDS_YCIN" - , "RDS_YDLO" - , "RDS_YPDN" - , "RDS_YDGU" - , "RDS_YDLQ" - , "RDS_YDBY" - , "RDS_YDPO" - , "RDS_YDBI" - , "RDS_YDOD" - , "RDS_YDMG" - , "RDS_YSDU" - , "RDS_YDKG" - , "RDS_YEJI" - , "RDS_YMES" - , "RDS_YECH" - , "RDS_YPED" - , "RDS_YELD" - , "RDS_YEML" - , "RDS_YESP" - , "RDS_YFTZ" - , "RDS_YFLI" - , "RDS_YFBS" - , "RDS_YFRT" - , "RDS_YFTA" - , "RDS_YFDF" - , "RDS_YGPT" - , "RDS_YGAY" - , "RDS_YGTN" - , "RDS_YGEL" - , "RDS_YGIA" - , "RDS_YGIG" - , "RDS_YGLA" - , "RDS_YGLI" - , "RDS_YBCG" - , "RDS_YGGE" - , "RDS_YGDA" - , "RDS_YGDI" - , "RDS_YGLB" - , "RDS_YPGV" - , "RDS_YGFN" - , "RDS_YGRS" - , "RDS_YGTH" - , "RDS_YGTE" - , "RDS_YGDH" - , "RDS_YHLC" - , "RDS_YHML" - , "RDS_YBHM" - , "RDS_YHAY" - , "RDS_YHBA" - , "RDS_YMHB" - , "RDS_YHPN" - , "RDS_YHID" - , "RDS_YHSM" - , "RDS_YHUG" - , "RDS_YIFL" - , "RDS_YIVL" - , "RDS_YJAB" - , "RDS_YJAC" - , "RDS_YJLC" - , "RDS_YJUN" - , "RDS_YKBR" - , "RDS_YPKG" - , "RDS_YKKG" - , "RDS_YKAL" - , "RDS_YKAR" - , "RDS_YPKA" - , "RDS_YKMB" - , "RDS_YKNG" - , "RDS_YKMP" - , "RDS_YKER" - , "RDS_YIMB" - , "RDS_YKII" - , "RDS_YKRY" - , "RDS_YKSC" - , "RDS_YKOW" - , "RDS_YPKU" - , "RDS_YLCG" - , "RDS_YLEV" - , "RDS_YLTV" - , "RDS_YMLT" - , "RDS_YLTN" - , "RDS_YPLM" - , "RDS_YLEC" - , "RDS_YLST" - , "RDS_YLEO" - , "RDS_YLRD" - , "RDS_YLIS" - , "RDS_YLHR" - , "RDS_YLRE" - , "RDS_YLHI" - , "RDS_YLOX" - , "RDS_YBMK" - , "RDS_YMND" - , "RDS_YMCO" - , "RDS_YMNG" - , "RDS_YMGD" - , "RDS_YMJM" - , "RDS_YMBA" - , "RDS_YMYB" - , "RDS_YMBU" - , "RDS_YMHU" - , "RDS_YMEK" - , "RDS_YMML" - , "RDS_YMEN" - , "RDS_YMMB" - , "RDS_YMER" - , "RDS_YMMU" - , "RDS_YMIA" - , "RDS_YMLS" - , "RDS_YMGB" - , "RDS_YOOM" - , "RDS_YMRB" - , "RDS_YMRW" - , "RDS_YMOR" - , "RDS_YMTI" - , "RDS_YMRY" - , "RDS_YMTG" - , "RDS_YGON" - , "RDS_YHOT" - , "RDS_YBMA" - , "RDS_YMNE" - , "RDS_YMOG" - , "RDS_YMDG" - , "RDS_YMUL" - , "RDS_YMMI" - , "RDS_YNRC" - , "RDS_YNBR" - , "RDS_YNAR" - , "RDS_YNRM" - , "RDS_YNWN" - , "RDS_YNGU" - , "RDS_YNHL" - , "RDS_YCNF" - , "RDS_YSNF" - , "RDS_YNTN" - , "RDS_YNSM" - , "RDS_YNPE" - , "RDS_YNOV" - , "RDS_YSNW" - , "RDS_YNUM" - , "RDS_YNYN" - , "RDS_YBOK" - , "RDS_YOEN" - , "RDS_YOLD" - , "RDS_YOLW" - , "RDS_YORG" - , "RDS_YORB" - , "RDS_YOSB" - , "RDS_YPAM" - , "RDS_YPBO" - , "RDS_YPKS" - , "RDS_YPEA" - , "RDS_YPPH" - , "RDS_YPJT" - , "RDS_YPLU" - , "RDS_YMPC" - , "RDS_YPCE" - , "RDS_YPMP" - , "RDS_YPAG" - , "RDS_YPPD" - , "RDS_YPKT" - , "RDS_YPLC" - , "RDS_YPMQ" - , "RDS_YPIR" - , "RDS_YPOD" - , "RDS_YPMH" - , "RDS_YBPN" - , "RDS_YQLP" - , "RDS_YQDI" - , "RDS_YRNG" - , "RDS_YNRV" - , "RDS_YREN" - , "RDS_YSRI" - , "RDS_YRMD" - , "RDS_YROI" - , "RDS_YBRK" - , "RDS_YROM" - , "RDS_YRTI" - , "RDS_YSII" - , "RDS_YSTA" - , "RDS_YSGE" - , "RDS_YSTH" - , "RDS_YBSG" - , "RDS_YSCO" - , "RDS_YSLK" - , "RDS_YSHK" - , "RDS_YSHT" - , "RDS_YSNB" - , "RDS_YSOL" - , "RDS_YGBI" - , "RDS_YSCR" - , "RDS_YSPT" - , "RDS_YSPE" - , "RDS_YSWL" - , "RDS_YSRN" - , "RDS_YKBY" - , "RDS_YSRD" - , "RDS_YBSU" - , "RDS_YSWH" - , "RDS_YSSY" - , "RDS_YSBK" - , "RDS_YSTW" - , "RDS_YTRE" - , "RDS_YTAM" - , "RDS_YTEF" - , "RDS_YTEM" - , "RDS_YTNK" - , "RDS_YTNG" - , "RDS_YTGM" - , "RDS_YTGT" - , "RDS_YTMO" - , "RDS_YTIB" - , "RDS_YPTN" - , "RDS_YTOC" - , "RDS_YTWB" - , "RDS_YBTL" - , "RDS_YTEE" - , "RDS_YTRA" - , "RDS_YTTI" - , "RDS_YTST" - , "RDS_YTBB" - , "RDS_YTMU" - , "RDS_YSWG" - , "RDS_YWKI" - , "RDS_YWLG" - , "RDS_YWGT" - , "RDS_YWBR" - , "RDS_YWKB" - , "RDS_YWRN" - , "RDS_YWBL" - , "RDS_YWCK" - , "RDS_YBWP" - , "RDS_YWTO" - , "RDS_YANG" - , "RDS_YWSL" - , "RDS_YWWL" - , "RDS_YWHA" - , "RDS_YWLM" - , "RDS_YWLU" - , "RDS_YWDG" - , "RDS_YWDH" - , "RDS_YWTN" - , "RDS_YWOL" - , "RDS_YPWR" - , "RDS_YWUD" - , "RDS_YWYF" - , "RDS_YWYM" - , "RDS_YWYY" - , "RDS_YYRM" - , "RDS_YYWG" - , "RDS_YYKI" - , "RDS_YYNG" - ] - allersa = - (ersaprelim ++ ersafac ++ ersards) >>= \f -> - ["current", "pending"] >>= \q -> - ersas >>= \(Ersa _ d) -> - let req = concat [q, "/ersa/", f, "_", uriAipDate d, ".pdf"] - in pure (AipDocument (aipRequestGet req "") (dir req)) - allSimpleAipDocuments = - simpleAipDocuments >>= \x -> - ["current", "pending"] >>= \q -> - let req = concat [q, "/", x] - in pure (AipDocument (aipRequestGet req "") (dir req)) - in AipDocuments - (allSimpleAipDocuments ++ allersa) +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.AipDocuments( + AipDocuments(..) +, AipDocuments1 +, AipDocuments2 +, AsAipDocuments(..) +, FoldAipDocuments(..) +, GetAipDocuments(..) +, SetAipDocuments(..) +, ManyAipDocuments(..) +, HasAipDocuments(..) +, IsAipDocuments(..) +) where + +import Control.Category((.), id) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withArray) +import Data.Aviation.Aip.Aip_SUP_and_AICs(Aip_SUP_and_AICs) +import Data.Aviation.Aip.AipDocument(AipDocument) +import Data.Aviation.Aip.DAPDocs(DAPDocs) +import Data.Aviation.Aip.Ersa(Ersa) +import Data.Aviation.Aip.Href(SetHref, FoldHref(_FoldHref), ManyHref(_ManyHref)) +import Data.Aviation.Aip.ListItemLinks(ListItemLinks) +import Data.Aviation.Aip.ListItemLinks1(ListItemLinks1) +import Data.Eq(Eq) +import Data.Foldable(toList) +import Data.Function(($)) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Prelude(Show) + +newtype AipDocuments book charts sup_aic dap ersa = + AipDocuments + [AipDocument book charts sup_aic dap ersa] + deriving (Eq, Ord, Show) + +instance Semigroup (AipDocuments book charts sup_aic dap ersa) where + AipDocuments x <> AipDocuments y = + AipDocuments (x <> y) + +instance Monoid (AipDocuments book charts sup_aic dap ersa) where + mappend = + (<>) + mempty = + AipDocuments [] + +instance Wrapped (AipDocuments book charts sup_aic dap ersa) where + type Unwrapped (AipDocuments book charts sup_aic dap ersa) = + [AipDocument book charts sup_aic dap ersa] + _Wrapped' = + iso (\(AipDocuments x) -> x) AipDocuments + +instance (AipDocuments book charts sup_aic dap ersa) ~ x => + Rewrapped (AipDocuments book charts sup_aic dap ersa) x + +type AipDocuments1 = + AipDocuments () () () () () + +type AipDocuments2 = + AipDocuments ListItemLinks ListItemLinks1 Aip_SUP_and_AICs DAPDocs Ersa + +instance (FromJSON book, FromJSON charts, FromJSON sup_aic, FromJSON dap, FromJSON ersa) => FromJSON (AipDocuments book charts sup_aic dap ersa) where + parseJSON = + withArray "AipDocuments" $ \v -> + AipDocuments <$> traverse parseJSON (toList v) + +instance (ToJSON book, ToJSON charts, ToJSON sup_aic, ToJSON dap, ToJSON ersa) => ToJSON (AipDocuments book charts sup_aic dap ersa) where + toJSON (AipDocuments x) = + toJSON x + +instance Cons (AipDocuments book charts sup_aic dap ersa) (AipDocuments book charts sup_aic dap ersa) (AipDocument book charts sup_aic dap ersa) (AipDocument book charts sup_aic dap ersa) where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc (AipDocuments book charts sup_aic dap ersa) (AipDocuments book charts sup_aic dap ersa) (AipDocument book charts sup_aic dap ersa) (AipDocument book charts sup_aic dap ersa) where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each (AipDocuments book charts sup_aic dap ersa) (AipDocuments book charts sup_aic dap ersa) (AipDocument book charts sup_aic dap ersa) (AipDocument book charts sup_aic dap ersa) where + each = + _Wrapped . each + +instance Reversing (AipDocuments book charts sup_aic dap ersa) where + reversing = + _Wrapped %~ reversing + +instance Plated (AipDocuments book charts sup_aic dap ersa) where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue (AipDocuments book charts sup_aic dap ersa) = (AipDocument book charts sup_aic dap ersa) +type instance Index (AipDocuments book charts sup_aic dap ersa) = Int +instance Ixed (AipDocuments book charts sup_aic dap ersa) where + ix i = + _Wrapped . ix i + +class ManyAipDocuments a => AsAipDocuments a where + _AipDocuments :: + Prism (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocuments book charts sup_aic dap ersa) (AipDocuments book' charts' sup_aic' dap' ersa') + default _AipDocuments :: + IsAipDocuments a => + Prism (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocuments book charts sup_aic dap ersa) (AipDocuments book' charts' sup_aic' dap' ersa') + _AipDocuments = + _IsAipDocuments + +instance AsAipDocuments AipDocuments where + _AipDocuments = + id + +class FoldAipDocuments a where + _FoldAipDocuments :: + Fold (a book charts sup_aic dap ersa) (AipDocuments book charts sup_aic dap ersa) + +instance FoldAipDocuments AipDocuments where + _FoldAipDocuments = + id + +class FoldAipDocuments a => GetAipDocuments a where + _GetAipDocuments :: + Getter (a book charts sup_aic dap ersa) (AipDocuments book charts sup_aic dap ersa) + default _GetAipDocuments :: + HasAipDocuments a => + Getter (a book charts sup_aic dap ersa) (AipDocuments book charts sup_aic dap ersa) + _GetAipDocuments = + aipDocuments + +instance GetAipDocuments AipDocuments where + _GetAipDocuments = + id + +class SetAipDocuments a where + _SetAipDocuments :: + Setter (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocuments book charts sup_aic dap ersa) (AipDocuments book' charts' sup_aic' dap' ersa') + default _SetAipDocuments :: + ManyAipDocuments a => + Setter (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocuments book charts sup_aic dap ersa) (AipDocuments book' charts' sup_aic' dap' ersa') + _SetAipDocuments = + _ManyAipDocuments + +instance SetAipDocuments AipDocuments where + _SetAipDocuments = + id + +class (FoldAipDocuments a, SetAipDocuments a) => ManyAipDocuments a where + _ManyAipDocuments :: + Traversal (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocuments book charts sup_aic dap ersa) (AipDocuments book' charts' sup_aic' dap' ersa') + +instance ManyAipDocuments AipDocuments where + _ManyAipDocuments = + id + +class (GetAipDocuments a, ManyAipDocuments a) => HasAipDocuments a where + aipDocuments :: + Lens (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocuments book charts sup_aic dap ersa) (AipDocuments book' charts' sup_aic' dap' ersa') + default aipDocuments :: + IsAipDocuments a => + Lens (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocuments book charts sup_aic dap ersa) (AipDocuments book' charts' sup_aic' dap' ersa') + aipDocuments = + _IsAipDocuments + +instance HasAipDocuments AipDocuments where + aipDocuments = + id + +class (HasAipDocuments a, AsAipDocuments a) => IsAipDocuments a where + _IsAipDocuments :: + Iso (a book charts sup_aic dap ersa) (a book' charts' sup_aic' dap' ersa') (AipDocuments book charts sup_aic dap ersa) (AipDocuments book' charts' sup_aic' dap' ersa') + +instance IsAipDocuments AipDocuments where + _IsAipDocuments = + id + +---- + +instance (ManyHref book, ManyHref charts, ManyHref sup_aic, ManyHref dap, ManyHref ersa) => SetHref (AipDocuments book charts sup_aic dap ersa) where +instance (ManyHref book, ManyHref charts, ManyHref sup_aic, ManyHref dap, ManyHref ersa) => FoldHref (AipDocuments book charts sup_aic dap ersa) where + _FoldHref = + _ManyHref + +instance (ManyHref book, ManyHref charts, ManyHref sup_aic, ManyHref dap, ManyHref ersa) => ManyHref (AipDocuments book charts sup_aic dap ersa) where + _ManyHref = + _Wrapped . traverse . _ManyHref diff --git a/src/Data/Aviation/Aip/AipHref.hs b/src/Data/Aviation/Aip/AipHref.hs deleted file mode 100644 --- a/src/Data/Aviation/Aip/AipHref.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} - -module Data.Aviation.Aip.AipHref( - AipHref(..) -, parseAipHref -, uriAipHref -, HasAipHref(..) -) where - -import Data.Aviation.Aip.AipDate(AipDate, HasAipDate(aipDate), parseAipDate) -import Data.Aviation.Aip.AipPg(AipPg, HasAipPg(aipPg), parseAipPg, aippg1, aippg2) -import Data.Aviation.Aip.Day(HasDay(day, day1, day2)) -import Data.Aviation.Aip.Month(HasMonth(month)) -import Data.Aviation.Aip.Year(HasYear(year, year1, year2, year3, year4)) -import Data.Digit(Digit, HasDigit(hasdigit), parsedigit) -import Text.Parser.Char(CharParsing, string) -import Papa - -data AipHref = - AipHref { - _aiphrefpg :: - AipPg - , _aiphrefdate :: - AipDate - , _aiphrefversion :: - Digit - } deriving (Eq, Ord, Show) - -makeClassy ''AipHref - -parseAipHref :: - (CharParsing p, Monad p) => - p AipHref -parseAipHref = - string "aip.asp?pg=" *> - (AipHref <$> parseAipPg <* string "&vdate=" <*> parseAipDate <* string "&ver=" <*> parsedigit) - -uriAipHref :: - HasAipHref s => - s - -> String -uriAipHref ahref = - concat - [ - "?pg=" - , show (ahref ^. aipHref . aippg1) - , show (ahref ^. aipHref . aippg2) - , "&vdate=" - , show (ahref ^. aipHref . day1) - , show (ahref ^. aipHref . day2) - , "-" - , show (ahref ^. aipHref . month) - , "-" - , show (ahref ^. aipHref . year1) - , show (ahref ^. aipHref . year2) - , show (ahref ^. aipHref . year3) - , show (ahref ^. aipHref . year4) - , "&ver=" - , show (ahref ^. aipHref . hasdigit) - ] - -instance HasAipPg AipHref where - aipPg = - aiphrefpg . aipPg - -instance HasAipDate AipHref where - aipDate = - aiphrefdate . aipDate - -instance HasDigit AipHref where - hasdigit = - aiphrefversion . hasdigit - -instance HasDay AipHref where - day = - aipDate . day - -instance HasMonth AipHref where - month = - aipDate . month - -instance HasYear AipHref where - year = - aipDate . year - diff --git a/src/Data/Aviation/Aip/AipOptions.hs b/src/Data/Aviation/Aip/AipOptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/AipOptions.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Aviation.Aip.AipOptions( + AipOptions(..) +, aipOptionOutputDirectory +, aipOptionCache +, aipOptionLog +, aipOptionVerbose +, parserAipOptions +) where + +import Control.Applicative((<*>)) +import Control.Lens +import Data.Aviation.Aip.Cache(Cache(ReadCache, ReadWriteCache, NoCache)) +import Data.Bool(Bool) +import Data.Eq(Eq) +import Data.Functor(fmap, (<$>)) +import Data.Maybe(Maybe(Just, Nothing)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Options.Applicative(Parser, argument, str, help, metavar, option, maybeReader, short, long, value, switch) +import Prelude(Show) +import System.FilePath(FilePath) + +data AipOptions = + AipOptions + FilePath + Cache + Bool -- log + Bool -- verbose + deriving (Eq, Ord, Show) + +aipOptionOutputDirectory :: + Lens' AipOptions FilePath +aipOptionOutputDirectory k (AipOptions d c l v) = + fmap (\d' -> AipOptions d' c l v) (k d) + +aipOptionCache :: + Lens' AipOptions Cache +aipOptionCache k (AipOptions d c l v) = + fmap (\c' -> AipOptions d c' l v) (k c) + +aipOptionLog :: + Lens' AipOptions Bool +aipOptionLog k (AipOptions d c l v) = + fmap (\l' -> AipOptions d c l' v) (k l) + +aipOptionVerbose :: + Lens' AipOptions Bool +aipOptionVerbose k (AipOptions d c l v) = + fmap (\v' -> AipOptions d c l v') (k v) + +parserAipOptions :: + Parser AipOptions +parserAipOptions = + AipOptions + <$> + Options.Applicative.argument + str + ( + help "AIP output directory" <> + metavar "aip-output-directory" + ) + <*> + option + ( + maybeReader + (\s -> case s of + "r" -> Just ReadCache + "rw" -> Just ReadWriteCache + "no" -> Just NoCache + _ -> Nothing + ) + ) + ( + short 'c' <> + long "cache" <> + value ReadWriteCache <> + help "how to utilise the cache to build the AIP document tree" + ) + <*> + switch + ( + long "log" <> + short 'l' <> + help "log to standard output" + ) + <*> + switch + ( + long "verbose" <> + short 'v' <> + help "print the AIP document tree after download" + ) diff --git a/src/Data/Aviation/Aip/AipPg.hs b/src/Data/Aviation/Aip/AipPg.hs deleted file mode 100644 --- a/src/Data/Aviation/Aip/AipPg.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} - -module Data.Aviation.Aip.AipPg where - -import Data.Digit(Digit, parsedigit) -import Text.Parser.Char(CharParsing, string) -import Papa - -data AipPg = - AipPg { - _aippg1 :: - Digit - , _aippg2 :: - Digit - } deriving (Eq, Ord, Show) - -makeClassy ''AipPg - -parseAipPg :: - (CharParsing p, Monad p) => - p AipPg -parseAipPg = - AipPg <$> parsedigit <*> parsedigit - -parseAipPgHref :: - (CharParsing p, Monad p) => - p AipPg -parseAipPgHref = - string "aip.asp?pg=" *> - parseAipPg diff --git a/src/Data/Aviation/Aip/AipRecord.hs b/src/Data/Aviation/Aip/AipRecord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/AipRecord.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.AipRecord( + AipRecord(..) +, AsAipRecord(..) +, FoldAipRecord(..) +, GetAipRecord(..) +, SetAipRecord(..) +, ManyAipRecord(..) +, HasAipRecord(..) +, IsAipRecord(..) +, aipRecordAipDocuments +) where + +import Control.Category(id) +import Control.Applicative(pure, (<*>)) +import Control.Lens hiding ((.=)) +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withObject, object, (.:), (.=)) +import Data.Aviation.Aip.AipDocuments(AipDocuments2) +import Data.Aviation.Aip.Href(SetHref, FoldHref, ManyHref(_ManyHref), FoldHref(_FoldHref)) +import Data.Eq(Eq) +import Data.Function(($)) +import Data.Functor(fmap, (<$>)) +import Data.Time(UTCTime) +import Prelude(Show) + +data AipRecord = + AipRecord + UTCTime + AipDocuments2 + deriving (Eq, Show) + +instance FromJSON AipRecord where + parseJSON = + withObject "AipRecord" $ \v -> + AipRecord <$> + v .: "utc" <*> + v .: "documents" + +instance ToJSON AipRecord where + toJSON (AipRecord t p) = + object ["utc" .= t, "documents" .= p] + +class ManyAipRecord a => AsAipRecord a where + _AipRecord :: + Prism' a AipRecord + default _AipRecord :: + IsAipRecord a => + Prism' a AipRecord + _AipRecord = + _IsAipRecord + +instance AsAipRecord AipRecord where + _AipRecord = + id + +class FoldAipRecord a where + _FoldAipRecord :: + Fold a AipRecord + +instance FoldAipRecord AipRecord where + _FoldAipRecord = + id + +class FoldAipRecord a => GetAipRecord a where + _GetAipRecord :: + Getter a AipRecord + default _GetAipRecord :: + HasAipRecord a => + Getter a AipRecord + _GetAipRecord = + aipRecord + +instance GetAipRecord AipRecord where + _GetAipRecord = + id + +class SetAipRecord a where + _SetAipRecord :: + Setter' a AipRecord + default _SetAipRecord :: + ManyAipRecord a => + Setter' a AipRecord + _SetAipRecord = + _ManyAipRecord + +instance SetAipRecord AipRecord where + _SetAipRecord = + id + +class (FoldAipRecord a, SetAipRecord a) => ManyAipRecord a where + _ManyAipRecord :: + Traversal' a AipRecord + +instance ManyAipRecord AipRecord where + _ManyAipRecord = + id + +class (GetAipRecord a, ManyAipRecord a) => HasAipRecord a where + aipRecord :: + Lens' a AipRecord + default aipRecord :: + IsAipRecord a => + Lens' a AipRecord + aipRecord = + _IsAipRecord + +instance HasAipRecord AipRecord where + aipRecord = + id + +class (HasAipRecord a, AsAipRecord a) => IsAipRecord a where + _IsAipRecord :: + Iso' a AipRecord + +instance IsAipRecord AipRecord where + _IsAipRecord = + id + +instance SetAipRecord () where +instance FoldAipRecord () where + _FoldAipRecord = + _ManyAipRecord +instance ManyAipRecord () where + _ManyAipRecord _ x = + pure x + +---- + +instance SetHref AipRecord where +instance FoldHref AipRecord where + _FoldHref = + _ManyHref + +instance ManyHref AipRecord where + _ManyHref f (AipRecord t p) = + AipRecord <$> pure t <*> _ManyHref f p + +aipRecordAipDocuments :: + Lens' AipRecord AipDocuments2 +aipRecordAipDocuments k (AipRecord t p) = + fmap (\p' -> AipRecord t p') (k p) + diff --git a/src/Data/Aviation/Aip/AipRecords.hs b/src/Data/Aviation/Aip/AipRecords.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/AipRecords.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.AipRecords( + AipRecords(..) +, AsAipRecords(..) +, FoldAipRecords(..) +, GetAipRecords(..) +, SetAipRecords(..) +, ManyAipRecords(..) +, HasAipRecords(..) +, IsAipRecords(..) +, getAipRecords +, aipRecords1 +, run +) where + +import Control.Category((.), id) +import Control.Applicative(pure, (<*>), (<**>)) +import Codec.Binary.UTF8.String as UTF8(encode) +import Control.Exception(IOException) +import Control.Lens hiding ((.=)) +import Control.Monad((>>=), when, unless) +import Control.Monad.Catch(MonadCatch(catch)) +import Control.Monad.IO.Class(liftIO) +import Control.Monad.Trans.Except(runExceptT) +import Data.Aeson(decodeFileStrict) +import Data.Aeson.Encode.Pretty(confIndent, defConfig, Indent(Spaces), encodePretty') +import qualified Data.ByteString.Lazy as LazyByteString(writeFile) +import Data.Time(getCurrentTime) +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withObject, object, (.:), (.=)) +import Data.Aviation.Aip.AipDocument(AipDocument(Aip_Book, Aip_Charts, Aip_SUP_AIC, Aip_DAP, Aip_DAH, Aip_ERSA, Aip_AandB_Charts, Aip_Summary_SUP_AIC), runAipDocument) +import Data.Aviation.Aip.AfterDownload(AfterDownload(AfterDownload), AfterDownloadAipCon) +import Data.Aviation.Aip.AipCon(AipCon) +import Data.Aviation.Aip.SHA1(showHash) +import Data.Aviation.Aip.AipDate(AipDate(AipDate)) +import Data.Aviation.Aip.AipOptions(parserAipOptions, aipOptionLog, aipOptionCache, aipOptionOutputDirectory, aipOptionVerbose) +import Data.Aviation.Aip.AipDocuments(AipDocuments1, AipDocuments(AipDocuments)) +import Data.Aviation.Aip.AipRecord(AipRecord(AipRecord), ManyAipRecord(_ManyAipRecord), FoldAipRecord, SetAipRecord, FoldAipRecord(_FoldAipRecord)) +import Data.Aviation.Aip.Cache(Cache, isReadOrWriteCache, isWriteCache) +import Data.Aviation.Aip.Href(Href(Href), SetHref, FoldHref(_FoldHref), ManyHref(_ManyHref), aipPrefix) +import Data.Aviation.Aip.HttpRequest(requestAipContents, downloadHref) +import Data.Aviation.Aip.Log(aiplog, aiplog') +import Data.Aviation.Aip.SHA1(SHA1, GetSHA1, ManySHA1(_ManySHA1), SetSHA1, HasSHA1(sha1), FoldSHA1(_FoldSHA1), hash, hashHex) +import Data.Bool(Bool(True)) +import Data.Char(isSpace) +import Data.Either(Either(Left, Right)) +import Data.Eq(Eq((==))) +import Data.Foldable(length, foldMap) +import Data.Function(($)) +import Data.Functor(fmap, (<$>)) +import Data.List(dropWhile, splitAt) +import Data.List.NonEmpty(NonEmpty((:|))) +import Data.Maybe(Maybe(Just, Nothing)) +import Data.Monoid(Monoid(mempty)) +import Data.Semigroup(Semigroup((<>))) +import Data.String(String) +import Options.Applicative(execParser, info, helper, fullDesc, header) +import Prelude(Show(show)) +import System.Directory(doesDirectoryExist, doesFileExist, getPermissions, readable, createDirectoryIfMissing, removeDirectoryRecursive) +import System.Exit(exitWith, ExitCode(ExitFailure)) +import System.FilePath(takeDirectory, (), FilePath) +import System.IO(IO, putStrLn) +import Text.HTML.TagSoup(Tag(TagText)) +import Text.HTML.TagSoup.Tree(TagTree(TagBranch, TagLeaf), parseTree) +import Text.HTML.TagSoup.Tree.Zipper(TagTreePos(TagTreePos), fromTagTree, traverseTree) + +data AipRecords = + AipRecords + SHA1 + (NonEmpty AipRecord) + deriving (Eq, Show) + +instance FromJSON AipRecords where + parseJSON = + withObject "AipRecords" $ \v -> + AipRecords <$> + v .: "sha1" <*> + v .: "aiprecords" + +instance ToJSON AipRecords where + toJSON (AipRecords s r) = + object ["sha1" .= s, "aiprecords" .= r] + +class ManyAipRecords a => AsAipRecords a where + _AipRecords :: + Prism' a AipRecords + default _AipRecords :: + IsAipRecords a => + Prism' a AipRecords + _AipRecords = + _IsAipRecords + +instance AsAipRecords AipRecords where + _AipRecords = + id + +class FoldAipRecords a where + _FoldAipRecords :: + Fold a AipRecords + +instance FoldAipRecords AipRecords where + _FoldAipRecords = + id + +class FoldAipRecords a => GetAipRecords a where + _GetAipRecords :: + Getter a AipRecords + default _GetAipRecords :: + HasAipRecords a => + Getter a AipRecords + _GetAipRecords = + aipRecords + +instance GetAipRecords AipRecords where + _GetAipRecords = + id + +class SetAipRecords a where + _SetAipRecords :: + Setter' a AipRecords + default _SetAipRecords :: + ManyAipRecords a => + Setter' a AipRecords + _SetAipRecords = + _ManyAipRecords + +instance SetAipRecords AipRecords where + _SetAipRecords = + id + +class (FoldAipRecords a, SetAipRecords a) => ManyAipRecords a where + _ManyAipRecords :: + Traversal' a AipRecords + +instance ManyAipRecords AipRecords where + _ManyAipRecords = + id + +class (GetAipRecords a, ManyAipRecords a) => HasAipRecords a where + aipRecords :: + Lens' a AipRecords + default aipRecords :: + IsAipRecords a => + Lens' a AipRecords + aipRecords = + _IsAipRecords + +instance HasAipRecords AipRecords where + aipRecords = + id + +class (HasAipRecords a, AsAipRecords a) => IsAipRecords a where + _IsAipRecords :: + Iso' a AipRecords + +instance IsAipRecords AipRecords where + _IsAipRecords = + id + +instance SetAipRecords () where +instance FoldAipRecords () where + _FoldAipRecords = + _ManyAipRecords +instance ManyAipRecords () where + _ManyAipRecords _ x = + pure x + +getAipRecords :: + Cache + -> FilePath -- basedir + -> AipCon AipRecords +getAipRecords cch dir = + let readCache :: + FilePath + -> AipCon (Maybe AipRecords) + readCache c = + if isReadOrWriteCache cch + then + do e <- liftIO $ doesFileExist c + if e + then + do p <- liftIO $ getPermissions c + if readable p + then + do aiplog "reading aip contents cache" + liftIO $ decodeFileStrict c :: AipCon (Maybe (AipRecords)) + else + do aiplog "aip contents cache no read permission" + pure Nothing + else + do aiplog "aip contents cache not exists" + pure Nothing + else + do aiplog "configured for no read aip contents cache" + pure Nothing + + writeCache z rs = + when (isWriteCache cch) $ + do aiplog "writing aip contents cache" + liftIO $ createDirectoryIfMissing True (takeDirectory z) + let conf = defConfig { confIndent = Spaces 2 } + liftIO $ LazyByteString.writeFile z (encodePretty' conf rs) + trimSpaces = + dropWhile isSpace + in do c <- requestAipContents + let h = hash (UTF8.encode c) + let h' = hashHex h + aiplog ("aip contents, sha1: " <> h' "") + let z = dir h' ".json" + r <- readCache z + case r of + Just v -> + do aiplog "using and returning aip contents cache" + pure v + Nothing -> + let traverseAipDocuments :: + TagTreePos String + -> AipDocuments1 + traverseAipDocuments (TagTreePos (TagBranch "ul" [] x) _ _ _) = + let li (TagBranch "li" [] [TagBranch "a" [("href", hf)] [TagLeaf (TagText "AIP Book")], TagLeaf (TagText tx)]) = + [Aip_Book (Href hf) (AipDate (trimSpaces tx)) ()] + li (TagBranch "li" [] [TagBranch "a" [("href", hf)] [TagLeaf (TagText "AIP Charts")], TagLeaf (TagText tx)]) = + [Aip_Charts (Href hf) (AipDate (trimSpaces tx)) ()] + li (TagBranch "li" [] [TagBranch "a" [("href", hf)] [TagLeaf (TagText "AIP Supplements and Aeronautical Information Circulars (AIC)")]]) = + [Aip_SUP_AIC (Href hf) ()] + li (TagBranch "li" [] [TagBranch "a" [("href", hf)] [TagLeaf (TagText "Departure and Approach Procedures (DAP)")], TagLeaf (TagText tx)]) = + [Aip_DAP (Href hf) (AipDate (trimSpaces tx)) ()] + li (TagBranch "li" [] [TagBranch "a" [("href", hf)] [TagLeaf (TagText "Designated Airspace Handbook (DAH)")], TagLeaf (TagText tx)]) = + [Aip_DAH (Href hf) (AipDate (trimSpaces tx))] + li (TagBranch "li" [] [TagBranch "a" [("href", hf)] [TagLeaf (TagText "En Route Supplement Australia (ERSA)")], TagLeaf (TagText tx)]) = + [Aip_ERSA (Href hf) (AipDate (trimSpaces tx)) ()] + li (TagBranch "li" [] [TagBranch "a" [("href", hf)] [TagLeaf (TagText "Precision Approach Terrain Charts and Type A & Type B Obstacle Charts")]]) = + [Aip_AandB_Charts (Href hf)] + li (TagBranch "li" [] [TagBranch "a" [("href", hf)] [TagLeaf (TagText tx)]]) = + let st = "Summary of SUP/AIC Current" + (p, s) = splitAt (length st) tx + in if p == st then + [Aip_Summary_SUP_AIC (Href hf) (AipDate (trimSpaces s))] + else + [] + li _ = + [] + in AipDocuments (x >>= li) + traverseAipDocuments _ = + mempty + in do let AipDocuments a = foldMap (traverseTree traverseAipDocuments . fromTagTree) (parseTree c) + q <- AipDocuments <$> traverse runAipDocument a + t <- liftIO getCurrentTime + aiplog ("traverse aip records at time " <> show t) + let rs = AipRecords h (AipRecord t q :| []) + writeCache z rs + pure rs + +---- + +instance FoldAipRecord AipRecords where + _FoldAipRecord = + _ManyAipRecord + +instance SetAipRecord AipRecords where + +instance ManyAipRecord AipRecords where + _ManyAipRecord f (AipRecords s r) = + AipRecords s <$> traverse f r + +instance SetHref AipRecords where +instance FoldHref AipRecords where + _FoldHref = + _ManyHref + +instance ManyHref AipRecords where + _ManyHref f (AipRecords s r) = + AipRecords <$> pure s <*> (traverse . _ManyHref) f r + +instance FoldSHA1 AipRecords where + _FoldSHA1 = + sha1 + +instance GetSHA1 AipRecords where + +instance ManySHA1 AipRecords where + _ManySHA1 = + sha1 + +instance SetSHA1 AipRecords where + +instance HasSHA1 AipRecords where + sha1 k (AipRecords s r) = + fmap (\s' -> AipRecords s' r) (k s) + +aipRecords1 :: + Lens' AipRecords (NonEmpty AipRecord) +aipRecords1 k (AipRecords s r) = + fmap (\r' -> AipRecords s r') (k r) + + +run :: + AfterDownloadAipCon a + -> IO () +run k = + let writeAip :: + AfterDownloadAipCon a + -> Cache + -> FilePath + -> AipCon AipRecords + writeAip (AfterDownload w) cch dir = + let catchIOException :: + MonadCatch m => + m a -> + (IOException -> m a) + -> m a + catchIOException = + catch + in do x <- getAipRecords cch dir + let h = dir showHash x + de <- liftIO $ doesDirectoryExist h + let dl = mapMOf_ _ManyHref (\c -> downloadHref h c >>= \z -> w z c) (aipPrefix x) + catchIOException (de `unless` dl) (\e -> + do aiplog ("IO Exception: " <> show e) + liftIO $ removeDirectoryRecursive h) + pure x + p = + execParser + (info (parserAipOptions <**> helper) ( + fullDesc <> + header "aip 0.1.0 " + ) + ) + in do opts <- p + let lg = (opts ^. aipOptionLog) + e <- runExceptT ((writeAip k (opts ^. aipOptionCache) (opts ^. aipOptionOutputDirectory) ^. _Wrapped) lg) + case e of + Left e' -> + do when lg (aiplog' ("network or HTTP error " <> show e')) + exitWith (ExitFailure 1) + Right r -> + when (opts ^. aipOptionVerbose) (putStrLn (show r)) diff --git a/src/Data/Aviation/Aip/Aip_SUP_and_AIC.hs b/src/Data/Aviation/Aip/Aip_SUP_and_AIC.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/Aip_SUP_and_AIC.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.Aip_SUP_and_AIC( + Aip_SUP_and_AIC(..) +, AsAip_SUP_and_AIC(..) +, FoldAip_SUP_and_AIC(..) +, GetAip_SUP_and_AIC(..) +, SetAip_SUP_and_AIC(..) +, ManyAip_SUP_and_AIC(..) +, HasAip_SUP_and_AIC(..) +, IsAip_SUP_and_AIC(..) +) where + +import Control.Category(id) +import Control.Applicative(pure, (<*>)) +import Control.Lens hiding ((.=)) +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withObject, object, (.:), (.=)) +import Data.Aviation.Aip.AipDate(AipDate) +import Data.Aviation.Aip.DocumentNumber(DocumentNumber) +import Data.Aviation.Aip.Href(Href, SetHref, FoldHref(_FoldHref), ManyHref(_ManyHref), GetHref, HasHref(href)) +import Data.Aviation.Aip.Title(Title) +import Data.Eq(Eq) +import Data.Function(($)) +import Data.Functor(fmap, (<$>)) +import Data.Ord(Ord) +import Prelude(Show) + +data Aip_SUP_and_AIC = + Aip_SUP_and_AIC + DocumentNumber + Href + Title + AipDate + AipDate + deriving (Eq, Ord, Show) + +instance FromJSON Aip_SUP_and_AIC where + parseJSON = + withObject "Aip_SUP_and_AIC" $ \v -> + Aip_SUP_and_AIC <$> + v .: "docnum" <*> + v .: "href" <*> + v .: "title" <*> + v .: "pubdate" <*> + v .: "effdate" + +instance ToJSON Aip_SUP_and_AIC where + toJSON (Aip_SUP_and_AIC docnum u title pubdate effdate) = + object ["docnum" .= docnum, "href" .= u, "title" .= title, "pubdate" .= pubdate, "effdate" .= effdate] + +class ManyAip_SUP_and_AIC a => AsAip_SUP_and_AIC a where + _Aip_SUP_and_AIC :: + Prism' a Aip_SUP_and_AIC + default _Aip_SUP_and_AIC :: + IsAip_SUP_and_AIC a => + Prism' a Aip_SUP_and_AIC + _Aip_SUP_and_AIC = + _IsAip_SUP_and_AIC + +instance AsAip_SUP_and_AIC Aip_SUP_and_AIC where + _Aip_SUP_and_AIC = + id + +class FoldAip_SUP_and_AIC a where + _FoldAip_SUP_and_AIC :: + Fold a Aip_SUP_and_AIC + +instance FoldAip_SUP_and_AIC Aip_SUP_and_AIC where + _FoldAip_SUP_and_AIC = + id + +class FoldAip_SUP_and_AIC a => GetAip_SUP_and_AIC a where + _GetAip_SUP_and_AIC :: + Getter a Aip_SUP_and_AIC + default _GetAip_SUP_and_AIC :: + HasAip_SUP_and_AIC a => + Getter a Aip_SUP_and_AIC + _GetAip_SUP_and_AIC = + aip_SUP_and_AIC + +instance GetAip_SUP_and_AIC Aip_SUP_and_AIC where + _GetAip_SUP_and_AIC = + id + +class SetAip_SUP_and_AIC a where + _SetAip_SUP_and_AIC :: + Setter' a Aip_SUP_and_AIC + default _SetAip_SUP_and_AIC :: + ManyAip_SUP_and_AIC a => + Setter' a Aip_SUP_and_AIC + _SetAip_SUP_and_AIC = + _ManyAip_SUP_and_AIC + +instance SetAip_SUP_and_AIC Aip_SUP_and_AIC where + _SetAip_SUP_and_AIC = + id + +class (FoldAip_SUP_and_AIC a, SetAip_SUP_and_AIC a) => ManyAip_SUP_and_AIC a where + _ManyAip_SUP_and_AIC :: + Traversal' a Aip_SUP_and_AIC + +instance ManyAip_SUP_and_AIC Aip_SUP_and_AIC where + _ManyAip_SUP_and_AIC = + id + +class (GetAip_SUP_and_AIC a, ManyAip_SUP_and_AIC a) => HasAip_SUP_and_AIC a where + aip_SUP_and_AIC :: + Lens' a Aip_SUP_and_AIC + default aip_SUP_and_AIC :: + IsAip_SUP_and_AIC a => + Lens' a Aip_SUP_and_AIC + aip_SUP_and_AIC = + _IsAip_SUP_and_AIC + +instance HasAip_SUP_and_AIC Aip_SUP_and_AIC where + aip_SUP_and_AIC = + id + +class (HasAip_SUP_and_AIC a, AsAip_SUP_and_AIC a) => IsAip_SUP_and_AIC a where + _IsAip_SUP_and_AIC :: + Iso' a Aip_SUP_and_AIC + +instance IsAip_SUP_and_AIC Aip_SUP_and_AIC where + _IsAip_SUP_and_AIC = + id + +instance SetAip_SUP_and_AIC () where +instance FoldAip_SUP_and_AIC () where + _FoldAip_SUP_and_AIC = + _ManyAip_SUP_and_AIC +instance ManyAip_SUP_and_AIC () where + _ManyAip_SUP_and_AIC _ x = + pure x + +---- + +instance SetHref Aip_SUP_and_AIC where +instance FoldHref Aip_SUP_and_AIC where + _FoldHref = + _ManyHref + +instance ManyHref Aip_SUP_and_AIC where + _ManyHref f (Aip_SUP_and_AIC docnum u title pubdate effdate) = + Aip_SUP_and_AIC <$> pure docnum <*> f u <*> pure title <*> pure pubdate <*> pure effdate + +instance GetHref Aip_SUP_and_AIC where +instance HasHref Aip_SUP_and_AIC where + href f (Aip_SUP_and_AIC docnum u title pubdate effdate) = + fmap (\u' -> Aip_SUP_and_AIC docnum u' title pubdate effdate) (f u) diff --git a/src/Data/Aviation/Aip/Aip_SUP_and_AICs.hs b/src/Data/Aviation/Aip/Aip_SUP_and_AICs.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/Aip_SUP_and_AICs.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Data.Aviation.Aip.Aip_SUP_and_AICs( + Aip_SUP_and_AICs(..) +, AsAip_SUP_and_AICs(..) +, FoldAip_SUP_and_AICs(..) +, GetAip_SUP_and_AICs(..) +, SetAip_SUP_and_AICs(..) +, ManyAip_SUP_and_AICs(..) +, HasAip_SUP_and_AICs(..) +, IsAip_SUP_and_AICs(..) +) where + +import Control.Category((.), id) +import Control.Applicative(pure) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withArray) +import Data.Aviation.Aip.Href(SetHref, FoldHref, ManyHref(_ManyHref), FoldHref(_FoldHref)) +import Data.Aviation.Aip.Aip_SUP_and_AIC(Aip_SUP_and_AIC) +import Data.Eq(Eq) +import Data.Foldable(toList) +import Data.Function(($)) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Prelude(Show) + +newtype Aip_SUP_and_AICs = + Aip_SUP_and_AICs + [Aip_SUP_and_AIC] + deriving (Eq, Ord, Show) + +instance Semigroup Aip_SUP_and_AICs where + Aip_SUP_and_AICs x <> Aip_SUP_and_AICs y = + Aip_SUP_and_AICs (x <> y) + +instance Monoid Aip_SUP_and_AICs where + mappend = + (<>) + mempty = + Aip_SUP_and_AICs mempty + +instance FromJSON Aip_SUP_and_AICs where + parseJSON = + withArray "Aip_SUP_and_AICs" $ \v -> + Aip_SUP_and_AICs <$> traverse parseJSON (toList v) + +instance ToJSON Aip_SUP_and_AICs where + toJSON (Aip_SUP_and_AICs x) = + toJSON x + +instance Wrapped Aip_SUP_and_AICs where + type Unwrapped Aip_SUP_and_AICs = + [Aip_SUP_and_AIC] + _Wrapped' = + iso (\(Aip_SUP_and_AICs x) -> x) Aip_SUP_and_AICs + +instance Aip_SUP_and_AICs ~ x => + Rewrapped Aip_SUP_and_AICs x + +instance Cons Aip_SUP_and_AICs Aip_SUP_and_AICs Aip_SUP_and_AIC Aip_SUP_and_AIC where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc Aip_SUP_and_AICs Aip_SUP_and_AICs Aip_SUP_and_AIC Aip_SUP_and_AIC where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each Aip_SUP_and_AICs Aip_SUP_and_AICs Aip_SUP_and_AIC Aip_SUP_and_AIC where + each = + _Wrapped . each + +instance Reversing Aip_SUP_and_AICs where + reversing = + _Wrapped %~ reversing + +instance Plated Aip_SUP_and_AICs where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue Aip_SUP_and_AICs = Aip_SUP_and_AIC +type instance Index Aip_SUP_and_AICs = Int +instance Ixed Aip_SUP_and_AICs where + ix i = + _Wrapped . ix i + +class ManyAip_SUP_and_AICs a => AsAip_SUP_and_AICs a where + _Aip_SUP_and_AICs :: + Prism' a Aip_SUP_and_AICs + default _Aip_SUP_and_AICs :: + IsAip_SUP_and_AICs a => + Prism' a Aip_SUP_and_AICs + _Aip_SUP_and_AICs = + _IsAip_SUP_and_AICs + +instance AsAip_SUP_and_AICs Aip_SUP_and_AICs where + _Aip_SUP_and_AICs = + id + +class FoldAip_SUP_and_AICs a where + _FoldAip_SUP_and_AICs :: + Fold a Aip_SUP_and_AICs + +instance FoldAip_SUP_and_AICs Aip_SUP_and_AICs where + _FoldAip_SUP_and_AICs = + id + +class FoldAip_SUP_and_AICs a => GetAip_SUP_and_AICs a where + _GetAip_SUP_and_AICs :: + Getter a Aip_SUP_and_AICs + default _GetAip_SUP_and_AICs :: + HasAip_SUP_and_AICs a => + Getter a Aip_SUP_and_AICs + _GetAip_SUP_and_AICs = + aip_SUP_and_AICs + +instance GetAip_SUP_and_AICs Aip_SUP_and_AICs where + _GetAip_SUP_and_AICs = + id + +class SetAip_SUP_and_AICs a where + _SetAip_SUP_and_AICs :: + Setter' a Aip_SUP_and_AICs + default _SetAip_SUP_and_AICs :: + ManyAip_SUP_and_AICs a => + Setter' a Aip_SUP_and_AICs + _SetAip_SUP_and_AICs = + _ManyAip_SUP_and_AICs + +instance SetAip_SUP_and_AICs Aip_SUP_and_AICs where + _SetAip_SUP_and_AICs = + id + +class (FoldAip_SUP_and_AICs a, SetAip_SUP_and_AICs a) => ManyAip_SUP_and_AICs a where + _ManyAip_SUP_and_AICs :: + Traversal' a Aip_SUP_and_AICs + +instance ManyAip_SUP_and_AICs Aip_SUP_and_AICs where + _ManyAip_SUP_and_AICs = + id + +class (GetAip_SUP_and_AICs a, ManyAip_SUP_and_AICs a) => HasAip_SUP_and_AICs a where + aip_SUP_and_AICs :: + Lens' a Aip_SUP_and_AICs + default aip_SUP_and_AICs :: + IsAip_SUP_and_AICs a => + Lens' a Aip_SUP_and_AICs + aip_SUP_and_AICs = + _IsAip_SUP_and_AICs + +instance HasAip_SUP_and_AICs Aip_SUP_and_AICs where + aip_SUP_and_AICs = + id + +class (HasAip_SUP_and_AICs a, AsAip_SUP_and_AICs a) => IsAip_SUP_and_AICs a where + _IsAip_SUP_and_AICs :: + Iso' a Aip_SUP_and_AICs + +instance IsAip_SUP_and_AICs Aip_SUP_and_AICs where + _IsAip_SUP_and_AICs = + id + +instance SetAip_SUP_and_AICs () where +instance FoldAip_SUP_and_AICs () where + _FoldAip_SUP_and_AICs = + _ManyAip_SUP_and_AICs +instance ManyAip_SUP_and_AICs () where + _ManyAip_SUP_and_AICs _ x = + pure x + +---- + +instance SetHref Aip_SUP_and_AICs where +instance FoldHref Aip_SUP_and_AICs where + _FoldHref = + _ManyHref + +instance ManyHref Aip_SUP_and_AICs where + _ManyHref = + _Wrapped . traverse . _ManyHref diff --git a/src/Data/Aviation/Aip/Amendment.hs b/src/Data/Aviation/Aip/Amendment.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/Amendment.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.Amendment( + Amendment(..) +, AsAmendment(..) +, FoldAmendment(..) +, GetAmendment(..) +, SetAmendment(..) +, ManyAmendment(..) +, HasAmendment(..) +, IsAmendment(..) +) where + +import Control.Category((.), id) +import Control.Applicative(pure) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON)) +import Data.Char(Char) +import Data.Eq(Eq) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Data.String(String) +import Prelude(Show) + +newtype Amendment = + Amendment + String + deriving (Eq, Ord, Show) + +instance FromJSON Amendment where + parseJSON v = + Amendment <$> parseJSON v + +instance ToJSON Amendment where + toJSON (Amendment x) = + toJSON x + +instance Semigroup Amendment where + Amendment x <> Amendment y = + Amendment (x <> y) + +instance Monoid Amendment where + mappend = + (<>) + mempty = + Amendment mempty + +instance Cons Amendment Amendment Char Char where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc Amendment Amendment Char Char where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each Amendment Amendment Char Char where + each = + _Wrapped . each + +instance Reversing Amendment where + reversing = + _Wrapped %~ reversing + +instance Plated Amendment where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue Amendment = Char +type instance Index Amendment = Int +instance Ixed Amendment where + ix i = + _Wrapped . ix i + +instance Wrapped Amendment where + type Unwrapped Amendment = String + _Wrapped' = + iso + (\(Amendment x) -> x) + Amendment + +instance Amendment ~ a => + Rewrapped Amendment a + +class ManyAmendment a => AsAmendment a where + _Amendment :: + Prism' a Amendment + default _Amendment :: + IsAmendment a => + Prism' a Amendment + _Amendment = + _IsAmendment + +instance AsAmendment Amendment where + _Amendment = + id + +instance AsAmendment String where + _Amendment = + from _Wrapped + +class FoldAmendment a where + _FoldAmendment :: + Fold a Amendment + +instance FoldAmendment Amendment where + _FoldAmendment = + id + +instance FoldAmendment String where + _FoldAmendment = + from _Wrapped + +class FoldAmendment a => GetAmendment a where + _GetAmendment :: + Getter a Amendment + default _GetAmendment :: + HasAmendment a => + Getter a Amendment + _GetAmendment = + amendment + +instance GetAmendment Amendment where + _GetAmendment = + id + +instance GetAmendment String where + _GetAmendment = + from _Wrapped + +class SetAmendment a where + _SetAmendment :: + Setter' a Amendment + default _SetAmendment :: + ManyAmendment a => + Setter' a Amendment + _SetAmendment = + _ManyAmendment + +instance SetAmendment Amendment where + _SetAmendment = + id + +instance SetAmendment String where + _SetAmendment = + from _Wrapped + +class (FoldAmendment a, SetAmendment a) => ManyAmendment a where + _ManyAmendment :: + Traversal' a Amendment + +instance ManyAmendment Amendment where + _ManyAmendment = + id + +instance ManyAmendment String where + _ManyAmendment = + from _Wrapped + +class (GetAmendment a, ManyAmendment a) => HasAmendment a where + amendment :: + Lens' a Amendment + default amendment :: + IsAmendment a => + Lens' a Amendment + amendment = + _IsAmendment + +instance HasAmendment Amendment where + amendment = + id + +instance HasAmendment String where + amendment = + from _Wrapped + +class (HasAmendment a, AsAmendment a) => IsAmendment a where + _IsAmendment :: + Iso' a Amendment + +instance IsAmendment Amendment where + _IsAmendment = + id + +instance IsAmendment String where + _IsAmendment = + from _Wrapped + +instance SetAmendment () where +instance FoldAmendment () where + _FoldAmendment = + _ManyAmendment +instance ManyAmendment () where + _ManyAmendment _ x = + pure x diff --git a/src/Data/Aviation/Aip/Cache.hs b/src/Data/Aviation/Aip/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/Cache.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.Cache( + Cache(..) +, AsCache(..) +, FoldCache(..) +, GetCache(..) +, SetCache(..) +, ManyCache(..) +, HasCache(..) +, IsCache(..) +, AsReadCache(..) +, AsReadWriteCache(..) +, AsNoCache(..) +, isReadOrWriteCache +, isWriteCache +) where + +import Control.Category(id) +import Control.Applicative(pure) +import Control.Lens +import Data.Bool(Bool, not) +import Data.Eq(Eq) +import Data.Foldable(any) +import Data.Maybe(Maybe(Just, Nothing)) +import Data.Ord(Ord) +import Prelude(Show) + +data Cache = + ReadCache + | ReadWriteCache + | NoCache + deriving (Eq, Ord, Show) + +class ManyCache a => AsCache a where + _Cache :: + Prism' a Cache + default _Cache :: + IsCache a => + Prism' a Cache + _Cache = + _IsCache + +instance AsCache Cache where + _Cache = + id + +class FoldCache a where + _FoldCache :: + Fold a Cache + +instance FoldCache Cache where + _FoldCache = + id + +class FoldCache a => GetCache a where + _GetCache :: + Getter a Cache + default _GetCache :: + HasCache a => + Getter a Cache + _GetCache = + cache + +instance GetCache Cache where + _GetCache = + id + +class SetCache a where + _SetCache :: + Setter' a Cache + default _SetCache :: + ManyCache a => + Setter' a Cache + _SetCache = + _ManyCache + +instance SetCache Cache where + _SetCache = + id + +class (FoldCache a, SetCache a) => ManyCache a where + _ManyCache :: + Traversal' a Cache + +instance ManyCache Cache where + _ManyCache = + id + +class (GetCache a, ManyCache a) => HasCache a where + cache :: + Lens' a Cache + default cache :: + IsCache a => + Lens' a Cache + cache = + _IsCache + +instance HasCache Cache where + cache = + id + +class (HasCache a, AsCache a) => IsCache a where + _IsCache :: + Iso' a Cache + +instance IsCache Cache where + _IsCache = + id + +instance SetCache () where +instance FoldCache () where + _FoldCache = + _ManyCache +instance ManyCache () where + _ManyCache _ x = + pure x + +---- + + +class AsReadCache a where + _ReadCache :: + Prism' + a + () + +instance AsReadCache () where + _ReadCache = + id + +instance AsReadCache Cache where + _ReadCache = + prism' + (\() -> ReadCache) + (\c -> case c of + ReadCache -> + Just () + _ -> + Nothing) + +class AsReadWriteCache a where + _ReadWriteCache :: + Prism' + a + () + +instance AsReadWriteCache () where + _ReadWriteCache = + id + +instance AsReadWriteCache Cache where + _ReadWriteCache = + prism' + (\() -> ReadWriteCache) + (\c -> case c of + ReadWriteCache -> + Just () + _ -> + Nothing) + +class AsNoCache a where + _NoCache :: + Prism' + a + () + +instance AsNoCache () where + _NoCache = + id + +instance AsNoCache Cache where + _NoCache = + prism' + (\() -> NoCache) + (\c -> case c of + NoCache -> + Just () + _ -> + Nothing) + +isReadOrWriteCache :: + (AsReadCache t, AsReadWriteCache t) => + t + -> Bool +isReadOrWriteCache x = + any (\p' -> not (isn't p' x)) [_ReadCache, _ReadWriteCache] + +isWriteCache :: + AsReadWriteCache t => + t + -> Bool +isWriteCache x = + not (isn't _ReadWriteCache x) + diff --git a/src/Data/Aviation/Aip/ConnErrorHttp4xx.hs b/src/Data/Aviation/Aip/ConnErrorHttp4xx.hs --- a/src/Data/Aviation/Aip/ConnErrorHttp4xx.hs +++ b/src/Data/Aviation/Aip/ConnErrorHttp4xx.hs @@ -1,16 +1,112 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DefaultSignatures #-} +{-# OPTIONS_HADDOCK prune #-} module Data.Aviation.Aip.ConnErrorHttp4xx( ConnErrorHttp4xx(..) +, AsConnErrorHttp4xx(..) +, FoldConnErrorHttp4xx(..) +, GetConnErrorHttp4xx(..) +, SetConnErrorHttp4xx(..) +, ManyConnErrorHttp4xx(..) +, HasConnErrorHttp4xx(..) +, IsConnErrorHttp4xx(..) ) where +import Control.Category(id) +import Control.Applicative(pure) +import Control.Lens +import Data.Eq(Eq) +import Data.Int(Int) import Network.Stream(ConnError) -import Papa +import Prelude(Show) data ConnErrorHttp4xx = IsConnError ConnError | Http4xx Int Int deriving (Eq, Show) -makeClassyPrisms ''ConnErrorHttp4xx +class AsConnErrorHttp4xx a where + _ConnErrorHttp4xx :: + Prism' a ConnErrorHttp4xx + default _ConnErrorHttp4xx :: + IsConnErrorHttp4xx a => + Prism' a ConnErrorHttp4xx + _ConnErrorHttp4xx = + _IsConnErrorHttp4xx + +instance AsConnErrorHttp4xx ConnErrorHttp4xx where + _ConnErrorHttp4xx = + id + +class FoldConnErrorHttp4xx a where + _FoldConnErrorHttp4xx :: + Fold a ConnErrorHttp4xx + +instance FoldConnErrorHttp4xx ConnErrorHttp4xx where + _FoldConnErrorHttp4xx = + id + +class FoldConnErrorHttp4xx a => GetConnErrorHttp4xx a where + _GetConnErrorHttp4xx :: + Getter a ConnErrorHttp4xx + default _GetConnErrorHttp4xx :: + HasConnErrorHttp4xx a => + Getter a ConnErrorHttp4xx + _GetConnErrorHttp4xx = + connErrorHttp4xx + +instance GetConnErrorHttp4xx ConnErrorHttp4xx where + _GetConnErrorHttp4xx = + id + +class SetConnErrorHttp4xx a where + _SetConnErrorHttp4xx :: + Setter' a ConnErrorHttp4xx + default _SetConnErrorHttp4xx :: + ManyConnErrorHttp4xx a => + Setter' a ConnErrorHttp4xx + _SetConnErrorHttp4xx = + _ManyConnErrorHttp4xx + +instance SetConnErrorHttp4xx ConnErrorHttp4xx where + _SetConnErrorHttp4xx = + id + +class (FoldConnErrorHttp4xx a, SetConnErrorHttp4xx a) => ManyConnErrorHttp4xx a where + _ManyConnErrorHttp4xx :: + Traversal' a ConnErrorHttp4xx + +instance ManyConnErrorHttp4xx ConnErrorHttp4xx where + _ManyConnErrorHttp4xx = + id + +class (GetConnErrorHttp4xx a, ManyConnErrorHttp4xx a) => HasConnErrorHttp4xx a where + connErrorHttp4xx :: + Lens' a ConnErrorHttp4xx + default connErrorHttp4xx :: + IsConnErrorHttp4xx a => + Lens' a ConnErrorHttp4xx + connErrorHttp4xx = + _IsConnErrorHttp4xx + +instance HasConnErrorHttp4xx ConnErrorHttp4xx where + connErrorHttp4xx = + id + +class (HasConnErrorHttp4xx a, AsConnErrorHttp4xx a) => IsConnErrorHttp4xx a where + _IsConnErrorHttp4xx :: + Iso' a ConnErrorHttp4xx + +instance IsConnErrorHttp4xx ConnErrorHttp4xx where + _IsConnErrorHttp4xx = + id + +instance SetConnErrorHttp4xx () where +instance FoldConnErrorHttp4xx () where + _FoldConnErrorHttp4xx = + _ManyConnErrorHttp4xx +instance ManyConnErrorHttp4xx () where + _ManyConnErrorHttp4xx _ x = + pure x diff --git a/src/Data/Aviation/Aip/DAPDoc.hs b/src/Data/Aviation/Aip/DAPDoc.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/DAPDoc.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.DAPDoc( + DAPDoc(..) +, AsDAPDoc(..) +, FoldDAPDoc(..) +, GetDAPDoc(..) +, SetDAPDoc(..) +, ManyDAPDoc(..) +, HasDAPDoc(..) +, IsDAPDoc(..) +) where + +import Control.Category(id) +import Control.Applicative(pure, (<*>)) +import Control.Lens hiding ((.=)) +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withObject, object, (.:), (.=)) +import Data.Aviation.Aip.DAPType(DAPType) +import Data.Aviation.Aip.DAPEntries(DAPEntries, FoldDAPEntries(_FoldDAPEntries), GetDAPEntries, SetDAPEntries, ManyDAPEntries(_ManyDAPEntries), HasDAPEntries(dapEntries)) +import Data.Aviation.Aip.Href(Href, SetHref, FoldHref, ManyHref(_ManyHref), FoldHref(_FoldHref)) +import Data.Eq(Eq) +import Data.Function(($)) +import Data.Functor(fmap, (<$>)) +import Data.Ord(Ord) +import Data.String(String) +import Prelude(Show) + +data DAPDoc = + DAPDoc + (DAPType String) + Href + DAPEntries + deriving (Eq, Ord, Show) + +instance FromJSON DAPDoc where + parseJSON = + withObject "DAPDoc" $ \v -> + DAPDoc <$> + v .: "type" <*> + v .: "href" <*> + v .: "entries" + +instance ToJSON DAPDoc where + toJSON (DAPDoc typ u entries) = + object ["type" .= typ, "href" .= u, "entries" .= entries] + +class ManyDAPDoc a => AsDAPDoc a where + _DAPDoc :: + Prism' a DAPDoc + default _DAPDoc :: + IsDAPDoc a => + Prism' a DAPDoc + _DAPDoc = + _IsDAPDoc + +instance AsDAPDoc DAPDoc where + _DAPDoc = + id + +class FoldDAPDoc a where + _FoldDAPDoc :: + Fold a DAPDoc + +instance FoldDAPDoc DAPDoc where + _FoldDAPDoc = + id + +class FoldDAPDoc a => GetDAPDoc a where + _GetDAPDoc :: + Getter a DAPDoc + default _GetDAPDoc :: + HasDAPDoc a => + Getter a DAPDoc + _GetDAPDoc = + dapDoc + +instance GetDAPDoc DAPDoc where + _GetDAPDoc = + id + +class SetDAPDoc a where + _SetDAPDoc :: + Setter' a DAPDoc + default _SetDAPDoc :: + ManyDAPDoc a => + Setter' a DAPDoc + _SetDAPDoc = + _ManyDAPDoc + +instance SetDAPDoc DAPDoc where + _SetDAPDoc = + id + +class (FoldDAPDoc a, SetDAPDoc a) => ManyDAPDoc a where + _ManyDAPDoc :: + Traversal' a DAPDoc + +instance ManyDAPDoc DAPDoc where + _ManyDAPDoc = + id + +class (GetDAPDoc a, ManyDAPDoc a) => HasDAPDoc a where + dapDoc :: + Lens' a DAPDoc + default dapDoc :: + IsDAPDoc a => + Lens' a DAPDoc + dapDoc = + _IsDAPDoc + +instance HasDAPDoc DAPDoc where + dapDoc = + id + +class (HasDAPDoc a, AsDAPDoc a) => IsDAPDoc a where + _IsDAPDoc :: + Iso' a DAPDoc + +instance IsDAPDoc DAPDoc where + _IsDAPDoc = + id + +instance SetDAPDoc () where +instance FoldDAPDoc () where + _FoldDAPDoc = + _ManyDAPDoc +instance ManyDAPDoc () where + _ManyDAPDoc _ x = + pure x + +instance SetHref DAPDoc where +instance FoldHref DAPDoc where + _FoldHref = + _ManyHref + +instance ManyHref DAPDoc where + _ManyHref f (DAPDoc typ u entries) = + DAPDoc <$> pure typ <*> f u <*> _ManyHref f entries + +---- + +instance FoldDAPEntries DAPDoc where + _FoldDAPEntries = + dapEntries +instance GetDAPEntries DAPDoc where +instance SetDAPEntries DAPDoc where +instance ManyDAPEntries DAPDoc where + _ManyDAPEntries = + dapEntries +instance HasDAPEntries DAPDoc where + dapEntries k (DAPDoc typ u entries) = + fmap (\entries' -> DAPDoc typ u entries') (k entries) diff --git a/src/Data/Aviation/Aip/DAPDocs.hs b/src/Data/Aviation/Aip/DAPDocs.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/DAPDocs.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Data.Aviation.Aip.DAPDocs( + DAPDocs(..) +, AsDAPDocs(..) +, FoldDAPDocs(..) +, GetDAPDocs(..) +, SetDAPDocs(..) +, ManyDAPDocs(..) +, HasDAPDocs(..) +, IsDAPDocs(..) +) where + +import Control.Category((.), id) +import Control.Applicative(pure) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withArray) +import Data.Aviation.Aip.DAPDoc(DAPDoc) +import Data.Aviation.Aip.Href(SetHref, FoldHref, ManyHref(_ManyHref), FoldHref(_FoldHref)) +import Data.Eq(Eq) +import Data.Foldable(toList) +import Data.Function(($)) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Prelude(Show) + +newtype DAPDocs = + DAPDocs + [DAPDoc] + deriving (Eq, Ord, Show) + +instance Semigroup DAPDocs where + DAPDocs x <> DAPDocs y = + DAPDocs (x <> y) + +instance Monoid DAPDocs where + mappend = + (<>) + mempty = + DAPDocs mempty + +instance FromJSON DAPDocs where + parseJSON = + withArray "DAPDocs" $ \v -> + DAPDocs <$> traverse parseJSON (toList v) + +instance ToJSON DAPDocs where + toJSON (DAPDocs x) = + toJSON x + +instance Wrapped DAPDocs where + type Unwrapped DAPDocs = + [DAPDoc] + _Wrapped' = + iso (\(DAPDocs x) -> x) DAPDocs + +instance DAPDocs ~ x => + Rewrapped DAPDocs x + +instance Cons DAPDocs DAPDocs DAPDoc DAPDoc where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc DAPDocs DAPDocs DAPDoc DAPDoc where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each DAPDocs DAPDocs DAPDoc DAPDoc where + each = + _Wrapped . each + +instance Reversing DAPDocs where + reversing = + _Wrapped %~ reversing + +instance Plated DAPDocs where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue DAPDocs = DAPDoc +type instance Index DAPDocs = Int +instance Ixed DAPDocs where + ix i = + _Wrapped . ix i + +class ManyDAPDocs a => AsDAPDocs a where + _DAPDocs :: + Prism' a DAPDocs + default _DAPDocs :: + IsDAPDocs a => + Prism' a DAPDocs + _DAPDocs = + _IsDAPDocs + +instance AsDAPDocs DAPDocs where + _DAPDocs = + id + +class FoldDAPDocs a where + _FoldDAPDocs :: + Fold a DAPDocs + +instance FoldDAPDocs DAPDocs where + _FoldDAPDocs = + id + +class FoldDAPDocs a => GetDAPDocs a where + _GetDAPDocs :: + Getter a DAPDocs + default _GetDAPDocs :: + HasDAPDocs a => + Getter a DAPDocs + _GetDAPDocs = + dapDocs + +instance GetDAPDocs DAPDocs where + _GetDAPDocs = + id + +class SetDAPDocs a where + _SetDAPDocs :: + Setter' a DAPDocs + default _SetDAPDocs :: + ManyDAPDocs a => + Setter' a DAPDocs + _SetDAPDocs = + _ManyDAPDocs + +instance SetDAPDocs DAPDocs where + _SetDAPDocs = + id + +class (FoldDAPDocs a, SetDAPDocs a) => ManyDAPDocs a where + _ManyDAPDocs :: + Traversal' a DAPDocs + +instance ManyDAPDocs DAPDocs where + _ManyDAPDocs = + id + +class (GetDAPDocs a, ManyDAPDocs a) => HasDAPDocs a where + dapDocs :: + Lens' a DAPDocs + default dapDocs :: + IsDAPDocs a => + Lens' a DAPDocs + dapDocs = + _IsDAPDocs + +instance HasDAPDocs DAPDocs where + dapDocs = + id + +class (HasDAPDocs a, AsDAPDocs a) => IsDAPDocs a where + _IsDAPDocs :: + Iso' a DAPDocs + +instance IsDAPDocs DAPDocs where + _IsDAPDocs = + id + +instance SetDAPDocs () where +instance FoldDAPDocs () where + _FoldDAPDocs = + _ManyDAPDocs +instance ManyDAPDocs () where + _ManyDAPDocs _ x = + pure x + +instance SetHref DAPDocs where +instance FoldHref DAPDocs where + _FoldHref = + _ManyHref + +instance ManyHref DAPDocs where + _ManyHref = + _Wrapped . traverse . _ManyHref diff --git a/src/Data/Aviation/Aip/DAPEntries.hs b/src/Data/Aviation/Aip/DAPEntries.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/DAPEntries.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.DAPEntries( + DAPEntries(..) +, AsDAPEntries(..) +, FoldDAPEntries(..) +, GetDAPEntries(..) +, SetDAPEntries(..) +, ManyDAPEntries(..) +, HasDAPEntries(..) +, IsDAPEntries(..) +) where + +import Control.Category((.), id) +import Control.Applicative(pure) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withArray) +import Data.Aviation.Aip.Href(SetHref, FoldHref, ManyHref(_ManyHref), FoldHref(_FoldHref)) +import Data.Aviation.Aip.DAPEntry(DAPEntry) +import Data.Eq(Eq) +import Data.Foldable(toList) +import Data.Function(($)) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Prelude(Show) + +newtype DAPEntries = + DAPEntries + [DAPEntry] + deriving (Eq, Ord, Show) + +instance Semigroup DAPEntries where + DAPEntries x <> DAPEntries y = + DAPEntries (x <> y) + +instance Monoid DAPEntries where + mappend = + (<>) + mempty = + DAPEntries mempty + +instance Wrapped DAPEntries where + type Unwrapped DAPEntries = [DAPEntry] + _Wrapped' = + iso + (\(DAPEntries x) -> x) + DAPEntries + +instance DAPEntries ~ a => + Rewrapped DAPEntries a + +instance FromJSON DAPEntries where + parseJSON = + withArray "DAPEntries" $ \v -> + DAPEntries <$> traverse parseJSON (toList v) + +instance ToJSON DAPEntries where + toJSON (DAPEntries x) = + toJSON x + +instance Cons DAPEntries DAPEntries DAPEntry DAPEntry where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc DAPEntries DAPEntries DAPEntry DAPEntry where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each DAPEntries DAPEntries DAPEntry DAPEntry where + each = + _Wrapped . each + +instance Reversing DAPEntries where + reversing = + _Wrapped %~ reversing + +instance Plated DAPEntries where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue DAPEntries = DAPEntry +type instance Index DAPEntries = Int +instance Ixed DAPEntries where + ix i = + _Wrapped . ix i + +class ManyDAPEntries a => AsDAPEntries a where + _DAPEntries :: + Prism' a DAPEntries + default _DAPEntries :: + IsDAPEntries a => + Prism' a DAPEntries + _DAPEntries = + _IsDAPEntries + +instance AsDAPEntries DAPEntries where + _DAPEntries = + id + +class FoldDAPEntries a where + _FoldDAPEntries :: + Fold a DAPEntries + +instance FoldDAPEntries DAPEntries where + _FoldDAPEntries = + id + +class FoldDAPEntries a => GetDAPEntries a where + _GetDAPEntries :: + Getter a DAPEntries + default _GetDAPEntries :: + HasDAPEntries a => + Getter a DAPEntries + _GetDAPEntries = + dapEntries + +instance GetDAPEntries DAPEntries where + _GetDAPEntries = + id + +class SetDAPEntries a where + _SetDAPEntries :: + Setter' a DAPEntries + default _SetDAPEntries :: + ManyDAPEntries a => + Setter' a DAPEntries + _SetDAPEntries = + _ManyDAPEntries + +instance SetDAPEntries DAPEntries where + _SetDAPEntries = + id + +class (FoldDAPEntries a, SetDAPEntries a) => ManyDAPEntries a where + _ManyDAPEntries :: + Traversal' a DAPEntries + +instance ManyDAPEntries DAPEntries where + _ManyDAPEntries = + id + +class (GetDAPEntries a, ManyDAPEntries a) => HasDAPEntries a where + dapEntries :: + Lens' a DAPEntries + default dapEntries :: + IsDAPEntries a => + Lens' a DAPEntries + dapEntries = + _IsDAPEntries + +instance HasDAPEntries DAPEntries where + dapEntries = + id + +class (HasDAPEntries a, AsDAPEntries a) => IsDAPEntries a where + _IsDAPEntries :: + Iso' a DAPEntries + +instance IsDAPEntries DAPEntries where + _IsDAPEntries = + id + +instance SetDAPEntries () where +instance FoldDAPEntries () where + _FoldDAPEntries = + _ManyDAPEntries +instance ManyDAPEntries () where + _ManyDAPEntries _ x = + pure x + +instance SetHref DAPEntries where +instance FoldHref DAPEntries where + _FoldHref = + _ManyHref + +instance ManyHref DAPEntries where + _ManyHref = + _Wrapped . traverse . _ManyHref diff --git a/src/Data/Aviation/Aip/DAPEntry.hs b/src/Data/Aviation/Aip/DAPEntry.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/DAPEntry.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.DAPEntry( + DAPEntry(..) +, AsDAPEntry(..) +, FoldDAPEntry(..) +, GetDAPEntry(..) +, SetDAPEntry(..) +, ManyDAPEntry(..) +, HasDAPEntry(..) +, IsDAPEntry(..) +) where + +import Control.Category(id) +import Control.Applicative(pure, (<*>)) +import Control.Lens hiding ((.=)) +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withObject, object, (.:), (.=)) +import Data.Aviation.Aip.AipDate(AipDate) +import Data.Aviation.Aip.Amendment(Amendment) +import Data.Aviation.Aip.Href(Href, SetHref, FoldHref(_FoldHref), ManyHref(_ManyHref), GetHref, HasHref(href)) +import Data.Aviation.Aip.Txt(Txt) +import Data.Eq(Eq) +import Data.Function(($)) +import Data.Functor(fmap, (<$>)) +import Data.Ord(Ord) +import Prelude(Show) + +data DAPEntry = + DAPEntry + Href + Txt + AipDate + Amendment + deriving (Eq, Ord, Show) + +instance FromJSON DAPEntry where + parseJSON = + withObject "DAPEntry" $ \v -> + DAPEntry <$> + v .: "href" <*> + v .: "txt" <*> + v .: "date" <*> + v .: "amendment" + +instance ToJSON DAPEntry where + toJSON (DAPEntry u txt date amendment) = + object ["href" .= u, "txt" .= txt, "date" .= date, "amendment" .= amendment] + +class ManyDAPEntry a => AsDAPEntry a where + _DAPEntry :: + Prism' a DAPEntry + default _DAPEntry :: + IsDAPEntry a => + Prism' a DAPEntry + _DAPEntry = + _IsDAPEntry + +instance AsDAPEntry DAPEntry where + _DAPEntry = + id + +class FoldDAPEntry a where + _FoldDAPEntry :: + Fold a DAPEntry + +instance FoldDAPEntry DAPEntry where + _FoldDAPEntry = + id + +class FoldDAPEntry a => GetDAPEntry a where + _GetDAPEntry :: + Getter a DAPEntry + default _GetDAPEntry :: + HasDAPEntry a => + Getter a DAPEntry + _GetDAPEntry = + dapEntry + +instance GetDAPEntry DAPEntry where + _GetDAPEntry = + id + +class SetDAPEntry a where + _SetDAPEntry :: + Setter' a DAPEntry + default _SetDAPEntry :: + ManyDAPEntry a => + Setter' a DAPEntry + _SetDAPEntry = + _ManyDAPEntry + +instance SetDAPEntry DAPEntry where + _SetDAPEntry = + id + +class (FoldDAPEntry a, SetDAPEntry a) => ManyDAPEntry a where + _ManyDAPEntry :: + Traversal' a DAPEntry + +instance ManyDAPEntry DAPEntry where + _ManyDAPEntry = + id + +class (GetDAPEntry a, ManyDAPEntry a) => HasDAPEntry a where + dapEntry :: + Lens' a DAPEntry + default dapEntry :: + IsDAPEntry a => + Lens' a DAPEntry + dapEntry = + _IsDAPEntry + +instance HasDAPEntry DAPEntry where + dapEntry = + id + +class (HasDAPEntry a, AsDAPEntry a) => IsDAPEntry a where + _IsDAPEntry :: + Iso' a DAPEntry + +instance IsDAPEntry DAPEntry where + _IsDAPEntry = + id + +instance SetDAPEntry () where +instance FoldDAPEntry () where + _FoldDAPEntry = + _ManyDAPEntry +instance ManyDAPEntry () where + _ManyDAPEntry _ x = + pure x + +instance SetHref DAPEntry where +instance FoldHref DAPEntry where + _FoldHref = + _ManyHref + +instance ManyHref DAPEntry where + _ManyHref f (DAPEntry u txt date amendment) = + DAPEntry <$> f u <*> pure txt <*> pure date <*> pure amendment + +instance GetHref DAPEntry where +instance HasHref DAPEntry where + href f (DAPEntry u txt date amendment) = + fmap (\u' -> DAPEntry u' txt date amendment) (f u) diff --git a/src/Data/Aviation/Aip/DAPType.hs b/src/Data/Aviation/Aip/DAPType.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/DAPType.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.DAPType( + DAPType(..) +, DAPType' +, AsDAPType(..) +, FoldDAPType(..) +, GetDAPType(..) +, SetDAPType(..) +, ManyDAPType(..) +, HasDAPType(..) +, IsDAPType(..) +) where + +import Control.Category(id) +import Control.Lens hiding ((.=)) +import Control.Monad(fail) +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), Value(Object), object, (.=)) +import Data.Eq(Eq) +import Data.Functor((<$>)) +import qualified Data.HashMap.Strict as HashMap(toList) +import Data.Ord(Ord) +import Prelude(Show) + +data DAPType aerodrome = + SpecNotManTOCDAP + | ChecklistTOCDAP + | LegendInfoTablesTOCDAP + | AeroProcChartsTOCDAP aerodrome + deriving (Eq, Ord, Show) + +type DAPType' = + DAPType () + +instance FromJSON aerodrome => FromJSON (DAPType aerodrome) where + parseJSON (Object z) = + case HashMap.toList z of + [("SpecNotManTOCDAP", q)] -> + (\() -> SpecNotManTOCDAP) <$> parseJSON q + [("ChecklistTOCDAP", q)] -> + (\() -> ChecklistTOCDAP) <$> parseJSON q + [("LegendInfoTablesTOCDAP", q)] -> + (\() -> LegendInfoTablesTOCDAP) <$> parseJSON q + [("AeroProcChartsTOCDAP", q)] -> + AeroProcChartsTOCDAP <$> parseJSON q + _ -> + fail "DAPType" + parseJSON _ = + fail "DAPType" + +instance ToJSON aerodrome => ToJSON (DAPType aerodrome) where + toJSON SpecNotManTOCDAP = + object ["SpecNotManTOCDAP" .= toJSON ()] + toJSON ChecklistTOCDAP = + object ["ChecklistTOCDAP" .= toJSON ()] + toJSON LegendInfoTablesTOCDAP = + object ["LegendInfoTablesTOCDAP" .= toJSON ()] + toJSON (AeroProcChartsTOCDAP x) = + object ["AeroProcChartsTOCDAP" .= toJSON x] + +class ManyDAPType a => AsDAPType a where + _DAPType :: + Prism (a aerodrome) (a aerodrome') (DAPType aerodrome) (DAPType aerodrome') + default _DAPType :: + IsDAPType a => + Prism (a aerodrome) (a aerodrome') (DAPType aerodrome) (DAPType aerodrome') + _DAPType = + _IsDAPType + +instance AsDAPType DAPType where + _DAPType = + id + +class FoldDAPType a where + _FoldDAPType :: + Fold (a aerodrome) (DAPType aerodrome) + +instance FoldDAPType DAPType where + _FoldDAPType = + id + +class FoldDAPType a => GetDAPType a where + _GetDAPType :: + Getter (a aerodrome) (DAPType aerodrome) + default _GetDAPType :: + HasDAPType a => + Getter (a aerodrome) (DAPType aerodrome) + _GetDAPType = + dapType + +instance GetDAPType DAPType where + _GetDAPType = + id + +class SetDAPType a where + _SetDAPType :: + Setter (a aerodrome) (a aerodrome') (DAPType aerodrome) (DAPType aerodrome') + default _SetDAPType :: + ManyDAPType a => + Setter (a aerodrome) (a aerodrome') (DAPType aerodrome) (DAPType aerodrome') + _SetDAPType = + _ManyDAPType + +instance SetDAPType DAPType where + _SetDAPType = + id + +class (FoldDAPType a, SetDAPType a) => ManyDAPType a where + _ManyDAPType :: + Traversal (a aerodrome) (a aerodrome') (DAPType aerodrome) (DAPType aerodrome') + +instance ManyDAPType DAPType where + _ManyDAPType = + id + +class (GetDAPType a, ManyDAPType a) => HasDAPType a where + dapType :: + Lens (a aerodrome) (a aerodrome') (DAPType aerodrome) (DAPType aerodrome') + default dapType :: + IsDAPType a => + Lens (a aerodrome) (a aerodrome') (DAPType aerodrome) (DAPType aerodrome') + dapType = + _IsDAPType + +instance HasDAPType DAPType where + dapType = + id + +class (HasDAPType a, AsDAPType a) => IsDAPType a where + _IsDAPType :: + Iso (a aerodrome) (a aerodrome') (DAPType aerodrome) (DAPType aerodrome') + +instance IsDAPType DAPType where + _IsDAPType = + id diff --git a/src/Data/Aviation/Aip/Day.hs b/src/Data/Aviation/Aip/Day.hs deleted file mode 100644 --- a/src/Data/Aviation/Aip/Day.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} - -module Data.Aviation.Aip.Day( - Day(..) -, parseDay -, HasDay(..) -) where - -import Data.Digit(Digit, parsedigit) -import Text.Parser.Char(CharParsing) -import Papa - -data Day = - Day { - _day1 :: - Digit - , _day2 :: - Digit - } deriving (Eq, Ord, Show) - -parseDay :: - (CharParsing p, Monad p) => - p Day -parseDay = - Day <$> parsedigit <*> parsedigit - -makeClassy ''Day diff --git a/src/Data/Aviation/Aip/DocumentNumber.hs b/src/Data/Aviation/Aip/DocumentNumber.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/DocumentNumber.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.DocumentNumber( + DocumentNumber(..) +, AsDocumentNumber(..) +, FoldDocumentNumber(..) +, GetDocumentNumber(..) +, SetDocumentNumber(..) +, ManyDocumentNumber(..) +, HasDocumentNumber(..) +, IsDocumentNumber(..) +) where + +import Control.Category((.), id) +import Control.Applicative(pure) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON)) +import Data.Char(Char) +import Data.Eq(Eq) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Data.String(String) +import Prelude(Show) + +newtype DocumentNumber = + DocumentNumber + String + deriving (Eq, Ord, Show) + +instance FromJSON DocumentNumber where + parseJSON v = + DocumentNumber <$> parseJSON v + +instance ToJSON DocumentNumber where + toJSON (DocumentNumber x) = + toJSON x + +instance Semigroup DocumentNumber where + DocumentNumber x <> DocumentNumber y = + DocumentNumber (x <> y) + +instance Monoid DocumentNumber where + mappend = + (<>) + mempty = + DocumentNumber mempty + +instance Cons DocumentNumber DocumentNumber Char Char where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc DocumentNumber DocumentNumber Char Char where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each DocumentNumber DocumentNumber Char Char where + each = + _Wrapped . each + +instance Reversing DocumentNumber where + reversing = + _Wrapped %~ reversing + +instance Plated DocumentNumber where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue DocumentNumber = Char +type instance Index DocumentNumber = Int +instance Ixed DocumentNumber where + ix i = + _Wrapped . ix i + +instance Wrapped DocumentNumber where + type Unwrapped DocumentNumber = String + _Wrapped' = + iso + (\(DocumentNumber x) -> x) + DocumentNumber + +instance DocumentNumber ~ a => + Rewrapped DocumentNumber a + +class ManyDocumentNumber a => AsDocumentNumber a where + _DocumentNumber :: + Prism' a DocumentNumber + default _DocumentNumber :: + IsDocumentNumber a => + Prism' a DocumentNumber + _DocumentNumber = + _IsDocumentNumber + +instance AsDocumentNumber DocumentNumber where + _DocumentNumber = + id + +instance AsDocumentNumber String where + _DocumentNumber = + from _Wrapped + +class FoldDocumentNumber a where + _FoldDocumentNumber :: + Fold a DocumentNumber + +instance FoldDocumentNumber DocumentNumber where + _FoldDocumentNumber = + id + +instance FoldDocumentNumber String where + _FoldDocumentNumber = + from _Wrapped + +class FoldDocumentNumber a => GetDocumentNumber a where + _GetDocumentNumber :: + Getter a DocumentNumber + default _GetDocumentNumber :: + HasDocumentNumber a => + Getter a DocumentNumber + _GetDocumentNumber = + documentNumber + +instance GetDocumentNumber DocumentNumber where + _GetDocumentNumber = + id + +instance GetDocumentNumber String where + _GetDocumentNumber = + from _Wrapped + +class SetDocumentNumber a where + _SetDocumentNumber :: + Setter' a DocumentNumber + default _SetDocumentNumber :: + ManyDocumentNumber a => + Setter' a DocumentNumber + _SetDocumentNumber = + _ManyDocumentNumber + +instance SetDocumentNumber DocumentNumber where + _SetDocumentNumber = + id + +instance SetDocumentNumber String where + _SetDocumentNumber = + from _Wrapped + +class (FoldDocumentNumber a, SetDocumentNumber a) => ManyDocumentNumber a where + _ManyDocumentNumber :: + Traversal' a DocumentNumber + +instance ManyDocumentNumber DocumentNumber where + _ManyDocumentNumber = + id + +instance ManyDocumentNumber String where + _ManyDocumentNumber = + from _Wrapped + +class (GetDocumentNumber a, ManyDocumentNumber a) => HasDocumentNumber a where + documentNumber :: + Lens' a DocumentNumber + default documentNumber :: + IsDocumentNumber a => + Lens' a DocumentNumber + documentNumber = + _IsDocumentNumber + +instance HasDocumentNumber DocumentNumber where + documentNumber = + id + +instance HasDocumentNumber String where + documentNumber = + from _Wrapped + +class (HasDocumentNumber a, AsDocumentNumber a) => IsDocumentNumber a where + _IsDocumentNumber :: + Iso' a DocumentNumber + +instance IsDocumentNumber DocumentNumber where + _IsDocumentNumber = + id + +instance IsDocumentNumber String where + _IsDocumentNumber = + from _Wrapped + +instance SetDocumentNumber () where +instance FoldDocumentNumber () where + _FoldDocumentNumber = + _ManyDocumentNumber +instance ManyDocumentNumber () where + _ManyDocumentNumber _ x = + pure x diff --git a/src/Data/Aviation/Aip/Ersa.hs b/src/Data/Aviation/Aip/Ersa.hs --- a/src/Data/Aviation/Aip/Ersa.hs +++ b/src/Data/Aviation/Aip/Ersa.hs @@ -1,21 +1,153 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DefaultSignatures #-} module Data.Aviation.Aip.Ersa( Ersa(..) +, AsErsa(..) +, FoldErsa(..) +, GetErsa(..) +, SetErsa(..) +, ManyErsa(..) , HasErsa(..) +, IsErsa(..) ) where -import Data.Aviation.Aip.AipHref(AipHref) -import Data.Aviation.Aip.AipDate(AipDate) -import Papa +import Control.Category(id) +import Control.Applicative(pure, (<*>)) +import Control.Lens hiding ((.=)) +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withObject, object, (.:), (.=)) +import Data.Aviation.Aip.Href(Href, SetHref, FoldHref, ManyHref(_ManyHref), FoldHref(_FoldHref)) +import Data.Aviation.Aip.ListItemLinks(ListItemLinks) +import Data.Aviation.Aip.ErsaAerodromes(ErsaAerodromes) +import Data.Eq(Eq) +import Data.Function(($)) +import Data.Functor((<$>)) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Prelude(Show) data Ersa = - Ersa { - _ersaHref :: - AipHref - , _ersaDate :: - AipDate - } deriving (Eq, Ord, Show) + Ersa + ListItemLinks + ErsaAerodromes + [Href] -- complete ERSA + deriving (Eq, Ord, Show) + +instance Semigroup Ersa where + Ersa l1 a1 c1 <> Ersa l2 a2 c2 = + Ersa (l1 <> l2) (a1 <> a2) (c1 <> c2) -makeClassy ''Ersa +instance Monoid Ersa where + mappend = + (<>) + mempty = + Ersa mempty mempty mempty + +instance FromJSON Ersa where + parseJSON = + withObject "Ersa" $ \v -> + Ersa <$> + v .: "links" <*> + v .: "aerodromes" <*> + v .: "complete" + +instance ToJSON Ersa where + toJSON (Ersa links aerodromes complete) = + object ["links" .= links, "aerodromes" .= aerodromes, "complete" .= complete] + +class ManyErsa a => AsErsa a where + _Ersa :: + Prism' a Ersa + default _Ersa :: + IsErsa a => + Prism' a Ersa + _Ersa = + _IsErsa + +instance AsErsa Ersa where + _Ersa = + id + +class FoldErsa a where + _FoldErsa :: + Fold a Ersa + +instance FoldErsa Ersa where + _FoldErsa = + id + +class FoldErsa a => GetErsa a where + _GetErsa :: + Getter a Ersa + default _GetErsa :: + HasErsa a => + Getter a Ersa + _GetErsa = + ersa + +instance GetErsa Ersa where + _GetErsa = + id + +class SetErsa a where + _SetErsa :: + Setter' a Ersa + default _SetErsa :: + ManyErsa a => + Setter' a Ersa + _SetErsa = + _ManyErsa + +instance SetErsa Ersa where + _SetErsa = + id + +class (FoldErsa a, SetErsa a) => ManyErsa a where + _ManyErsa :: + Traversal' a Ersa + +instance ManyErsa Ersa where + _ManyErsa = + id + +class (GetErsa a, ManyErsa a) => HasErsa a where + ersa :: + Lens' a Ersa + default ersa :: + IsErsa a => + Lens' a Ersa + ersa = + _IsErsa + +instance HasErsa Ersa where + ersa = + id + +class (HasErsa a, AsErsa a) => IsErsa a where + _IsErsa :: + Iso' a Ersa + +instance IsErsa Ersa where + _IsErsa = + id + +instance SetErsa () where +instance FoldErsa () where + _FoldErsa = + _ManyErsa +instance ManyErsa () where + _ManyErsa _ x = + pure x + +---- + +instance SetHref Ersa where +instance FoldHref Ersa where + _FoldHref = + _ManyHref + +instance ManyHref Ersa where + _ManyHref f (Ersa l a c) = + Ersa <$> _ManyHref f l <*> _ManyHref f a <*> traverse f c diff --git a/src/Data/Aviation/Aip/ErsaAerodrome.hs b/src/Data/Aviation/Aip/ErsaAerodrome.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/ErsaAerodrome.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.ErsaAerodrome( + ErsaAerodrome(..) +, AsErsaAerodrome(..) +, FoldErsaAerodrome(..) +, GetErsaAerodrome(..) +, SetErsaAerodrome(..) +, ManyErsaAerodrome(..) +, HasErsaAerodrome(..) +, IsErsaAerodrome(..) +) where + +import Control.Category(id) +import Control.Applicative(pure, (<*>)) +import Control.Lens hiding ((.=)) +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withObject, object, (.:), (.=)) +import Data.Aviation.Aip.Href(Href, SetHref, FoldHref, ManyHref(_ManyHref), FoldHref(_FoldHref)) +import Data.Eq(Eq) +import Data.Function(($)) +import Data.Functor((<$>)) +import Data.Ord(Ord) +import Data.Maybe(Maybe) +import Data.String(String) +import Prelude(Show) + +data ErsaAerodrome = + ErsaAerodrome + String + Href + (Maybe Href) + deriving (Eq, Ord, Show) + +instance FromJSON ErsaAerodrome where + parseJSON = + withObject "ErsaAerodrome" $ \v -> + ErsaAerodrome <$> + v .: "aerodrome" <*> + v .: "fac_href" <*> + v .: "rds_href" + +instance ToJSON ErsaAerodrome where + toJSON (ErsaAerodrome aerodrome fac rds) = + object ["aerodrome" .= aerodrome, "fac_href" .= fac, "rds_href" .= rds] + +class ManyErsaAerodrome a => AsErsaAerodrome a where + _ErsaAerodrome :: + Prism' a ErsaAerodrome + default _ErsaAerodrome :: + IsErsaAerodrome a => + Prism' a ErsaAerodrome + _ErsaAerodrome = + _IsErsaAerodrome + +instance AsErsaAerodrome ErsaAerodrome where + _ErsaAerodrome = + id + +class FoldErsaAerodrome a where + _FoldErsaAerodrome :: + Fold a ErsaAerodrome + +instance FoldErsaAerodrome ErsaAerodrome where + _FoldErsaAerodrome = + id + +class FoldErsaAerodrome a => GetErsaAerodrome a where + _GetErsaAerodrome :: + Getter a ErsaAerodrome + default _GetErsaAerodrome :: + HasErsaAerodrome a => + Getter a ErsaAerodrome + _GetErsaAerodrome = + ersaAerodrome + +instance GetErsaAerodrome ErsaAerodrome where + _GetErsaAerodrome = + id + +class SetErsaAerodrome a where + _SetErsaAerodrome :: + Setter' a ErsaAerodrome + default _SetErsaAerodrome :: + ManyErsaAerodrome a => + Setter' a ErsaAerodrome + _SetErsaAerodrome = + _ManyErsaAerodrome + +instance SetErsaAerodrome ErsaAerodrome where + _SetErsaAerodrome = + id + +class (FoldErsaAerodrome a, SetErsaAerodrome a) => ManyErsaAerodrome a where + _ManyErsaAerodrome :: + Traversal' a ErsaAerodrome + +instance ManyErsaAerodrome ErsaAerodrome where + _ManyErsaAerodrome = + id + +class (GetErsaAerodrome a, ManyErsaAerodrome a) => HasErsaAerodrome a where + ersaAerodrome :: + Lens' a ErsaAerodrome + default ersaAerodrome :: + IsErsaAerodrome a => + Lens' a ErsaAerodrome + ersaAerodrome = + _IsErsaAerodrome + +instance HasErsaAerodrome ErsaAerodrome where + ersaAerodrome = + id + +class (HasErsaAerodrome a, AsErsaAerodrome a) => IsErsaAerodrome a where + _IsErsaAerodrome :: + Iso' a ErsaAerodrome + +instance IsErsaAerodrome ErsaAerodrome where + _IsErsaAerodrome = + id + +instance SetErsaAerodrome () where +instance FoldErsaAerodrome () where + _FoldErsaAerodrome = + _ManyErsaAerodrome +instance ManyErsaAerodrome () where + _ManyErsaAerodrome _ x = + pure x + +---- + +instance SetHref ErsaAerodrome where +instance FoldHref ErsaAerodrome where + _FoldHref = + _ManyHref + +instance ManyHref ErsaAerodrome where + _ManyHref f (ErsaAerodrome aerodrome fac rds) = + ErsaAerodrome <$> pure aerodrome <*> f fac <*> traverse f rds + diff --git a/src/Data/Aviation/Aip/ErsaAerodromes.hs b/src/Data/Aviation/Aip/ErsaAerodromes.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/ErsaAerodromes.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} + +module Data.Aviation.Aip.ErsaAerodromes( + ErsaAerodromes(..) +, AsErsaAerodromes(..) +, FoldErsaAerodromes(..) +, GetErsaAerodromes(..) +, SetErsaAerodromes(..) +, ManyErsaAerodromes(..) +, HasErsaAerodromes(..) +, IsErsaAerodromes(..) +) where + +import Control.Category((.), id) +import Control.Applicative(pure) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withArray) +import Data.Eq(Eq) +import Data.Foldable(toList) +import Data.Function(($)) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Prelude(Show) +import Data.Aviation.Aip.ErsaAerodrome(ErsaAerodrome) +import Data.Aviation.Aip.Href(SetHref, FoldHref, ManyHref(_ManyHref), FoldHref(_FoldHref)) + +newtype ErsaAerodromes = + ErsaAerodromes + [ErsaAerodrome] + deriving (Eq, Ord, Show) + +instance Semigroup ErsaAerodromes where + ErsaAerodromes x <> ErsaAerodromes y = + ErsaAerodromes (x <> y) + +instance Monoid ErsaAerodromes where + mappend = + (<>) + mempty = + ErsaAerodromes [] + +instance Wrapped ErsaAerodromes where + type Unwrapped ErsaAerodromes = + [ErsaAerodrome] + _Wrapped' = + iso (\(ErsaAerodromes x) -> x) ErsaAerodromes + +instance ErsaAerodromes ~ x => + Rewrapped ErsaAerodromes x + +instance FromJSON ErsaAerodromes where + parseJSON = + withArray "ErsaAerodromes" $ \v -> + ErsaAerodromes <$> traverse parseJSON (toList v) + +instance ToJSON ErsaAerodromes where + toJSON (ErsaAerodromes x) = + toJSON x + +instance Cons ErsaAerodromes ErsaAerodromes ErsaAerodrome ErsaAerodrome where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc ErsaAerodromes ErsaAerodromes ErsaAerodrome ErsaAerodrome where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each ErsaAerodromes ErsaAerodromes ErsaAerodrome ErsaAerodrome where + each = + _Wrapped . each + +instance Reversing ErsaAerodromes where + reversing = + _Wrapped %~ reversing + +instance Plated ErsaAerodromes where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue ErsaAerodromes = ErsaAerodrome +type instance Index ErsaAerodromes = Int +instance Ixed ErsaAerodromes where + ix i = + _Wrapped . ix i + +class ManyErsaAerodromes a => AsErsaAerodromes a where + _ErsaAerodromes :: + Prism' a ErsaAerodromes + default _ErsaAerodromes :: + IsErsaAerodromes a => + Prism' a ErsaAerodromes + _ErsaAerodromes = + _IsErsaAerodromes + +instance AsErsaAerodromes ErsaAerodromes where + _ErsaAerodromes = + id + +class FoldErsaAerodromes a where + _FoldErsaAerodromes :: + Fold a ErsaAerodromes + +instance FoldErsaAerodromes ErsaAerodromes where + _FoldErsaAerodromes = + id + +class FoldErsaAerodromes a => GetErsaAerodromes a where + _GetErsaAerodromes :: + Getter a ErsaAerodromes + default _GetErsaAerodromes :: + HasErsaAerodromes a => + Getter a ErsaAerodromes + _GetErsaAerodromes = + ersaAerodromes + +instance GetErsaAerodromes ErsaAerodromes where + _GetErsaAerodromes = + id + +class SetErsaAerodromes a where + _SetErsaAerodromes :: + Setter' a ErsaAerodromes + default _SetErsaAerodromes :: + ManyErsaAerodromes a => + Setter' a ErsaAerodromes + _SetErsaAerodromes = + _ManyErsaAerodromes + +instance SetErsaAerodromes ErsaAerodromes where + _SetErsaAerodromes = + id + +class (FoldErsaAerodromes a, SetErsaAerodromes a) => ManyErsaAerodromes a where + _ManyErsaAerodromes :: + Traversal' a ErsaAerodromes + +instance ManyErsaAerodromes ErsaAerodromes where + _ManyErsaAerodromes = + id + +class (GetErsaAerodromes a, ManyErsaAerodromes a) => HasErsaAerodromes a where + ersaAerodromes :: + Lens' a ErsaAerodromes + default ersaAerodromes :: + IsErsaAerodromes a => + Lens' a ErsaAerodromes + ersaAerodromes = + _IsErsaAerodromes + +instance HasErsaAerodromes ErsaAerodromes where + ersaAerodromes = + id + +class (HasErsaAerodromes a, AsErsaAerodromes a) => IsErsaAerodromes a where + _IsErsaAerodromes :: + Iso' a ErsaAerodromes + +instance IsErsaAerodromes ErsaAerodromes where + _IsErsaAerodromes = + id + +instance SetErsaAerodromes () where +instance FoldErsaAerodromes () where + _FoldErsaAerodromes = + _ManyErsaAerodromes +instance ManyErsaAerodromes () where + _ManyErsaAerodromes _ x = + pure x + +---- + +instance SetHref ErsaAerodromes where +instance FoldHref ErsaAerodromes where + _FoldHref = + _ManyHref + +instance ManyHref ErsaAerodromes where + _ManyHref = + _Wrapped . traverse . _ManyHref diff --git a/src/Data/Aviation/Aip/Ersas.hs b/src/Data/Aviation/Aip/Ersas.hs deleted file mode 100644 --- a/src/Data/Aviation/Aip/Ersas.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Data.Aviation.Aip.Ersas( - Ersas(..) -, parseAipTree -) where - -import Data.Aviation.Aip.Ersa(Ersa(Ersa)) -import Data.Aviation.Aip.AipDate(parseAipDate) -import Data.Aviation.Aip.AipHref(parseAipHref) -import Text.HTML.TagSoup(Tag(TagText)) -import Text.HTML.TagSoup.Tree(TagTree(TagBranch, TagLeaf), parseTree) -import Text.HTML.TagSoup.Tree.Util(htmlRoot) -import Text.HTML.TagSoup.Tree.Zipper(TagTreePos(TagTreePos), traverseTree, fromTagTree) -import Text.Parsec(Parsec, Stream, parse) -import Text.Parser.Char(space, char) -import Text.Parser.Combinators(between) -import Papa - -newtype Ersas = - Ersas - [Ersa] - deriving (Eq, Ord, Show) - -makeWrapped ''Ersas - -instance Monoid Ersas where - mempty = - Ersas - mempty - Ersas x `mappend` Ersas y = - Ersas (x `mappend` y) - -parseAipTree :: - String - -> Ersas -parseAipTree = - let runParse :: - Stream s Identity t => - Parsec s () a - -> s - -> Maybe a - runParse p s = - parse p "aip" s ^? _Right - aipTreeTraversal :: - TagTreePos String - -> Ersas - aipTreeTraversal t = - case t of - TagTreePos (TagBranch "li" [] (TagBranch "a" [("href", href)] [TagLeaf (TagText n)]:TagLeaf (TagText tx):_)) _ _ _ -> - let pdate = do _ <- space - between (char '(') (char ')') parseAipDate - in case n of - "En Route Supplement Australia (ERSA)" -> - let p = do h <- runParse parseAipHref href - d <- runParse pdate tx - pure (Ersas [Ersa h d]) - in fromMaybe mempty p - _ -> - mempty - _ -> - mempty - in traverseTree aipTreeTraversal . fromTagTree . htmlRoot . parseTree diff --git a/src/Data/Aviation/Aip/Href.hs b/src/Data/Aviation/Aip/Href.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/Href.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.Href( + Href(..) +, AsHref(..) +, FoldHref(..) +, GetHref(..) +, SetHref(..) +, ManyHref(..) +, HasHref(..) +, IsHref(..) +, dropHrefFile +, aipPrefix +) where + +import Control.Category((.), id) +import Control.Applicative(pure, (<*>)) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON)) +import Data.Bool(bool) +import Data.Char(Char) +import Data.Eq(Eq((/=))) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.List(reverse, dropWhile, isPrefixOf) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Data.String(String) +import Prelude(Show) + +newtype Href = + Href + String + deriving (Eq, Ord, Show) + +instance FromJSON Href where + parseJSON v = + Href <$> parseJSON v + +instance ToJSON Href where + toJSON (Href x) = + toJSON x + +instance Semigroup Href where + Href x <> Href y = + Href (x <> y) + +instance Monoid Href where + mappend = + (<>) + mempty = + Href mempty + +instance Cons Href Href Char Char where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc Href Href Char Char where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each Href Href Char Char where + each = + _Wrapped . each + +instance Reversing Href where + reversing = + _Wrapped %~ reversing + +instance Plated Href where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue Href = Char +type instance Index Href = Int +instance Ixed Href where + ix i = + _Wrapped . ix i + +instance AsEmpty Href where + _Empty = + _Wrapped . _Empty + +instance Wrapped Href where + type Unwrapped Href = String + _Wrapped' = + iso + (\(Href x) -> x) + Href + +instance Href ~ a => + Rewrapped Href a + +class ManyHref a => AsHref a where + _Href :: + Prism' a Href + default _Href :: + IsHref a => + Prism' a Href + _Href = + _IsHref + +instance AsHref Href where + _Href = + id + +instance AsHref String where + _Href = + from _Wrapped + +class FoldHref a where + _FoldHref :: + Fold a Href + +instance FoldHref Href where + _FoldHref = + id + +instance FoldHref String where + _FoldHref = + from _Wrapped + +class FoldHref a => GetHref a where + _GetHref :: + Getter a Href + default _GetHref :: + HasHref a => + Getter a Href + _GetHref = + href + +instance GetHref Href where + _GetHref = + id + +instance GetHref String where + _GetHref = + from _Wrapped + +class SetHref a where + _SetHref :: + Setter' a Href + default _SetHref :: + ManyHref a => + Traversal' a Href + _SetHref = + _ManyHref + +instance SetHref Href where + _SetHref = + id + +instance SetHref String where + _SetHref = + from _Wrapped + +class (FoldHref a, SetHref a) => ManyHref a where + _ManyHref :: + Traversal' a Href + +instance ManyHref Href where + _ManyHref = + id + +instance ManyHref String where + _ManyHref = + from _Wrapped + +class (GetHref a, ManyHref a) => HasHref a where + href :: + Lens' a Href + default href :: + IsHref a => + Lens' a Href + href = + _IsHref + +instance HasHref Href where + href = + id + +instance HasHref String where + href = + from _Wrapped + +class (HasHref a, AsHref a) => IsHref a where + _IsHref :: + Iso' a Href + +instance IsHref Href where + _IsHref = + id + +instance IsHref String where + _IsHref = + from _Wrapped + +instance SetHref () where +instance FoldHref () where + _FoldHref = + _ManyHref +instance ManyHref () where + _ManyHref _ x = + pure x + +dropHrefFile :: + Href + -> Href +dropHrefFile = + (_Wrapped %~ reverse . dropWhile (/= '/') . reverse) + +aipPrefix :: + ManyHref s => + s + -> s +aipPrefix = + _ManyHref . _Wrapped %~ let p = "/aip/" in bool <$> (p <>) <*> id <*> isPrefixOf p diff --git a/src/Data/Aviation/Aip/HttpRequest.hs b/src/Data/Aviation/Aip/HttpRequest.hs --- a/src/Data/Aviation/Aip/HttpRequest.hs +++ b/src/Data/Aviation/Aip/HttpRequest.hs @@ -1,23 +1,51 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} module Data.Aviation.Aip.HttpRequest( aipRequestGet , aipRequestPost , aipRequestMethod , doRequest +, doRequest' +, doGetRequest +, doPostRequest , requestAipContents +, downloadHref ) where - + +import Control.Category((.)) +import Control.Applicative(pure) +import Control.Lens +import Control.Monad.IO.Class(liftIO) +import Network.HTTP(HandleStream, getAuth, openStream, host, normalizeRequest, defaultNormalizeRequestOptions, close) +import qualified Data.ByteString.Lazy as LazyByteString(writeFile) import Control.Monad.Trans.Except(ExceptT(ExceptT)) +import Data.Aviation.Aip.AipCon(AipCon(AipCon)) +import Data.Aviation.Aip.Log(aiplog) import Data.Aviation.Aip.ConnErrorHttp4xx(ConnErrorHttp4xx(IsConnError, Http4xx)) -import Network.HTTP(HStream, Request, RequestMethod(GET, POST), mkRequest, setRequestBody, simpleHTTP, rspCode, rspBody) +import Data.Aviation.Aip.Href(Href(Href)) +import Data.Bool(Bool(True), bool) +import Data.Either(Either(Left, Right)) +import Data.Eq(Eq((==))) +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +import Data.Foldable(elem) +import Data.Functor((<$>)) +#endif +import Data.Function(($)) +import Data.List(isPrefixOf, dropWhile) +import Data.Maybe(Maybe(Just)) +import Data.Semigroup(Semigroup((<>))) +import Data.String(String) +import Network.HTTP(HStream, Request, RequestMethod(GET, POST), mkRequest, setRequestBody, simpleHTTP, simpleHTTP_, rspCode, rspBody) import Network.BufferType(BufferType) import Network.URI(URI(URI), URIAuth(URIAuth)) -import Papa +import Prelude(Show(show)) +import System.Directory(createDirectoryIfMissing) +import System.FilePath(FilePath, splitFileName, isPathSeparator, ()) aipRequestGet :: BufferType ty => - String + Href -> String -> Request ty aipRequestGet = @@ -25,7 +53,7 @@ aipRequestPost :: BufferType ty => - String + Href -> String -> Request ty aipRequestPost = @@ -34,33 +62,101 @@ aipRequestMethod :: BufferType ty => RequestMethod - -> String + -> Href -> String -> Request ty -aipRequestMethod m s z = - mkRequest m (URI "http:" (Just (URIAuth "" "www.airservicesaustralia.com" "")) ("/aip/" ++ s) z "") +aipRequestMethod m (Href s) z = + let s' = bool ("/aip/" <> s) s ("/aip/" `isPrefixOf` s) + in mkRequest m (URI "http:" (Just (URIAuth "" "www.airservicesaustralia.com" "")) s' z "") doRequest :: HStream a => Request a - -> ExceptT ConnErrorHttp4xx IO a + -> AipCon a doRequest r = + AipCon . pure . ExceptT $ do x <- simpleHTTP r - case x of - Left e -> - pure (Left (IsConnError e)) - Right c -> - let (r1, r2, r3) = rspCode c - in if r1 == 4 then - pure (Left (Http4xx r2 r3)) - else - pure (Right (rspBody c)) + pure $ + case x of + Left e -> + Left (IsConnError e) + Right c -> + let (r1, r2, r3) = rspCode c + in if r1 == 4 then + Left (Http4xx r2 r3) + else + Right (rspBody c) +doRequest' :: + HStream a => + Request a + -> HandleStream a + -> AipCon a +doRequest' r h = + AipCon . pure . + ExceptT $ + do x <- simpleHTTP_ h r + pure $ + case x of + Left e -> + Left (IsConnError e) + Right c -> + let (r1, r2, r3) = rspCode c + in if r1 == 4 then + Left (Http4xx r2 r3) + else + Right (rspBody c) + +doGetRequest :: + HStream a => + Href + -> String + -> AipCon a +doGetRequest s z = + doRequest (aipRequestGet s z) + +doPostRequest :: + HStream a => + Href + -> String + -> AipCon a +doPostRequest s z = + doRequest (aipRequestPost s z) + requestAipContents :: - ExceptT ConnErrorHttp4xx IO String + AipCon String requestAipContents = let r = setRequestBody - (aipRequestPost "aip.asp" "?pg=10") + (aipRequestPost (Href "aip.asp") "?pg=10") ("application/x-www-form-urlencoded", "Submit=I+Agree&check=1") in doRequest r + +downloadHref :: + FilePath + -> Href + -> AipCon FilePath +downloadHref d hf = + do let q = aipRequestGet hf "" + aiplog ("making request for aip document " <> show q) + auth <- getAuth q + aiplog ("making request for aip document with auth " <> show auth) + c <- liftIO $ openStream (host auth) 80 + r <- doRequest' (normalizeRequest defaultNormalizeRequestOptions q) c + let (j, k) = splitFileName (hf ^. _Wrapped) + let ot = d dropWhile isPathSeparator j + aiplog ("output directory for aip document " <> ot) + do liftIO $ createDirectoryIfMissing True ot + let ot' = ot k + let otw = +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + let win = "/\\:*\"?<>|" + repl ch = bool ch '_' (ch `elem` win) + in repl <$> ot' +#else + ot' +#endif + aiplog ("writing aip document " <> otw) + liftIO $ LazyByteString.writeFile otw r + liftIO $ close c + pure ot' diff --git a/src/Data/Aviation/Aip/ListItemLink.hs b/src/Data/Aviation/Aip/ListItemLink.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/ListItemLink.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.ListItemLink( + ListItemLink(..) +, AsListItemLink(..) +, FoldListItemLink(..) +, GetListItemLink(..) +, SetListItemLink(..) +, ManyListItemLink(..) +, HasListItemLink(..) +, IsListItemLink(..) +) where + +import Control.Category(id) +import Control.Applicative(pure, (<*>)) +import Control.Lens hiding ((.=)) +import Data.Aviation.Aip.Href(Href, SetHref, FoldHref(_FoldHref), ManyHref(_ManyHref), GetHref, HasHref(href)) +import Data.Aviation.Aip.Txt(Txt) +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withObject, object, (.:), (.=)) +import Data.Eq(Eq) +import Data.Function(($)) +import Data.Functor(fmap, (<$>)) +import Data.Ord(Ord) +import Prelude(Show) + +data ListItemLink = + ListItemLink + Href + Txt + deriving (Eq, Ord, Show) + +instance FromJSON ListItemLink where + parseJSON = + withObject "ListItemLink" $ \v -> + ListItemLink <$> + v .: "href" <*> + v .: "txt" + +instance ToJSON ListItemLink where + toJSON (ListItemLink u t) = + object ["href" .= u, "txt" .= t] + +class ManyListItemLink a => AsListItemLink a where + _ListItemLink :: + Prism' a ListItemLink + default _ListItemLink :: + IsListItemLink a => + Prism' a ListItemLink + _ListItemLink = + _IsListItemLink + +instance AsListItemLink ListItemLink where + _ListItemLink = + id + +class FoldListItemLink a where + _FoldListItemLink :: + Fold a ListItemLink + +instance FoldListItemLink ListItemLink where + _FoldListItemLink = + id + +class FoldListItemLink a => GetListItemLink a where + _GetListItemLink :: + Getter a ListItemLink + default _GetListItemLink :: + HasListItemLink a => + Getter a ListItemLink + _GetListItemLink = + listItemLink + +instance GetListItemLink ListItemLink where + _GetListItemLink = + id + +class SetListItemLink a where + _SetListItemLink :: + Setter' a ListItemLink + default _SetListItemLink :: + ManyListItemLink a => + Setter' a ListItemLink + _SetListItemLink = + _ManyListItemLink + +instance SetListItemLink ListItemLink where + _SetListItemLink = + id + +class (FoldListItemLink a, SetListItemLink a) => ManyListItemLink a where + _ManyListItemLink :: + Traversal' a ListItemLink + +instance ManyListItemLink ListItemLink where + _ManyListItemLink = + id + +class (GetListItemLink a, ManyListItemLink a) => HasListItemLink a where + listItemLink :: + Lens' a ListItemLink + default listItemLink :: + IsListItemLink a => + Lens' a ListItemLink + listItemLink = + _IsListItemLink + +instance HasListItemLink ListItemLink where + listItemLink = + id + +class (HasListItemLink a, AsListItemLink a) => IsListItemLink a where + _IsListItemLink :: + Iso' a ListItemLink + +instance IsListItemLink ListItemLink where + _IsListItemLink = + id + +instance SetListItemLink () where +instance FoldListItemLink () where + _FoldListItemLink = + _ManyListItemLink +instance ManyListItemLink () where + _ManyListItemLink _ x = + pure x + +---- + +instance SetHref ListItemLink where +instance FoldHref ListItemLink where + _FoldHref = + _ManyHref + +instance ManyHref ListItemLink where + _ManyHref f (ListItemLink u x) = + ListItemLink <$> f u <*> pure x + +instance GetHref ListItemLink where +instance HasHref ListItemLink where + href f (ListItemLink u x) = + fmap (\u' -> ListItemLink u' x) (f u) diff --git a/src/Data/Aviation/Aip/ListItemLinks.hs b/src/Data/Aviation/Aip/ListItemLinks.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/ListItemLinks.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.ListItemLinks( + ListItemLinks(..) +, AsListItemLinks(..) +, FoldListItemLinks(..) +, GetListItemLinks(..) +, SetListItemLinks(..) +, ManyListItemLinks(..) +, HasListItemLinks(..) +, IsListItemLinks(..) +) where + +import Control.Category((.), id) +import Control.Applicative(pure) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withArray) +import Data.Aviation.Aip.Href(SetHref, FoldHref, ManyHref(_ManyHref), FoldHref(_FoldHref)) +import Data.Aviation.Aip.ListItemLink(ListItemLink, ManyListItemLink(_ManyListItemLink), SetListItemLink, FoldListItemLink(_FoldListItemLink)) +import Data.Eq(Eq) +import Data.Foldable(toList) +import Data.Function(($)) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Prelude(Show) + +newtype ListItemLinks = + ListItemLinks + [ListItemLink] + deriving (Eq, Ord, Show) + +instance FromJSON ListItemLinks where + parseJSON = + withArray "ListItemLinks" $ \v -> + ListItemLinks <$> traverse parseJSON (toList v) + +instance ToJSON ListItemLinks where + toJSON (ListItemLinks x) = + toJSON x + +instance Semigroup ListItemLinks where + ListItemLinks x <> ListItemLinks y = + ListItemLinks (x <> y) + +instance Monoid ListItemLinks where + mappend = + (<>) + mempty = + ListItemLinks [] + +instance Wrapped ListItemLinks where + type Unwrapped ListItemLinks = + [ListItemLink] + _Wrapped' = + iso (\(ListItemLinks x) -> x) ListItemLinks + +instance ListItemLinks ~ x => + Rewrapped ListItemLinks x + +instance Cons ListItemLinks ListItemLinks ListItemLink ListItemLink where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc ListItemLinks ListItemLinks ListItemLink ListItemLink where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each ListItemLinks ListItemLinks ListItemLink ListItemLink where + each = + _Wrapped . each + +instance Reversing ListItemLinks where + reversing = + _Wrapped %~ reversing + +instance Plated ListItemLinks where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue ListItemLinks = ListItemLink +type instance Index ListItemLinks = Int +instance Ixed ListItemLinks where + ix i = + _Wrapped . ix i + +class ManyListItemLinks a => AsListItemLinks a where + _ListItemLinks :: + Prism' a ListItemLinks + default _ListItemLinks :: + IsListItemLinks a => + Prism' a ListItemLinks + _ListItemLinks = + _IsListItemLinks + +instance AsListItemLinks ListItemLinks where + _ListItemLinks = + id + +class FoldListItemLinks a where + _FoldListItemLinks :: + Fold a ListItemLinks + +instance FoldListItemLinks ListItemLinks where + _FoldListItemLinks = + id + +class FoldListItemLinks a => GetListItemLinks a where + _GetListItemLinks :: + Getter a ListItemLinks + default _GetListItemLinks :: + HasListItemLinks a => + Getter a ListItemLinks + _GetListItemLinks = + listItemLinks + +instance GetListItemLinks ListItemLinks where + _GetListItemLinks = + id + +class SetListItemLinks a where + _SetListItemLinks :: + Setter' a ListItemLinks + default _SetListItemLinks :: + ManyListItemLinks a => + Setter' a ListItemLinks + _SetListItemLinks = + _ManyListItemLinks + +instance SetListItemLinks ListItemLinks where + _SetListItemLinks = + id + +class (FoldListItemLinks a, SetListItemLinks a) => ManyListItemLinks a where + _ManyListItemLinks :: + Traversal' a ListItemLinks + +instance ManyListItemLinks ListItemLinks where + _ManyListItemLinks = + id + +class (GetListItemLinks a, ManyListItemLinks a) => HasListItemLinks a where + listItemLinks :: + Lens' a ListItemLinks + default listItemLinks :: + IsListItemLinks a => + Lens' a ListItemLinks + listItemLinks = + _IsListItemLinks + +instance HasListItemLinks ListItemLinks where + listItemLinks = + id + +class (HasListItemLinks a, AsListItemLinks a) => IsListItemLinks a where + _IsListItemLinks :: + Iso' a ListItemLinks + +instance IsListItemLinks ListItemLinks where + _IsListItemLinks = + id + +instance SetListItemLinks () where +instance FoldListItemLinks () where + _FoldListItemLinks = + _ManyListItemLinks +instance ManyListItemLinks () where + _ManyListItemLinks _ x = + pure x + +---- + +instance SetListItemLink ListItemLinks where + +instance FoldListItemLink ListItemLinks where + _FoldListItemLink = + _ManyListItemLink + +instance ManyListItemLink ListItemLinks where + _ManyListItemLink f (ListItemLinks x) = + ListItemLinks <$> traverse f x + +instance SetHref ListItemLinks where +instance FoldHref ListItemLinks where + _FoldHref = + _ManyHref + +instance ManyHref ListItemLinks where + _ManyHref = + _Wrapped . traverse . _ManyHref diff --git a/src/Data/Aviation/Aip/ListItemLinks1.hs b/src/Data/Aviation/Aip/ListItemLinks1.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/ListItemLinks1.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Data.Aviation.Aip.ListItemLinks1( + ListItemLinks1(..) +, AsListItemLinks1(..) +, FoldListItemLinks1(..) +, GetListItemLinks1(..) +, SetListItemLinks1(..) +, ManyListItemLinks1(..) +, HasListItemLinks1(..) +, IsListItemLinks1(..) +) where + +import Control.Category((.), id) +import Control.Applicative(pure) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON), withArray) +import Data.Aviation.Aip.Href(SetHref, FoldHref(_FoldHref), ManyHref(_ManyHref)) +import Data.Aviation.Aip.ListItemLink(ListItemLink) +import Data.Eq(Eq) +import Data.Foldable(toList) +import Data.Function(($)) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.List.NonEmpty(NonEmpty) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Prelude(Show) + +newtype ListItemLinks1 = + ListItemLinks1 + [NonEmpty ListItemLink] + deriving (Eq, Ord, Show) + +instance Semigroup ListItemLinks1 where + ListItemLinks1 x <> ListItemLinks1 y = + ListItemLinks1 (x <> y) + +instance Monoid ListItemLinks1 where + mappend = + (<>) + mempty = + ListItemLinks1 mempty + +instance FromJSON ListItemLinks1 where + parseJSON = + withArray "ListItemLinks1" $ \v -> + ListItemLinks1 <$> traverse parseJSON (toList v) + +instance ToJSON ListItemLinks1 where + toJSON (ListItemLinks1 x) = + toJSON x + +instance Wrapped ListItemLinks1 where + type Unwrapped ListItemLinks1 = + [NonEmpty ListItemLink] + _Wrapped' = + iso (\(ListItemLinks1 x) -> x) ListItemLinks1 + +instance ListItemLinks1 ~ x => + Rewrapped ListItemLinks1 x + +instance Cons ListItemLinks1 ListItemLinks1 (NonEmpty ListItemLink) (NonEmpty ListItemLink) where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc ListItemLinks1 ListItemLinks1 (NonEmpty ListItemLink) (NonEmpty ListItemLink) where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each ListItemLinks1 ListItemLinks1 (NonEmpty ListItemLink) (NonEmpty ListItemLink) where + each = + _Wrapped . each + +instance Reversing ListItemLinks1 where + reversing = + _Wrapped %~ reversing + +instance Plated ListItemLinks1 where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue ListItemLinks1 = NonEmpty ListItemLink +type instance Index ListItemLinks1 = Int +instance Ixed ListItemLinks1 where + ix i = + _Wrapped . ix i + +class ManyListItemLinks1 a => AsListItemLinks1 a where + _ListItemLinks1 :: + Prism' a ListItemLinks1 + default _ListItemLinks1 :: + IsListItemLinks1 a => + Prism' a ListItemLinks1 + _ListItemLinks1 = + _IsListItemLinks1 + +instance AsListItemLinks1 ListItemLinks1 where + _ListItemLinks1 = + id + +class FoldListItemLinks1 a where + _FoldListItemLinks1 :: + Fold a ListItemLinks1 + +instance FoldListItemLinks1 ListItemLinks1 where + _FoldListItemLinks1 = + id + +class FoldListItemLinks1 a => GetListItemLinks1 a where + _GetListItemLinks1 :: + Getter a ListItemLinks1 + default _GetListItemLinks1 :: + HasListItemLinks1 a => + Getter a ListItemLinks1 + _GetListItemLinks1 = + listItemLinks1 + +instance GetListItemLinks1 ListItemLinks1 where + _GetListItemLinks1 = + id + +class SetListItemLinks1 a where + _SetListItemLinks1 :: + Setter' a ListItemLinks1 + default _SetListItemLinks1 :: + ManyListItemLinks1 a => + Setter' a ListItemLinks1 + _SetListItemLinks1 = + _ManyListItemLinks1 + +instance SetListItemLinks1 ListItemLinks1 where + _SetListItemLinks1 = + id + +class (FoldListItemLinks1 a, SetListItemLinks1 a) => ManyListItemLinks1 a where + _ManyListItemLinks1 :: + Traversal' a ListItemLinks1 + +instance ManyListItemLinks1 ListItemLinks1 where + _ManyListItemLinks1 = + id + +class (GetListItemLinks1 a, ManyListItemLinks1 a) => HasListItemLinks1 a where + listItemLinks1 :: + Lens' a ListItemLinks1 + default listItemLinks1 :: + IsListItemLinks1 a => + Lens' a ListItemLinks1 + listItemLinks1 = + _IsListItemLinks1 + +instance HasListItemLinks1 ListItemLinks1 where + listItemLinks1 = + id + +class (HasListItemLinks1 a, AsListItemLinks1 a) => IsListItemLinks1 a where + _IsListItemLinks1 :: + Iso' a ListItemLinks1 + +instance IsListItemLinks1 ListItemLinks1 where + _IsListItemLinks1 = + id + +instance SetListItemLinks1 () where +instance FoldListItemLinks1 () where + _FoldListItemLinks1 = + _ManyListItemLinks1 +instance ManyListItemLinks1 () where + _ManyListItemLinks1 _ x = + pure x + +instance SetHref ListItemLinks1 where +instance FoldHref ListItemLinks1 where + _FoldHref = + _ManyHref + +instance ManyHref ListItemLinks1 where + _ManyHref = + _Wrapped . traverse . traverse . _ManyHref diff --git a/src/Data/Aviation/Aip/Log.hs b/src/Data/Aviation/Aip/Log.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/Log.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Aviation.Aip.Log( + aiplog +, aiplog' +) where + +import Control.Category((.)) +import Control.Monad.IO.Class(MonadIO(liftIO)) +import Data.String(String) +import System.IO(hPutStrLn, stderr, IO) + +aiplog :: + MonadIO f => + String + -> f () +aiplog = + liftIO . aiplog' + +aiplog' :: + String + -> IO () +aiplog' = + hPutStrLn stderr diff --git a/src/Data/Aviation/Aip/Month.hs b/src/Data/Aviation/Aip/Month.hs deleted file mode 100644 --- a/src/Data/Aviation/Aip/Month.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} - -module Data.Aviation.Aip.Month( - Month(..) -, parseMonth -, HasMonth(..) -, AsMonth(..) -) where - -import Text.Parser.Combinators(choice, try) -import Text.Parser.Char(CharParsing, string) -import Papa - -data Month = - Jan - | Feb - | Mar - | Apr - | May - | Jun - | Jul - | Aug - | Sep - | Oct - | Nov - | Dec - deriving (Eq, Ord, Show) - -parseMonth :: - CharParsing p => - p Month -parseMonth = - choice - [ - Jan <$ string "Jan" - , Feb <$ try (string "Feb") - , Mar <$ try (string "Mar") - , Apr <$ try (string "Apr") - , May <$ try (string "May") - , Jun <$ try (string "Jun") - , Jul <$ try (string "Jul") - , Aug <$ try (string "Aug") - , Sep <$ try (string "Sep") - , Oct <$ try (string "Oct") - , Nov <$ try (string "Nov") - , Dec <$ try (string "Dec") - ] - -makeClassy ''Month -makeClassyPrisms ''Month diff --git a/src/Data/Aviation/Aip/SHA1.hs b/src/Data/Aviation/Aip/SHA1.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/SHA1.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.SHA1( + SHA1(..) +, AsSHA1(..) +, FoldSHA1(..) +, GetSHA1(..) +, SetSHA1(..) +, ManySHA1(..) +, HasSHA1(..) +, IsSHA1(..) +, hash +, hashHex +, showsHash +, showHash +) where + +import Control.Category((.), id) +import Control.Applicative(pure) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON)) +import Data.Digest.SHA1(Word160(Word160)) +import qualified Data.Digest.SHA1 as SHA1(hash, toInteger) +import Data.Eq(Eq) +import Data.Functor((<$>)) +import Data.String(String) +import Data.Word(Word8) +import Numeric(showHex) +import Prelude(Show, ShowS) + +newtype SHA1 = + SHA1 + Word160 + deriving (Eq, Show) + +instance FromJSON SHA1 where + parseJSON v = + (\(b0, b1, b2, b3, b4) -> SHA1 (Word160 b0 b1 b2 b3 b4)) <$> parseJSON v + +instance ToJSON SHA1 where + toJSON (SHA1 (Word160 b0 b1 b2 b3 b4)) = + toJSON (b0, b1, b2, b3, b4) + +class ManySHA1 a => AsSHA1 a where + _SHA1 :: + Prism' a SHA1 + default _SHA1 :: + IsSHA1 a => + Prism' a SHA1 + _SHA1 = + _IsSHA1 + +instance AsSHA1 SHA1 where + _SHA1 = + id + +class FoldSHA1 a where + _FoldSHA1 :: + Fold a SHA1 + +instance FoldSHA1 SHA1 where + _FoldSHA1 = + id + +class FoldSHA1 a => GetSHA1 a where + _GetSHA1 :: + Getter a SHA1 + default _GetSHA1 :: + HasSHA1 a => + Getter a SHA1 + _GetSHA1 = + sha1 + +instance GetSHA1 SHA1 where + _GetSHA1 = + id + +class SetSHA1 a where + _SetSHA1 :: + Setter' a SHA1 + default _SetSHA1 :: + ManySHA1 a => + Setter' a SHA1 + _SetSHA1 = + _ManySHA1 + +instance SetSHA1 SHA1 where + _SetSHA1 = + id + +class (FoldSHA1 a, SetSHA1 a) => ManySHA1 a where + _ManySHA1 :: + Traversal' a SHA1 + +instance ManySHA1 SHA1 where + _ManySHA1 = + id + +class (GetSHA1 a, ManySHA1 a) => HasSHA1 a where + sha1 :: + Lens' a SHA1 + default sha1 :: + IsSHA1 a => + Lens' a SHA1 + sha1 = + _IsSHA1 + +instance HasSHA1 SHA1 where + sha1 = + id + +class (HasSHA1 a, AsSHA1 a) => IsSHA1 a where + _IsSHA1 :: + Iso' a SHA1 + +instance IsSHA1 SHA1 where + _IsSHA1 = + id + +instance SetSHA1 () where +instance FoldSHA1 () where + _FoldSHA1 = + _ManySHA1 +instance ManySHA1 () where + _ManySHA1 _ x = + pure x + +hash :: + [Word8] + -> SHA1 +hash = + SHA1 . SHA1.hash + +hashHex :: + SHA1 + -> ShowS +hashHex (SHA1 x) = + showHex (SHA1.toInteger x) + +showsHash :: + HasSHA1 s => + s + -> ShowS +showsHash x = + hashHex (x ^. sha1) + +showHash :: + HasSHA1 s => + s + -> String +showHash x = + showsHash x "" diff --git a/src/Data/Aviation/Aip/Title.hs b/src/Data/Aviation/Aip/Title.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/Title.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.Title( + Title(..) +, AsTitle(..) +, FoldTitle(..) +, GetTitle(..) +, SetTitle(..) +, ManyTitle(..) +, HasTitle(..) +, IsTitle(..) +) where + +import Control.Category((.), id) +import Control.Applicative(pure) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON)) +import Data.Char(Char) +import Data.Eq(Eq) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Data.String(String) +import Prelude(Show) + + +newtype Title = + Title + String + deriving (Eq, Ord, Show) + +instance FromJSON Title where + parseJSON v = + Title <$> parseJSON v + +instance ToJSON Title where + toJSON (Title x) = + toJSON x + +instance Semigroup Title where + Title x <> Title y = + Title (x <> y) + +instance Monoid Title where + mappend = + (<>) + mempty = + Title mempty + +instance Cons Title Title Char Char where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc Title Title Char Char where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each Title Title Char Char where + each = + _Wrapped . each + +instance Reversing Title where + reversing = + _Wrapped %~ reversing + +instance Plated Title where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue Title = Char +type instance Index Title = Int +instance Ixed Title where + ix i = + _Wrapped . ix i + +instance Wrapped Title where + type Unwrapped Title = String + _Wrapped' = + iso + (\(Title x) -> x) + Title + +instance Title ~ a => + Rewrapped Title a + +class ManyTitle a => AsTitle a where + _Title :: + Prism' a Title + default _Title :: + IsTitle a => + Prism' a Title + _Title = + _IsTitle + +instance AsTitle Title where + _Title = + id + +instance AsTitle String where + _Title = + from _Wrapped + +class FoldTitle a where + _FoldTitle :: + Fold a Title + +instance FoldTitle Title where + _FoldTitle = + id + +instance FoldTitle String where + _FoldTitle = + from _Wrapped + +class FoldTitle a => GetTitle a where + _GetTitle :: + Getter a Title + default _GetTitle :: + HasTitle a => + Getter a Title + _GetTitle = + title + +instance GetTitle Title where + _GetTitle = + id + +instance GetTitle String where + _GetTitle = + from _Wrapped + +class SetTitle a where + _SetTitle :: + Setter' a Title + default _SetTitle :: + ManyTitle a => + Setter' a Title + _SetTitle = + _ManyTitle + +instance SetTitle Title where + _SetTitle = + id + +instance SetTitle String where + _SetTitle = + from _Wrapped + +class (FoldTitle a, SetTitle a) => ManyTitle a where + _ManyTitle :: + Traversal' a Title + +instance ManyTitle Title where + _ManyTitle = + id + +instance ManyTitle String where + _ManyTitle = + from _Wrapped + +class (GetTitle a, ManyTitle a) => HasTitle a where + title :: + Lens' a Title + default title :: + IsTitle a => + Lens' a Title + title = + _IsTitle + +instance HasTitle Title where + title = + id + +instance HasTitle String where + title = + from _Wrapped + +class (HasTitle a, AsTitle a) => IsTitle a where + _IsTitle :: + Iso' a Title + +instance IsTitle Title where + _IsTitle = + id + +instance IsTitle String where + _IsTitle = + from _Wrapped + +instance SetTitle () where +instance FoldTitle () where + _FoldTitle = + _ManyTitle +instance ManyTitle () where + _ManyTitle _ x = + pure x diff --git a/src/Data/Aviation/Aip/Txt.hs b/src/Data/Aviation/Aip/Txt.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aviation/Aip/Txt.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Aviation.Aip.Txt ( + Txt(..) +, AsTxt(..) +, FoldTxt(..) +, GetTxt(..) +, SetTxt(..) +, ManyTxt(..) +, HasTxt(..) +, IsTxt(..) +) where + +import Control.Category((.), id) +import Control.Applicative(pure) +import Control.Lens +import Data.Aeson(FromJSON(parseJSON), ToJSON(toJSON)) +import Data.Char(Char) +import Data.Eq(Eq) +import Data.Functor((<$>)) +import Data.Int(Int) +import Data.Monoid(Monoid(mappend, mempty)) +import Data.Ord(Ord) +import Data.Semigroup(Semigroup((<>))) +import Data.String(String) +import Prelude(Show) + +-- import Papa hiding ((.=)) + +newtype Txt = + Txt + String + deriving (Eq, Ord, Show) + +instance FromJSON Txt where + parseJSON v = + Txt <$> parseJSON v + +instance ToJSON Txt where + toJSON (Txt x) = + toJSON x + +instance Semigroup Txt where + Txt x <> Txt y = + Txt (x <> y) + +instance Monoid Txt where + mappend = + (<>) + mempty = + Txt mempty + +instance Cons Txt Txt Char Char where + _Cons = + _Wrapped . _Cons . seconding (from _Wrapped) + +instance Snoc Txt Txt Char Char where + _Snoc = + _Wrapped . _Snoc . firsting (from _Wrapped) + +instance Each Txt Txt Char Char where + each = + _Wrapped . each + +instance Reversing Txt where + reversing = + _Wrapped %~ reversing + +instance Plated Txt where + plate = + _Wrapped . plate . from _Wrapped + +type instance IxValue Txt = Char +type instance Index Txt = Int +instance Ixed Txt where + ix i = + _Wrapped . ix i + +instance AsEmpty Txt where + _Empty = + _Wrapped . _Empty + +instance Wrapped Txt where + type Unwrapped Txt = String + _Wrapped' = + iso + (\(Txt x) -> x) + Txt + +instance Txt ~ a => + Rewrapped Txt a + +class ManyTxt a => AsTxt a where + _Txt :: + Prism' a Txt + default _Txt :: + IsTxt a => + Prism' a Txt + _Txt = + _IsTxt + +instance AsTxt Txt where + _Txt = + id + +instance AsTxt String where + _Txt = + from _Wrapped + +class FoldTxt a where + _FoldTxt :: + Fold a Txt + +instance FoldTxt Txt where + _FoldTxt = + id + +instance FoldTxt String where + _FoldTxt = + from _Wrapped + +class FoldTxt a => GetTxt a where + _GetTxt :: + Getter a Txt + default _GetTxt :: + HasTxt a => + Getter a Txt + _GetTxt = + txt + +instance GetTxt Txt where + _GetTxt = + id + +instance GetTxt String where + _GetTxt = + from _Wrapped + +class SetTxt a where + _SetTxt :: + Setter' a Txt + default _SetTxt :: + ManyTxt a => + Traversal' a Txt + _SetTxt = + _ManyTxt + +instance SetTxt Txt where + _SetTxt = + id + +instance SetTxt String where + _SetTxt = + from _Wrapped + +class (FoldTxt a, SetTxt a) => ManyTxt a where + _ManyTxt :: + Traversal' a Txt + +instance ManyTxt Txt where + _ManyTxt = + id + +instance ManyTxt String where + _ManyTxt = + from _Wrapped + +class (GetTxt a, ManyTxt a) => HasTxt a where + txt :: + Lens' a Txt + default txt :: + IsTxt a => + Lens' a Txt + txt = + _IsTxt + +instance HasTxt Txt where + txt = + id + +instance HasTxt String where + txt = + from _Wrapped + +class (HasTxt a, AsTxt a) => IsTxt a where + _IsTxt :: + Iso' a Txt + +instance IsTxt Txt where + _IsTxt = + id + +instance IsTxt String where + _IsTxt = + from _Wrapped + +instance SetTxt () where +instance FoldTxt () where + _FoldTxt = + _ManyTxt +instance ManyTxt () where + _ManyTxt _ x = + pure x diff --git a/src/Data/Aviation/Aip/Year.hs b/src/Data/Aviation/Aip/Year.hs deleted file mode 100644 --- a/src/Data/Aviation/Aip/Year.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} - -module Data.Aviation.Aip.Year( - Year(..) -, parseYear -, HasYear(..) -) where - -import Data.Digit(Digit, parsedigit) -import Text.Parser.Char(CharParsing) -import Papa - -data Year = - Year { - _year1 :: - Digit - , _year2 :: - Digit - , _year3 :: - Digit - , _year4 :: - Digit - } - deriving (Eq, Ord, Show) - -parseYear :: - (CharParsing p, Monad p) => - p Year -parseYear = - Year <$> parsedigit <*> parsedigit <*> parsedigit <*> parsedigit - -makeClassy ''Year diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Main( - main -) where - -import Control.Monad.IO.Class(MonadIO(liftIO)) -import Data.Aviation.Aip.AipDocuments(writeAipDocuments) -import Control.Monad.Trans.Except(runExceptT) -import System.Directory(createDirectoryIfMissing) -import System.Environment(getArgs) -import System.FilePath(()) -import System.IO(IO, Handle, IOMode(AppendMode), withFile, hPutStrLn, stderr) -import Papa - -main :: - IO () -main = - do a <- getArgs - case a of - adir:ldir:_ -> - let wlogfile :: - MonadIO m => - FilePath - -> (Handle -> IO a) - -> m a - wlogfile f = - liftIO . withFile (ldir f) AppendMode - ex = - do liftIO (mapM_ (createDirectoryIfMissing True) [adir, ldir]) - wlogfile "err.log" (\herr -> - wlogfile "out.log" (\hout -> - do p <- runExceptT (writeAipDocuments herr hout adir) - mapM_ (\qs -> appendFile (ldir "aip") (qs >>= \q -> q ++ "\n")) p)) - in void (runExceptT ex) - _ -> - hPutStrLn stderr " " diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = pure () diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Main where - -import Build_doctests (deps) -import Control.Applicative -import Control.Monad -import Data.List -import System.Directory -import System.FilePath -import Test.DocTest - -main :: - IO () -main = - getSources >>= \sources -> doctest $ - "-isrc" - : "-idist/build/autogen" - : "-optP-include" - : "-optPdist/build/autogen/cabal_macros.h" - : "-hide-all-packages" - : map ("-package="++) deps ++ sources - -getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "src" - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c