module Main where

import           Universum

import           Data.List (nub)
import           Database.SQLite.Simple (Connection (..), NamedParam (..), queryNamed, query_,
                                         withConnection)

import           Test.Hspec (Spec, describe, hspec, it, shouldBe)
import           Test.Hspec.QuickCheck (modifyMaxSuccess, prop)
import           Test.QuickCheck (Gen, arbitrary, elements, forAll, listOf, listOf1, property,
                                  (===))
import           Test.QuickCheck.Monadic (assert, monadicIO, pre, run)

import           Configuration (basicIOLayer, emptyConfig)
import           DataSource (App, Attachment (..), AttachmentId (..), Comment (..),
                             CommentBody (..), CommentId (..), Config (..), DBLayerException (..),
                             DataLayer (..), DeletedTicket (..), ExportFromTime (..), IOLayer (..),
                             Ticket (..), TicketId (..), TicketInfo (..), TicketStatus (..),
                             TicketTag (..), TicketTags (..), TicketURL (..), User, UserId (..),
                             ZendeskAPIUrl (..), ZendeskResponse (..), basicDataLayer,
                             createResponseTicket, createSchema, deleteAllData, emptyDBLayer,
                             emptyDataLayer, insertCommentAttachments, insertTicketComments,
                             insertTicketInfo, renderTicketStatus, runApp, showURL)
import           Exceptions (ProcessTicketExceptions (..), ZipFileExceptions (..))
import           Http.Exceptions (HttpNetworkLayerException (..))
import           Http.Layer (HTTPNetworkLayer (..), emptyHTTPNetworkLayer)

import           Lib (exportZendeskDataToLocalDB, fetchTicket, fetchTicketComments, fetchTickets,
                      filterAnalyzedTickets, getAttachmentsFromComment, inspectAttachment,
                      processTicket)
import           LogAnalysis.Classifier (extractIssuesFromLogs)
import           LogAnalysis.Exceptions (LogAnalysisException (..))
import           LogAnalysis.Types (Analysis, ErrorCode (..), LogFile, renderErrorCode,
                                    setupAnalysis)
import           Statistics (filterTicketsByStatus, filterTicketsWithAttachments,
                             showAttachmentInfo, showCommentAttachments)

import           HttpQueueSpec (dispatchActionsSpec)
import           LogAnalysisSpec (classifierSpec)

-- TODO(ks): What we are really missing is a realistic @Gen DataLayer m@.

main :: IO ()
main = hspec spec

-- stack test --test-arguments "--seed=1425428185"
-- stack test log-classifier --fast --test-arguments "-m Zendesk"
spec :: Spec
spec =
    describe "Log Classifier Tests" $ do
        describe "Statistics" $ do
            filterTicketsWithAttachmentsSpec
            filterTicketsByStatusSpec
            showAttachmentInfoSpec
            showCommentAttachmentsSpec
            showTicketCategoryCountSpec
            -- TODO(rc): showTicketWithAttachmentsSpec
            -- TODO(rc): showTicketAttachmentsSpec
            -- TODO(rc): showStatisticsSpec
        describe "Zendesk" $ do
            inspectAttachmentSpec
            validShowURLSpec
            fetchTicketsSpec
            processTicketSpec
            filterAnalyzedTicketsSpec
            createResponseTicketSpec
            exportZendeskDataToLocalDBSpec
            getAttachmentsFromCommentSpec

        describe "HttpNetworkLayer" $ do
            parsingFailureSpec

        describe "Database" $ do
            deleteAllDataSpec
            insertCommentAttachmentsSpec
            insertTicketInfoSpec
            insertTicketCommentsSpec

        dispatchActionsSpec

        describe "LogAnalysis" $ do
            classifierSpec

-- | A utility function for testing which stubs IO and returns
-- the @Config@.
stubbedConfig :: Config
stubbedConfig =
    emptyConfig
        { cfgIOLayer            = stubbedIOLayer
        , cfgDBLayer            = emptyDBLayer
        }
  where
    stubbedIOLayer :: IOLayer App
    stubbedIOLayer =
        basicIOLayer
            { iolPrintText      = \_     -> pure ()
            , iolAppendFile     = \_ _   -> pure ()
            -- ^ Do nothing with the output
            }

-- | Generate a @HttpNotFound@ so we can test when a ticket can't be found.
generateHttpNotFoundExceptions :: Gen HttpNetworkLayerException
generateHttpNotFoundExceptions = HttpNotFound <$> arbitrary

parsingFailureSpec :: Spec
parsingFailureSpec =
    describe "parsingFailureSpec " $ modifyMaxSuccess (const 1000) $ do
        it "should return Nothing when parsing fails at getTicketInfo" $ do
            forAll arbitrary $ \ticketId ->
                forAll generateHttpNotFoundExceptions $ \exception ->
                    monadicIO $ do

                        -- we exclusivly want just @HttpNotFound@, others are rethrown.
                        pre $ case exception of
                                   HttpNotFound _ -> True
                                   _              -> False

                        let stubbedHttpNetworkLayer :: HTTPNetworkLayer App
                            stubbedHttpNetworkLayer =
                                emptyHTTPNetworkLayer
                                    { hnlApiCall                = \_ _   -> throwM exception
                                    }

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer = basicDataLayer stubbedHttpNetworkLayer

                        let appExecution :: IO (Maybe TicketInfo)
                            appExecution = runApp (fetchTicket stubbedDataLayer ticketId) stubbedConfig

                        ticket <- run appExecution

                        -- Check we don't have any tickets, since they would all raise a parsing exception.
                        assert . isNothing $ ticket

        it "should return empty when parsing fails at getTicketComments" $ do
            forAll arbitrary $ \ticketId ->
                forAll generateHttpNotFoundExceptions $ \exception ->

                    monadicIO $ do

                        let stubbedHttpNetworkLayer :: HTTPNetworkLayer App
                            stubbedHttpNetworkLayer =
                                emptyHTTPNetworkLayer
                                    { hnlApiCall                = \_ _   -> throwM exception
                                    }

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer = basicDataLayer stubbedHttpNetworkLayer

                        -- TODO(ks): There is an indication that we need to propage this exception.
                        let appExecution :: IO [Comment]
                            appExecution = runApp (fetchTicketComments stubbedDataLayer ticketId) stubbedConfig

                        comments <- run appExecution

                        -- Check we don't have any comments.
                        assert . null $ comments

fetchTicketsSpec :: Spec
fetchTicketsSpec =
    describe "fetchTickets" $ modifyMaxSuccess (const 200) $ do
        it "doesn't return tickets since there are none" $
            forAll arbitrary $ \(ticketInfo :: TicketInfo) ->

                monadicIO $ do

                    let stubbedDataLayer :: DataLayer App
                        stubbedDataLayer =
                            emptyDataLayer
                                { zlListToBeAnalysedTickets =           pure []
                                , zlGetTicketInfo           = \_     -> pure $ Just ticketInfo
                                , zlListAdminAgents         =           pure []
                                }

                    let appExecution :: IO [TicketInfo]
                        appExecution = runApp (fetchTickets stubbedDataLayer) stubbedConfig

                    tickets <- run appExecution

                    assert $ length tickets == 0

        it "returns sorted nonempty tickets" $
            forAll arbitrary $ \(ticketInfo) ->
                forAll (listOf1 arbitrary) $ \(listTickets) ->
                    forAll (listOf1 arbitrary) $ \(agents :: [User]) ->

                        monadicIO $ do

                            pre $ any (\TicketInfo{..} -> tiStatus /= TicketStatus "solved") listTickets

                            let stubbedDataLayer :: DataLayer App
                                stubbedDataLayer =
                                    emptyDataLayer
                                        { zlListToBeAnalysedTickets =           pure listTickets
                                        , zlGetTicketInfo           = \_     -> pure ticketInfo
                                        , zlListAdminAgents         =           pure agents
                                        }

                            let appExecution :: IO [TicketInfo]
                                appExecution = runApp (fetchTickets stubbedDataLayer) stubbedConfig

                            tickets <- run appExecution

                            -- Check we have some tickets.
                            assert $ length tickets > 0
                            -- Check the order is sorted.
                            assert $ sortBy compare tickets == tickets

processTicketSpec :: Spec
processTicketSpec =
    describe "processTicket" $ modifyMaxSuccess (const 200) $ do
        it "processes ticket, with comments" $
            forAll arbitrary $ \(ticketInfo :: TicketInfo) ->
                forAll (listOf1 arbitrary) $ \(listTickets) ->
                forAll (listOf1 arbitrary) $ \(comments) ->

                    monadicIO $ do

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlListToBeAnalysedTickets =           pure listTickets
                                    , zlGetTicketInfo           = \_     -> pure $ Just ticketInfo
                                    , zlPostTicketComment       = \_ _   -> pure ()
                                    , zlGetTicketComments       = \_     -> pure comments
                                    , zlGetAttachment           = \_     -> pure $ Just mempty
                                    }

                        let appExecution :: IO ZendeskResponse
                            appExecution = runApp (processTicket stubbedDataLayer . tiId $ ticketInfo) stubbedConfig

                        zendeskResponse <- run appExecution

                        -- Check we have some comments.
                        assert . not . null . zrComment $ zendeskResponse

        it "processes ticket, with no attachments" $
            forAll (listOf1 genCommentWithNoAttachment) $ \(commentsWithoutAttachment :: [Comment]) ->
                forAll arbitrary $ \(ticketInfo :: TicketInfo) ->
                    monadicIO $ do

                    let stubbedDataLayer :: DataLayer App
                        stubbedDataLayer =
                            emptyDataLayer
                                { zlGetTicketComments = \_   -> pure commentsWithoutAttachment
                                , zlGetTicketInfo     = \_   -> pure $ Just ticketInfo
                                , zlPostTicketComment = \_ _ -> pure ()
                                }

                    let appExecution :: IO ZendeskResponse
                        appExecution = runApp (processTicket stubbedDataLayer . tiId $ ticketInfo) stubbedConfig

                    zendeskResponse <- run appExecution

                    assert . not . null . zrComment $ zendeskResponse
                    assert $ isResponseTaggedWithNoLogs zendeskResponse

        it "processes ticket, with attachments" $
            forAll (listOf1 arbitrary) $ \(comments :: [Comment]) ->
                forAll arbitrary $ \(ticketInfo :: TicketInfo) ->
                    monadicIO $ do

                    pre $ any (not . null . cAttachments) comments

                    let stubbedDataLayer :: DataLayer App
                        stubbedDataLayer =
                            emptyDataLayer
                                { zlGetTicketComments = \_   -> pure comments
                                , zlGetTicketInfo     = \_   -> pure $ Just ticketInfo
                                , zlPostTicketComment = \_ _ -> pure ()
                                , zlGetAttachment     = \_   -> pure $ Just mempty
                                }

                    let appExecution :: IO ZendeskResponse
                        appExecution = runApp (processTicket stubbedDataLayer . tiId $ ticketInfo) stubbedConfig

                    zendeskResponse <- run appExecution

                    assert . not . null . zrComment $ zendeskResponse
                    assert . not . isResponseTaggedWithNoLogs $ zendeskResponse

        it "tries to process ticket but cannot find both comments and attachments, throws exception" $
            forAll arbitrary $ \(ticketInfo :: TicketInfo) ->

                monadicIO $ do

                    let stubbedDataLayer :: DataLayer App
                        stubbedDataLayer =
                            emptyDataLayer
                                { zlGetTicketInfo           = \_     -> pure $ Just ticketInfo
                                , zlPostTicketComment       = \_ _   -> pure ()
                                , zlGetTicketComments       = \_     -> pure []
                                , zlGetAttachment           = \_     -> pure Nothing
                                }

                    let appExecution :: IO ZendeskResponse
                        appExecution = runApp (processTicket stubbedDataLayer . tiId $ ticketInfo) stubbedConfig

                    eZendeskResponse <- run (try appExecution)

                    -- Check it throws exception
                    assert $ isLeft (eZendeskResponse :: Either ProcessTicketExceptions ZendeskResponse)
                    whenLeft eZendeskResponse $ \processException ->
                        assert $ processException == CommentAndAttachmentNotFound (tiId ticketInfo)

        it "tries to process ticket but cannot find attachments, throws exception" $
            forAll arbitrary $ \(ticketInfo :: TicketInfo) ->
                forAll (listOf1 arbitrary) $ \comments ->

                    monadicIO $ do

                        pre $ any (\Comment{..} -> not $ null cAttachments) comments

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlGetTicketInfo           = \_     -> pure $ Just ticketInfo
                                    , zlPostTicketComment       = \_ _   -> pure ()
                                    , zlGetTicketComments       = \_     -> pure comments
                                    , zlGetAttachment           = \_     -> pure Nothing
                                    }

                        let appExecution :: IO ZendeskResponse
                            appExecution = runApp (processTicket stubbedDataLayer . tiId $ ticketInfo) stubbedConfig

                        eZendeskResponse <- run (try appExecution)

                        -- Check we have some comments.
                        assert $ isLeft (eZendeskResponse :: Either ProcessTicketExceptions ZendeskResponse)
                        whenLeft eZendeskResponse $ \processException ->
                            assert $ processException == AttachmentNotFound (tiId ticketInfo)

        it "tries to process ticket but cannot fetch ticket info, throws exception" $
            forAll arbitrary $ \(ticketId :: TicketId) ->

                    monadicIO $ do

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlGetTicketInfo           = \_     -> pure Nothing
                                    , zlPostTicketComment       = \_ _   -> pure ()
                                    , zlGetTicketComments       = \_     -> pure empty
                                    }

                        let appExecution :: IO ZendeskResponse
                            appExecution = runApp (processTicket stubbedDataLayer ticketId) stubbedConfig

                        eZendeskResponse <- run (try appExecution)

                        assert $ isLeft (eZendeskResponse :: Either ProcessTicketExceptions ZendeskResponse)
                        whenLeft eZendeskResponse $ \processException ->
                            assert $ processException == TicketInfoNotFound ticketId

isResponseTaggedWithNoLogs :: ZendeskResponse -> Bool
isResponseTaggedWithNoLogs response = "no-log-files" `elem` getTicketTags (zrTags response)

genCommentWithNoAttachment :: Gen Comment
genCommentWithNoAttachment = do
    comment <- arbitrary
    pure $ comment {cAttachments = mempty}

genCommentWithAttachment :: Gen Comment
genCommentWithAttachment = do
    comment    <- arbitrary
    attachment <- listOf1 arbitrary
    pure $ comment {cAttachments = attachment}

genTicketWithStatus :: Gen TicketInfo
genTicketWithStatus = do
    ticketInfo <- arbitrary
    status     <- TicketStatus <$> elements ["open", "closed"]
    pure $ ticketInfo {tiStatus = status}

genTicketWithFilteredTags :: [Text] -> Gen TicketInfo
genTicketWithFilteredTags tagToBeFiltered = do
    ticketInfo <- arbitrary
    pure $ ticketInfo {tiTags = TicketTags tagToBeFiltered}

genTicketWithUnsolvedStatus :: Gen TicketInfo
genTicketWithUnsolvedStatus = do
    ticketInfo <- arbitrary
    status     <- TicketStatus <$> elements ["new", "hold", "open", "pending"]
    pure $ ticketInfo {tiStatus = status}

-- Simple tests to cover it works.
validShowURLSpec :: Spec
validShowURLSpec =
    describe "showURL" $ modifyMaxSuccess (const 10000) $ do
        it "returns valid UserRequestedTicketsURL" $ do
            property $ \userId ->
                let typedURL    = showURL $ UserRequestedTicketsURL userId
                    untypedURL  = "/users/" <> show (getUserId userId) <> "/tickets/requested.json"
                in  typedURL == untypedURL
        it "returns valid UserAssignedTicketsURL" $ do
            property $ \userId ->
                let typedURL    = showURL $ UserAssignedTicketsURL userId
                    untypedURL  = "/users/" <> show (getUserId userId) <> "/tickets/assigned.json"
                in  typedURL == untypedURL
        it "returns valid UserUnassignedTicketsURL" $
                let typedURL    = showURL $ UserUnassignedTicketsURL
                    untypedURL  = "/search.json?query=type%3Aticket%20assignee%3Anone&sort_by=created_at&sort_order=asc"
                in  typedURL == untypedURL
        it "returns valid TicketsURL" $ do
            property $ \ticketId ->
                let typedURL    = showURL $ TicketsURL ticketId
                    untypedURL  = "/tickets/" <> show (getTicketId ticketId) <> ".json"
                in  typedURL == untypedURL
        it "returns valid TicketAgentURL" $ do
            property $ \ticketId ->
                let typedURL    = showURL $ TicketAgentURL ticketId
                    untypedURL  = "https://iohk.zendesk.com/agent/tickets/" <> show (getTicketId ticketId)
                in  typedURL == untypedURL
        it "returns valid TicketCommentsURL" $ do
            property $ \ticketId ->
                let typedURL    = showURL $ TicketCommentsURL ticketId
                    untypedURL  = "/tickets/" <> show (getTicketId ticketId) <> "/comments.json"
                in  typedURL == untypedURL
        it "returns valid ExportDataByTimestamp" $ do
            property $ \timestamp ->
                let typedURL    = showURL $ ExportDataByTimestamp timestamp
                    untypedURL  = "https://iohk.zendesk.com/api/v2/incremental/tickets.json?start_time="
                        <> (show @_ @Integer . floor . toRational $ getExportFromTime timestamp)
                in  typedURL == untypedURL

filterTicketsWithAttachmentsSpec :: Spec
filterTicketsWithAttachmentsSpec =
    describe "filterTicketsWithAttachments" $ do
        it "filtered/unfiltered tickets return same length if all tickets have attachments" $ do
            forAll (listOf1 arbitrary) $ \(listTickets) ->
                forAll (listOf1 genCommentWithAttachment) $ \(comments) ->

                    monadicIO $ do

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlGetTicketComments       = \_     -> pure comments
                                    }

                        let appExecution :: IO [TicketInfo]
                            appExecution = runApp (filterTicketsWithAttachments stubbedDataLayer listTickets) stubbedConfig

                        tickets <- run appExecution
                        -- Check we have some tickets.
                        assert $ (length tickets) == (length listTickets)

        it "filtered tickets length is zero if no tickets have attachments" $ do
            forAll (listOf1 arbitrary) $ \(listTickets) ->
                forAll (listOf1 genCommentWithNoAttachment) $ \(comments) ->

                    monadicIO $ do

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlGetTicketComments       = \_     -> pure comments
                                    }

                        let appExecution :: IO [TicketInfo]
                            appExecution = runApp (filterTicketsWithAttachments stubbedDataLayer listTickets) stubbedConfig

                        tickets <- run appExecution
                        -- Check we have some tickets.
                        assert $ (length tickets) == 0

filterTicketsByStatusSpec :: Spec
filterTicketsByStatusSpec =
    describe "filterTicketsByStatus" $ do
        it "a TicketInfo array with x open tickets should filter to length x" $ property $
            forAll (listOf1 genTicketWithStatus) $ \tickets -> do
                length (filterTicketsByStatus tickets "open") == length (filter ((== TicketStatus "open") . tiStatus) tickets)
        it "a TicketInfo array with x closed tickets should filter to length x" $ property $
            forAll (listOf1 genTicketWithStatus) $ \tickets -> do
                length (filterTicketsByStatus tickets "closed") == length (filter ((== TicketStatus "closed") . tiStatus) tickets)

showAttachmentInfoSpec :: Spec
showAttachmentInfoSpec =
    describe "showAttachmentInfo" $ do
        it "given an attachment, return  a Text describing the attachment" $ property $
            forAll (listOf1 arbitrary) $ \(listOfAttachments :: [Attachment]) ->
                fmap showAttachmentInfo listOfAttachments == fmap (\attachment -> ("  Attachment: " <> (show $ aSize attachment) <> " - " <> aURL attachment :: Text)) listOfAttachments

showCommentAttachmentsSpec :: Spec
showCommentAttachmentsSpec =
    describe "showCommentsAttachments" $ do
        it "given an comment, return  a [Text] describing each comment` attachment" $ property $
            forAll (listOf1 arbitrary) $ \(listOfComments :: [Comment]) ->
                fmap showCommentAttachments listOfComments == fmap (\comment -> ( showAttachmentInfo <$> cAttachments comment)) listOfComments

showTicketCategoryCountSpec :: Spec
showTicketCategoryCountSpec =
    describe "showTicketCategoryCount" $ do
        it "Properly show  total/open/closed ticket count" $ property $
            forAll (listOf1 arbitrary) $ \(listOfComments :: [Comment]) ->
                fmap showCommentAttachments listOfComments == fmap (\comment -> ( showAttachmentInfo <$> cAttachments comment)) listOfComments

filterAnalyzedTicketsSpec :: Spec
filterAnalyzedTicketsSpec =
    describe "filterAnalyzedTickets" $ modifyMaxSuccess (const 200) $ do
        it "should not filter tickets with status 'open', 'hold', 'pending', and 'new'" $
            forAll (listOf genTicketWithUnsolvedStatus) $ \(ticketInfos :: [TicketInfo]) ->
                    length (filterAnalyzedTickets ticketInfos) `shouldBe` length ticketInfos

        it "should filter solved tickets" $
            forAll (listOf arbitrary) $ \(ticketInfos :: [TicketInfo]) ->
                let filteredTickets :: [TicketInfo]
                    filteredTickets = filterAnalyzedTickets ticketInfos
                in all (\ticket -> tiStatus ticket /= TicketStatus "solved") filteredTickets

        it "should filter goguen testnet tickets" $
            forAll (listOf $ genTicketWithFilteredTags ["goguen_testnets"]) $
                \(ticketInfos :: [TicketInfo]) ->
                    length (filterAnalyzedTickets ticketInfos) `shouldBe` 0

createResponseTicketSpec :: Spec
createResponseTicketSpec =
    describe "createResponseTicket" $ modifyMaxSuccess (const 200) $ do
        it "should preserve ticket field and custom field from ticketInfo" $
            property $ \agentId ticketInfo zendeskResponse ->
                let responseTicket = createResponseTicket agentId ticketInfo zendeskResponse
                in tiField ticketInfo == tField responseTicket
                && tiCustomField ticketInfo == tCustomField responseTicket
        it "should preserve tags from ticketinfo and zendeskresponse" $
            property $ \agentId ticketInfo zendeskResponse ->
                let responseTicket      = createResponseTicket agentId ticketInfo zendeskResponse
                    mergedTags          = getTicketTags $ tiTags ticketInfo <> zrTags zendeskResponse
                    responseTags        = getTicketTags $ tTag responseTicket
                -- in summary, the response tags have the debuggers `analyzed-by-script-version` tag AND
                -- they remove the `to_be_analysed` tag AND they are unique.
                in (filter (/= renderTicketStatus ToBeAnalyzed) . nub $ renderTicketStatus AnalyzedByScriptV1_6_0 : mergedTags) === responseTags

exportZendeskDataToLocalDBSpec :: Spec
exportZendeskDataToLocalDBSpec =
    describe "exportZendeskDataToLocalDB" $ modifyMaxSuccess (const 200) $ do
        it "should export no data since there is nothing new" $
            forAll arbitrary $ \(exportFromTime) ->

               monadicIO $ do

                   let stubbedDataLayer :: DataLayer App
                       stubbedDataLayer =
                           emptyDataLayer
                               { zlExportTickets           = \_     -> pure []
                               , zlListDeletedTickets      =           pure []
                               , zlGetTicketComments       = \_     -> pure []
                               }

                   let appExecution :: IO [TicketInfo]
                       appExecution = runApp (exportZendeskDataToLocalDB stubbedDataLayer exportFromTime) stubbedConfig

                   ticketsToExport <- run appExecution

                   -- Check we don't have any tickets.
                   assert . null $ ticketsToExport

        it "should export a list of tickets since there are new tickets" $
             forAll (listOf1 genTicketWithUnsolvedStatus) $ \(listTickets) ->
                forAll arbitrary $ \(exportFromTime) ->

                    monadicIO $ do

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlExportTickets           = \_     -> pure listTickets
                                    , zlListDeletedTickets      =           pure []
                                    , zlGetTicketComments       = \_     -> pure []
                                    }

                        let appExecution :: IO [TicketInfo]
                            appExecution = runApp (exportZendeskDataToLocalDB stubbedDataLayer exportFromTime) stubbedConfig

                        ticketsToExport <- run appExecution

                        -- Check that we have tickets.
                        assert . not . null $ ticketsToExport
                        assert $ length ticketsToExport == length listTickets

        it "should not return deleted tickets" $
             forAll (listOf1 arbitrary) $ \(listTickets) ->
                forAll arbitrary $ \(exportFromTime) ->

                    monadicIO $ do

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlExportTickets           = \_     -> pure listTickets
                                    , zlListDeletedTickets      =           pure $ map (DeletedTicket . tiId) listTickets
                                    , zlGetTicketComments       = \_     -> pure []
                                    }

                        let appExecution :: IO [TicketInfo]
                            appExecution = runApp (exportZendeskDataToLocalDB stubbedDataLayer exportFromTime) stubbedConfig

                        ticketsToExport <- run appExecution

                        -- Check we don't have any tickets.
                        assert . null $ ticketsToExport

        it "should not return duplicated tickets" $
             forAll (listOf1 genTicketWithUnsolvedStatus) $ \(listTickets) ->
                forAll arbitrary $ \(exportFromTime) ->

                    monadicIO $ do

                        -- Here we duplicate them to check if the function works.
                        let duplicatedListTickets = concat $ replicate 10 listTickets

                        let stubbedDataLayer :: DataLayer App
                            stubbedDataLayer =
                                emptyDataLayer
                                    { zlExportTickets           = \_     -> pure duplicatedListTickets
                                    , zlListDeletedTickets      =           pure []
                                    , zlGetTicketComments       = \_     -> pure []
                                    }

                        let appExecution :: IO [TicketInfo]
                            appExecution = runApp (exportZendeskDataToLocalDB stubbedDataLayer exportFromTime) stubbedConfig

                        ticketsToExport <- run appExecution

                        -- Check that we have tickets.
                        assert . not . null $ ticketsToExport
                        assert $ length ticketsToExport == length listTickets

getAttachmentsFromCommentSpec :: Spec
getAttachmentsFromCommentSpec =
    describe "getAttachmentsFromComment" $ modifyMaxSuccess (const 200) $
        prop "should return zip file attachments" $
          \(comments :: [Comment]) -> do
            let filteredAttachments = getAttachmentsFromComment comments
            all (\att -> aContentType att `elem` zipFileContentTypes) filteredAttachments
          where
            zipFileContentTypes :: [Text]
            zipFileContentTypes = ["application/zip", "application/x-zip-compressed"]

------------------------------------------------------------
-- Tests for database operations
------------------------------------------------------------

-- Currently, this is how datas are stored in the DB, this can be changed in the future.
-- TODO(hs): Wrap primitive type with newtype
type DBTicketInfo = (TicketId, UserId, Maybe UserId, TicketURL, TicketTags, TicketStatus)
type DBTicketComment = (CommentId, TicketId, CommentBody, Bool, UserId)
type DBCommentAttachment = (AttachmentId, CommentId, Text, Text, Int)
type DBAttachmentContent = (Integer, ByteString)

deleteAllDataSpec :: Spec
deleteAllDataSpec =
    describe "deleteAllData" $ modifyMaxSuccess (const 200) $ do
       prop "should delete all datas from database" $
           monadicIO $ do
               (tickets, ticketComments, commentAttachments, attachmentContents) <-
                   run . withDBSchema ":memory:" $ \conn -> do
                       deleteAllData conn
                       tickets            <- query_ conn "SELECT * from ticket_info"
                       ticketComments     <- query_ conn "SELECT * from ticket_comment"
                       commentAttachments <- query_ conn "SELECT * from comment_attachment"
                       attachmentContents <- query_ conn "SELECT * from attachment_content"
                       return (tickets, ticketComments, commentAttachments, attachmentContents)

               assert . null $ (tickets            :: [DBTicketInfo])
               assert . null $ (ticketComments     :: [DBTicketComment])
               assert . null $ (commentAttachments :: [DBCommentAttachment])
               assert . null $ (attachmentContents :: [DBAttachmentContent])

       prop "should try to delete datas from database without tables, throws exception" $
           monadicIO $ do
               eResult <- run . try $ withConnection ":memory:" deleteAllData

               assert $ isLeft (eResult :: Either DBLayerException ())

insertCommentAttachmentsSpec :: Spec
insertCommentAttachmentsSpec =
    describe "insertCommentAttachmentsSpec" $ modifyMaxSuccess (const 200) $ do
        prop "should insert comment and its attachment to the database" $
            \(comment :: Comment) (attachment :: Attachment) ->
                monadicIO $ do
                    dbAttachments <- run . withDBSchema ":memory:" $ \conn -> do
                            insertCommentAttachments conn comment attachment
                            dbAttachments <- queryNamed conn
                                "SELECT * FROM comment_attachment WHERE comment_id = :id"
                                [":id" := cId comment]
                            return (dbAttachments :: [DBCommentAttachment])

                    assert . isJust . safeHead $ dbAttachments
                    whenJust (safeHead dbAttachments) $
                        \(attachmentId, commentId, attUrl, attContentType, attSize) -> do
                           assert $ attachmentId   == aId attachment
                           assert $ commentId      == cId comment
                           assert $ attUrl         == aURL attachment
                           assert $ attContentType == aContentType attachment
                           assert $ attSize        == aSize attachment

        prop "should try to insert comment and its attachment to the database without tables, throws exception" $
            \(comment :: Comment) (attachment :: Attachment) ->
                monadicIO $ do
                    eResult <- run . try $
                        withConnection ":memory:" $ \conn
                            -> insertCommentAttachments conn comment attachment

                    assert $ isLeft (eResult :: Either DBLayerException ())

insertTicketInfoSpec :: Spec
insertTicketInfoSpec =
    describe "insertTicketInfo" $ modifyMaxSuccess (const 200) $ do
      prop "should insert ticket info to the dabatase" $
          \(ticketInfo :: TicketInfo) ->
              monadicIO $ do
                dbTicketInfos <- run . withDBSchema ":memory:" $ \conn -> do
                        insertTicketInfo conn ticketInfo
                        dbTicketInfos <- queryNamed conn "SELECT * FROM ticket_info WHERE tiId = :id"
                            [":id" := (getTicketId . tiId) ticketInfo]
                        return (dbTicketInfos :: [DBTicketInfo])

                assert . isJust . safeHead $ dbTicketInfos
                whenJust (safeHead dbTicketInfos)
                    (\(ticketId, requesterId, assigneeId, ticketUrl, ticketTags, ticketStatus) -> do
                       assert $ ticketId     == tiId ticketInfo
                       assert $ requesterId  == tiRequesterId ticketInfo
                       assert $ assigneeId   == tiAssigneeId ticketInfo
                       assert $ ticketUrl    == tiUrl ticketInfo
                       assert $ ticketTags   == tiTags ticketInfo
                       assert $ ticketStatus == tiStatus ticketInfo
                    )
      prop "should try to insert ticketInfo to the database without tables, throws exception" $
          \(ticketInfo :: TicketInfo) ->
              monadicIO $ do
                eResult <- run . try $
                    withConnection ":memory:" $ \conn -> insertTicketInfo conn ticketInfo

                assert $ isLeft (eResult :: Either DBLayerException ())

insertTicketCommentsSpec :: Spec
insertTicketCommentsSpec =
    describe "insertTicketComments" $ modifyMaxSuccess (const 200) $ do
      prop "should insert ticketId and its comments to the dabatase" $
          \(ticketId :: TicketId) (comment :: Comment) ->
              monadicIO $ do
               dbComments <- run . withDBSchema ":memory:" $ \conn -> do
                        insertTicketComments conn ticketId comment
                        dbComments <- queryNamed conn
                            "SELECT * FROM ticket_comment WHERE ticket_id = :id"
                            [":id" := getTicketId ticketId]
                        return (dbComments :: [DBTicketComment])

               assert . isJust . safeHead $ dbComments
               whenJust (safeHead dbComments) $ \(commentId, tid, commentbody, isPublic, authorId) -> do
                   assert $ tid         == ticketId
                   assert $ commentbody == cBody comment
                   assert $ commentId   == cId comment
                   assert $ isPublic    == cPublic comment
                   assert $ authorId    == cAuthor comment

      prop "should try to insert ticketId and comment to the database without tables, throws exception" $
          \(ticketId :: TicketId) (comment :: Comment) ->
              monadicIO $ do
                eResult <- run . try $
                    withConnection ":memory:" $ \conn -> insertTicketComments conn ticketId comment

                assert $ isLeft (eResult :: Either DBLayerException ())

-- | Perform an action to the database with schema
withDBSchema :: String -> (Connection -> IO a) -> IO a
withDBSchema dbpath action =
    withConnection dbpath $ \conn -> do
        createSchema conn
        action conn

inspectAttachmentSpec :: Spec
inspectAttachmentSpec =
    describe "inspectAttachment" $ modifyMaxSuccess (const 200) $ do
        prop "should inspect attchment and return zendeskResponse" $
            \(ticketInfo :: TicketInfo) ->
                monadicIO $ do
                    zendeskResponse <- run $ inspectAttachment emptyConfig ticketInfo
                        mempty emptyExtractLogFunc emptyExtractErrorCodeFunc

                    assert $ tiId ticketInfo == zrTicketId zendeskResponse
        prop "should return response with tag 'sent-log-corrupted' when it failed to extract logs" $
            \(ticketInfo :: TicketInfo) ->
                monadicIO $ do
                    zendeskResponse <- run $ inspectAttachment emptyConfig ticketInfo
                        mempty errorExtractLogFunc extractIssuesFromLogs

                    assert $ tiId ticketInfo == zrTicketId zendeskResponse
                    assert $ zrTags zendeskResponse == TicketTags [renderErrorCode SentLogCorrupted]

        prop "should return response with tag 'sent-log-corrupted' if given log was corrupted" $
            \(ticketInfo :: TicketInfo) ->
                monadicIO $ do
                    zendeskResponse <- run $ inspectAttachment emptyConfig ticketInfo
                        mempty emptyExtractLogFunc (errorExtractErrorCodeFunc LogReadException)

                    assert $ tiId ticketInfo == zrTicketId zendeskResponse
                    assert $ zrTags zendeskResponse == TicketTags [renderErrorCode SentLogCorrupted]

        prop "should return zendeskResponse with tag 'no-known-issue' when it failed to extract logs" $
            \(ticketInfo :: TicketInfo) ->
                monadicIO $ do
                    zendeskResponse <- run $ inspectAttachment emptyConfig ticketInfo
                        mempty emptyExtractLogFunc (errorExtractErrorCodeFunc NoKnownIssueFound)

                    assert $ tiId ticketInfo == zrTicketId zendeskResponse
                    assert $ zrTags zendeskResponse == TicketTags [renderErrorCode NoKnownIssue]

        prop "should return throw JSONDecodeFailure exception when it fails to decode json file" $
            \(ticketInfo :: TicketInfo) ->
                monadicIO $ do
                    eZendeskResponse <- run . try $ inspectAttachment emptyConfig ticketInfo
                        mempty emptyExtractLogFunc (errorExtractErrorCodeFunc $ JSONDecodeFailure mempty)

                    assert $ not $ isRight (eZendeskResponse :: Either LogAnalysisException ZendeskResponse)
  where
    emptyExtractLogFunc :: Int -> LByteString -> Either ZipFileExceptions [LogFile]
    emptyExtractLogFunc _ _ = return mempty

    errorExtractLogFunc :: Int -> LByteString -> Either ZipFileExceptions [LogFile]
    errorExtractLogFunc _ _ = Left ReadZipFileException

    emptyExtractErrorCodeFunc :: (Monad m) => [LogFile] -> Analysis -> m Analysis
    emptyExtractErrorCodeFunc _ _ = return emptyAnalysis

    errorExtractErrorCodeFunc :: (MonadCatch m)
                              => LogAnalysisException
                              -> [LogFile]
                              -> Analysis
                              -> m Analysis
    errorExtractErrorCodeFunc e _ _ = throwM e

    emptyAnalysis :: Analysis
    emptyAnalysis = setupAnalysis mempty


module Statistics
    ( runJSONFold
    , receivedCreatedF
    , module Statistics.Block
    , module Statistics.Chart
    , module Statistics.CSV
    , module Statistics.Focus
    , module Statistics.Graph
    , module Statistics.MemPool
    , module Statistics.Report
    , module Statistics.Throughput
    , module Statistics.Tx
    ) where

import           Control.Foldl (Fold (..))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M

import           JSONLog
import           Statistics.Block
import           Statistics.Chart
import           Statistics.CSV
import           Statistics.Focus
import           Statistics.Graph
import           Statistics.MemPool
import           Statistics.Report
-- import Statistics.Relay
import           Statistics.Throughput
import           Statistics.Tx
import           Types
import           Universum
import           Util.Pipes (fold')

runJSONFold :: FilePath -> Fold IndexedJLTimedEvent a -> IO a
runJSONFold logDir fd = runParseLogs logDir $ fold' fd

receivedCreatedF :: Fold IndexedJLTimedEvent (Map TxHash (Maybe Timestamp))
receivedCreatedF = f <$> txFirstReceivedF <*> inBlockChainF
  where
    f :: Map TxHash Timestamp -> Map TxHash Timestamp -> Map TxHash (Maybe Timestamp)
    f rm cm = M.mapWithKey g rm
      where
        g :: TxHash -> Timestamp -> Maybe Timestamp
        g tx ts = maybe Nothing (\ts' -> Just $ ts' - ts) $ M.lookup tx cm


-- Programatica Front-End Commands, level 0
module Pfe0Cmds where
import Prelude hiding (print,putStr,putStrLn,catch,readFile)
import Data.List((\\))
import Control.Monad(unless,when)
import Data.Maybe(fromJust)

import PFE0

import HsName(ModuleName(..),isMainModule,sameModuleName)
--import HsConstants(main_mod)
import HsLexerPass1(rmSpace,Pos(line)) -- for lines of code metrics

import PfeParse
import PrettyPrint
import MUtils
import SimpleGraphs(reverseGraph,reachable)
import DirUtils(optCreateDirectory)
import AbstractIO
import Statistics

pfe0 parseModule args = runPFE0Cmds () pfe0Cmds parseModule args

--runPFE0Cmds ext cmds = runPFE0 ext $ doCmd (cmds, projectStatus)
runPFE0Cmds ext cmds = runCmds (runPFE0 ext) cmds

pfe0Cmds = projman++graphqueries

addHelpCmd prg cmds0 = cmds where cmds=cmds0++helpCmd prg cmds

helpCmd prg cmds =
  [("help",(noArgs (putStrLn (usage prg cmds)),"list available commands"))]

projman =
  -- Project management (a project is a set of source files)
  [("new"     , (qfileArgs  new, "create a new project containing zero or more files")),
   ("add"     , (qfileArgs  add, "add files to the project")),
   ("remove"  , (qfileArgs  remove, "remove files from the project")),
   ("prune"   , (moduleArgs prune,"remove unreachable modules from the project")),
   ("files"   , (noArgs     files,"list files in the project")),
   ("options" , (noArgs     options,"show options in effect"))]

graphqueries =
  -- Module graph queries
  [("modules" , (moduleArgs modules,"show a topologically sorted list of modules")),
   ("graph"   , (graphArgs graph,"show module dependecy (sub)graph")),
--   ("dirgraph", (moduleArgs dirgraph,"show source directory dependecy (sub)graph")),
--   ("dotdirgraph", (moduleArgs dotdirgraph,"dot format source directory dependecy (sub)graph")),
   ("unused"  , (moduleArgs unused,"list unimported and unreachable modules")),
   ("file"    , (moduleArg  file,"which file is the module in")),
   ("module"  , (fileArg    module',"which module does the file contain")),
   ("loc"     , (moduleArgs locModules, "number of lines of code")),
   ("sizemetrics" , (noArgs sizeMetrics, "number of lines per module metrics")),
   ("locmetrics" , (noArgs locMetrics, "number of lines of code per module metrics")),
   ("importmetrics",(noArgs importMetrics, "number of imports per module metrics")),
   ("exportmetrics",(noArgs exportMetrics, "number of exports (importers) per module metrics"))]

--- Project management ---------------------------------------------------------
new    quiet args = do newProject; addPaths quiet args
add    quiet args = addPaths quiet args
remove quiet args = removePaths quiet args

files = putStr . unlines =<< allFiles

options = print =<< parserFlags

qfileArgs f = f #@ kwOption "-quiet" <@ filenames

--- Module graph queries -------------------------------------------------------
modules ms = do g <- getSortedSubGraph (just ms)
	        let sccs = map (map (fst.snd)) g
	        putStrLn "Topologically sorted strongly connected components:"
	        putStr (unlines (map (unwords.map pp) sccs))

graphArgs = moduleArgs' graphOpts
  where
    graphOpts = (,,) #@ kwOption "-rev" <@ kwOption "-dot" <@ kwOption "-dir"

graph (rev,dot,dir) =
    pput . out_conv_dirs @@ getSubGraph . just
  where
    out_conv_dirs  = if dir then out_conv . srcdirGraph  else out_conv . map snd
    out_conv = out . conv
    out   = if dot then dotFormat    else makeFormat
    conv  = if rev then reverseGraph else id

-- Dot format functions contributed by Claus Reinke:

dotFormat g =
   "digraph ModuleGraph {size=\"7.5,10.5\";ratio=fill;" $$
   vcat [q x<>"->"<>braces (fsep [q d<>";"|d<-xs])|(x,xs)<-g] $$
   "}"
  where
    q = doubleQuotes

makeFormat g = vcat [x<>":"<+>fsep xs|(x,xs)<-g]

--dirgraph    ms = pput . makeFormat =<< srcdirGraph ms
--dotdirgraph ms = pput . dotFormat =<< srcdirGraph ms

srcdirGraph g = dg
  where moddirs = [(m,dirname path)|(path,(m,_))<-g]
	moddir m = fromJust (lookup m moddirs)
	dg = mapSnd usort $
	     collectByFst
	       [(moddir m,dir')|(_,(m,ms))<-g,dir'<-usort (map moddir ms)]

dirname = current . reverse . dropWhile (/='/') . reverse
  where current "" = "./"
	current path = path

file m =
    do g <- getCurrentModuleGraph
       pput $ vcat [m<>":"<+>f|(f,(m',_))<-g,m'==m]

module' f =
    do g <- getCurrentModuleGraph
       pput $ vcat [f<>":"<+>m|(f',(m,_))<-g,f'==f]

getUnused ms =
  do fg <- getCurrentModuleGraph
     let g = map snd fg
         unimported = map fst g \\ [m|(m,_:_)<-reverseGraph g]
	 roots = if null ms then mains else ms
	   where mains = [m|(m,_)<-g,isMainModule m]
	 r = reachable g roots
	 unreached = map fst g \\ r
     when (null roots) $
       fail "No root modules given, no Main module in the project"
     return (fg,roots,unimported,unreached)

mainModules =
  do fg <- getCurrentModuleGraph
     return [m|(f,(m,_))<-fg,isMainModule m]

unused ms =
  do (_,roots,us,unr) <- getUnused ms
     if null us -- unlikely...
       then putStrLn "All modules are imported somewhere"
       else pput $ "The following modules are never imported:" $$
	           nest 4 (fsep us)
     unless (null unr) $
       do pput $
	    sep [ppi "The following modules are unreachable from",
		 nest 2 (fsep roots<>":")]
	  pput $ nest 4 (fsep unr)

prune ms =
  do (fg,_,_,unreached) <- getUnused ms
     removePaths False [f|(f,(m,_))<-fg,m `elem` unreached]

sizeMetrics =
    pput . ppStatistics "number of lines" "module"
      =<< mapM (forkM (fst.snd) (size #. readFile . fst))
      =<< getCurrentModuleGraph
  where
    size = length . lines

locMetrics =
    pput . ppStatistics "number of lines of code" "module"
      =<< mapM (forkM (fst.snd) (loc . snd #. lex0SourceFile.fst))
      =<< getCurrentModuleGraph

--forkM f g x = (,) (f x) # g x
forkM f g x =
  do y <- g x
      -- seq to process one file at a time in locMetrics & sizeMetrics
     seq y (return (f x,y))

loc = length . squeezeDups . map (line.fst.snd) . rmSpace

locModules = mapM_ locModule
locModule = locFile @@ findFile
locFile = pput . loc . snd @@ lex0SourceFile

importMetrics = graphMetrics id "number of imports"
exportMetrics = graphMetrics reverseGraph "number of importers"

graphMetrics f lbl =
    do g <- mapSnd length . f . map snd # getCurrentModuleGraph
       pput $ ppStatistics lbl "module" g


{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -freduction-depth=100 #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
-- | Instances for 'Generic' and 'HasMetadata'.
--
-- We define instances for datatypes from @generics-sop@ and
-- @base@ that are supported.
--
-- (There are only instances defined in this module, so the
-- documentation is empty.)
--
module Generics.SOP.Instances () where

-- GHC versions and base versions:
--
-- 7.6.3:  4.6.0.1
-- 7.8.3:  4.7.0.1
-- 7.8.4:  4.7.0.2
-- 7.10.3: 4.8.2.0
-- 8.0.2:  4.9.1.0
-- 8.2.2:  4.10.1.0
-- 8.4.3:  4.11.1.0
-- 8.6.1:  4.12.0.0

import Control.Exception
import Data.Char
import Data.Complex
import Data.Data
import Data.Fixed
import Data.Functor.Compose -- new
import qualified Data.Functor.Const -- new
import Data.Functor.Identity -- new
import Data.Functor.Product -- new
import Data.Functor.Sum -- new
import Data.List.NonEmpty -- new
import qualified Data.Monoid
import Data.Ord
import qualified Data.Semigroup -- new
import Data.Version
import Data.Void -- new
import Foreign.C.Error
import Foreign.C.Types
#if MIN_VERSION_base(4,11,0)
import GHC.ByteOrder -- new
#endif
import GHC.Conc -- new
import GHC.ExecutionStack -- new
import GHC.Exts -- new
-- import GHC.Events -- platform-specific, omitted
import GHC.Fingerprint -- new
import GHC.Float -- new
import qualified GHC.Generics -- new
import GHC.IO.Buffer -- new
import GHC.IO.Device -- new
import GHC.IO.Encoding -- new
import GHC.IO.Encoding.Failure -- new
import GHC.IO.Exception -- new
import GHC.IO.Handle -- new
import GHC.RTS.Flags -- new
import qualified GHC.Stack -- new
import GHC.StaticPtr -- new
import GHC.Stats -- new
import System.Console.GetOpt
import System.IO
import Text.Printf
import Text.Read.Lex

import Generics.SOP.BasicFunctors
import Generics.SOP.Classes
import Generics.SOP.TH

-- Types from Generics.SOP:

deriveGeneric ''I
deriveGeneric ''K
deriveGeneric ''(:.:)
deriveGeneric ''(-.->) -- new

-- Cannot derive instances for Sing
-- Cannot derive instances for Shape
-- Cannot derive instances for NP, NS, POP, SOP
-- Cannot derive instances for metadata types

-- Types from the Prelude:

deriveGeneric ''Bool
deriveGeneric ''Ordering
deriveGeneric ''Maybe
deriveGeneric ''Either
deriveGeneric ''()
deriveGeneric ''(,)              -- 2
deriveGeneric ''(,,)
deriveGeneric ''(,,,)
deriveGeneric ''(,,,,)           -- 5
deriveGeneric ''(,,,,,)
deriveGeneric ''(,,,,,,)
deriveGeneric ''(,,,,,,,)
deriveGeneric ''(,,,,,,,,)
deriveGeneric ''(,,,,,,,,,)      -- 10
deriveGeneric ''(,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,) -- 15
deriveGeneric ''(,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,) -- 20
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,) -- 25
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30
deriveGeneric ''[]

-- Other types from base:

-- From Control.Exception:
deriveGeneric ''IOException
deriveGeneric ''ArithException
deriveGeneric ''ArrayException
deriveGeneric ''AssertionFailed
deriveGeneric ''AsyncException
deriveGeneric ''NonTermination
deriveGeneric ''NestedAtomically
deriveGeneric ''BlockedIndefinitelyOnMVar
deriveGeneric ''BlockedIndefinitelyOnSTM
deriveGeneric ''AllocationLimitExceeded -- new
deriveGeneric ''Deadlock
deriveGeneric ''NoMethodError
deriveGeneric ''PatternMatchFail
deriveGeneric ''RecConError
deriveGeneric ''RecSelError
deriveGeneric ''RecUpdError
deriveGeneric ''ErrorCall
deriveGeneric ''TypeError -- new
deriveGeneric ''MaskingState

-- From Data.Char:
deriveGeneric ''GeneralCategory

-- From Data.Complex:
deriveGeneric ''Complex

-- From Data.Data:
deriveGeneric ''DataRep
deriveGeneric ''Fixity
deriveGeneric ''ConstrRep

-- From Data.Fixed:
deriveGeneric ''Fixed
deriveGeneric ''E0
deriveGeneric ''E1
deriveGeneric ''E2
deriveGeneric ''E3
deriveGeneric ''E6
deriveGeneric ''E9
deriveGeneric ''E12

-- From Data.Functor.Compose
deriveGeneric ''Compose -- new

-- From Data.Functor.Const
deriveGeneric ''Data.Functor.Const.Const -- new

-- From Data.Functor.Identity
deriveGeneric ''Identity -- new

-- From Data.Functor.Product
deriveGeneric ''Product -- new

-- From Data.Functor.Sum
deriveGeneric ''Sum -- new

-- From Data.List.NonEmpty
deriveGeneric ''NonEmpty -- new

-- From Data.Monoid:
deriveGeneric ''Data.Monoid.Dual
deriveGeneric ''Data.Monoid.Endo
deriveGeneric ''Data.Monoid.All
deriveGeneric ''Data.Monoid.Any
deriveGeneric ''Data.Monoid.Sum
deriveGeneric ''Data.Monoid.Product
deriveGeneric ''Data.Monoid.First
deriveGeneric ''Data.Monoid.Last
deriveGeneric ''Data.Monoid.Alt -- new

-- From Data.Ord:
deriveGeneric ''Down

-- From Data.Proxy:
deriveGeneric ''Proxy

-- From Data.Semigroup:
deriveGeneric ''Data.Semigroup.Min -- new
deriveGeneric ''Data.Semigroup.Max -- new
deriveGeneric ''Data.Semigroup.First -- new
deriveGeneric ''Data.Semigroup.Last -- new
deriveGeneric ''Data.Semigroup.WrappedMonoid -- new
deriveGeneric ''Data.Semigroup.Option -- new
deriveGeneric ''Data.Semigroup.Arg -- new

-- From Data.Version:
deriveGeneric ''Version

-- From Data.Void:
deriveGeneric ''Void -- new

-- From Foreign.C.Error:
deriveGeneric ''Errno

-- From Foreign.C.Types:
deriveGeneric ''CChar
deriveGeneric ''CSChar
deriveGeneric ''CUChar
deriveGeneric ''CShort
deriveGeneric ''CUShort
deriveGeneric ''CInt
deriveGeneric ''CUInt
deriveGeneric ''CLong
deriveGeneric ''CULong
deriveGeneric ''CPtrdiff
deriveGeneric ''CSize
deriveGeneric ''CWchar
deriveGeneric ''CSigAtomic
deriveGeneric ''CLLong
deriveGeneric ''CULLong
deriveGeneric ''CIntPtr
deriveGeneric ''CUIntPtr
deriveGeneric ''CIntMax
deriveGeneric ''CUIntMax
deriveGeneric ''CClock
deriveGeneric ''CTime
deriveGeneric ''CUSeconds
deriveGeneric ''CSUSeconds
deriveGeneric ''CFloat
deriveGeneric ''CDouble

#if MIN_VERSION_base(4,11,0)
-- From GHC.ByteOrder:
deriveGeneric ''ByteOrder -- new
#endif

-- From GHC.Conc:
deriveGeneric ''ThreadStatus -- new
deriveGeneric ''BlockReason -- new

-- From GHC.ExecutionStack:
deriveGeneric ''Location -- new
deriveGeneric ''SrcLoc -- new

-- From GHC.Exts:
deriveGeneric ''RuntimeRep -- new
deriveGeneric ''VecCount -- new
deriveGeneric ''VecElem -- new
deriveGeneric ''SpecConstrAnnotation -- new

-- From GHC.Generics:
deriveGeneric ''GHC.Generics.K1 -- new
deriveGeneric ''GHC.Generics.U1 -- new
deriveGeneric ''GHC.Generics.V1 -- new
deriveGeneric ''GHC.Generics.Par1 -- new
deriveGeneric ''GHC.Generics.M1 -- new
deriveGeneric ''GHC.Generics.R -- new
deriveGeneric ''GHC.Generics.S -- new
deriveGeneric ''GHC.Generics.D -- new
deriveGeneric ''GHC.Generics.C -- new
deriveGeneric ''(GHC.Generics.:*:) -- new
deriveGeneric ''(GHC.Generics.:+:) -- new
deriveGeneric ''(GHC.Generics.:.:) -- new
deriveGeneric ''GHC.Generics.Associativity -- new
deriveGeneric ''GHC.Generics.DecidedStrictness -- new
deriveGeneric ''GHC.Generics.SourceStrictness -- new
deriveGeneric ''GHC.Generics.SourceUnpackedness -- new
deriveGeneric ''GHC.Generics.Fixity -- new

-- From GHC.IO.Buffer:
deriveGeneric ''Buffer -- new
deriveGeneric ''BufferState -- new

-- From GHC.IO.Device:
deriveGeneric ''IODeviceType -- new

-- From GHC.IO.Encoding:
deriveGeneric ''BufferCodec -- new
deriveGeneric ''CodingProgress -- new

-- From GHC.IO.Encoding.Failure:
deriveGeneric ''CodingFailureMode -- new

-- From GHC.Fingerprint
deriveGeneric ''Fingerprint -- new

-- From GHC.Float
deriveGeneric ''FFFormat -- new

-- From GHC.IO.Exception:
#if MIN_VERSION_base(4,11,0)
deriveGeneric ''FixIOException -- new
deriveGeneric ''IOErrorType -- new
#endif

-- From GHC.IO.Handle:
deriveGeneric ''HandlePosn -- new
#if MIN_VERSION_base(4,10,0)
deriveGeneric ''LockMode -- new
#endif

-- From GHC.RTS.Flags:
deriveGeneric ''RTSFlags -- new
deriveGeneric ''GiveGCStats -- new
deriveGeneric ''GCFlags -- new
deriveGeneric ''ConcFlags -- new
deriveGeneric ''MiscFlags -- new
deriveGeneric ''DebugFlags -- new
deriveGeneric ''DoCostCentres -- new
deriveGeneric ''CCFlags -- new
deriveGeneric ''DoHeapProfile -- new
deriveGeneric ''ProfFlags -- new
deriveGeneric ''DoTrace -- new
deriveGeneric ''TraceFlags -- new
deriveGeneric ''TickyFlags -- new
#if MIN_VERSION_base(4,10,0)
deriveGeneric ''ParFlags -- new
#endif

-- From GHC.Stack:
deriveGeneric ''GHC.Stack.SrcLoc -- new
deriveGeneric ''GHC.Stack.CallStack -- new

-- From GHC.StaticPtr:
deriveGeneric ''StaticPtrInfo -- new

-- From GHC.Stats:
#if MIN_VERSION_base(4,10,0)
deriveGeneric ''RTSStats -- new
deriveGeneric ''GCDetails -- new
#endif
#if !MIN_VERSION_base(4,11,0)
deriveGeneric ''GCStats -- new
#endif

-- From System.Console.GetOpt:

deriveGeneric ''ArgOrder
deriveGeneric ''OptDescr
deriveGeneric ''ArgDescr

-- From System.Exit:

deriveGeneric ''ExitCode

-- From System.IO:

deriveGeneric ''IOMode
deriveGeneric ''BufferMode
deriveGeneric ''SeekMode
deriveGeneric ''Newline
deriveGeneric ''NewlineMode

-- From Text.Printf:

deriveGeneric ''FieldFormat
deriveGeneric ''FormatAdjustment
deriveGeneric ''FormatSign
deriveGeneric ''FormatParse

-- From Text.Read.Lex:

deriveGeneric ''Lexeme
deriveGeneric ''Number

-- Abstract / primitive datatypes (we don't derive Generic for these):
--
-- Ratio
-- Integer
-- ThreadId
-- Chan
-- MVar
-- QSem
-- QSemN
-- DataType
-- Dynamic
-- IORef
-- TypeRep
-- TyCon
-- TypeRepKey
-- KProxy -- not abstract, but intended for kind-level use
-- STRef
-- Unique
-- ForeignPtr
-- CFile
-- CFpos
-- CJmpBuf
-- Pool
-- Ptr
-- FunPtr
-- IntPtr
-- WordPtr
-- StablePtr
-- Char
-- Double
-- Float
-- Int
-- Int8
-- Int16
-- Int32
-- Int64
-- Word
-- Word8
-- Word16
-- Word32
-- Word64
-- IO
-- ST
-- (->)
-- RealWorld
-- Handle
-- HandlePosn
-- TextEncoding
-- StableName
-- Weak
-- ReadP
-- ReadPrec
-- STM
-- TVar
-- Natural
-- Event
-- EventManager
-- CostCentre
-- CostCentreStack
--
-- Datatypes we cannot currently handle:
--
-- SomeException
-- SomeAsyncException
-- Handler
-- Coercion
-- (:~:)


{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}

module DispatchLoop (dispatchLoop) where

import qualified Sound.ALSA.Sequencer.Connect as Connect
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer as SndSeq

import qualified Data.Foldable as DF
import qualified Data.List as DL
import qualified Data.Set as DS
import qualified Data.Map as DM
import qualified Data.IntSet as IS
import qualified Data.Sequence as SQ
import GHC.Word
import Data.Maybe
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Control.Monad

import Statistics

import Control.Exception
import Control.Concurrent
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Lazy

import ChordData
import ChordUtils
import EventUtils
import LoopConfig
import ChordMatrix
import ShowStatus

import WithCli

data Options = Options {
  channel :: Maybe Int,
  config :: Maybe String,
  cmdelay :: Maybe Int,
  codelay :: Maybe Int,
  histlen :: Maybe Int
} deriving (Show, Generic, HasArguments)

getus :: IO Integer

getus = (*1000000) `fmap` getPOSIXTime >>= return . round

loadcr :: Maybe String -> IO (ChordRouting, Maybe UTCTime)

loadcr Nothing = return (chordMatrix, Nothing)
loadcr (Just f) = tryLoad f `catch` \(e :: SomeException) -> do
  putStrLn $ show e
  cfgt <- getCfgTime f
  return (chordMatrix, cfgt)

fromMaybeMax n d mbn = max n (fromMaybe d mbn)

dispatchLoop :: SndSeq.T SndSeq.DuplexMode ->
                Connect.T ->
                Options -> IO ()

dispatchLoop h ci opt@Options {channel = chan, config = s} = do
  dtt <- getus
  (cr, mbcfgt) <- loadcr s
  evalStateT loop LoopStatus {
    h = h,
    ci = ci,
    chan = Event.Channel $ fromIntegral $ fromMaybe 0 chan,
    cr = cr,
    is = IS.empty,
    pvl = 0,
    os = DS.empty,
    dt = dtt,
    diff = 0,
    tsamples = IS.empty,
    age = 0,
    status = ChordOff,
    ping = Nothing,
    ckcfg = Nothing,
    cfgtime = mbcfgt,
    cfgpath = s,
    cmdly = fromMaybeMax 1 10 (cmdelay opt),
    codly = fromMaybeMax 1 10 (codelay opt),
    portmap = DM.empty,
    statmsg = "",
    statchg = False,
    chstlen = fromMaybeMax 1 3 (histlen opt),
    chist = SQ.empty,
    stats = Stats 0 0 0 0
}

loop :: StateT LoopStatus IO ()

loop = do
  showstat
  ports <- gets cr >>= (return . listPorts)
  pm <- gets portmap
  let newports = ports DL.\\ DM.keys pm
  hh <- gets h
  newconns <- lift $ mapM (makePort hh) newports
  modify (\s -> s {portmap = DM.union pm (DM.fromList $ zip newports newconns)})
  cn <- gets chan
  pn <- gets ping
  e <- gets h >>= lift . Event.input
  case eventChannel e of
    Nothing | pingEvent (Event.body e) -> handleChords
    Nothing | ckcfgEvent (Event.body e) -> checkConfig
    Just ec | ec == cn -> do
      if isNothing pn then (do
        let pn' = e {Event.body = Event.CustomEv Event.User0 Event.customZero}
        let ck' = e {Event.body = Event.CustomEv Event.User1 Event.customZero}
        modify (\s -> s {ping = Just pn', ckcfg = Just ck'})
        sendPingDelay' ckcfg 1000000)
      else return ()
      loop' e
    _ -> loop

loop' e = do
  case Event.body e of
    Event.CtrlEv ce ctrl | allNotesOff ce ctrl -> cancelChord
    Event.NoteEv ne note -> processNote ne note
    _ -> do
      loop

checkConfig = do
  cfgp <- gets cfgpath
  cfgt <- gets cfgtime
  case (cfgp, cfgt) of
    (Just fp, Just ft) -> do
      mbnwt <- lift $ getCfgTime fp
      case mbnwt of
        Just nwt -> do
          if nwt > ft
            then do
              crr <- gets cr
              (ncr, mbxx) <- lift (tryLoad fp `catch`
                                    (\(_::SomeException) -> return (crr, Nothing)))
              let sucf = case mbxx of
                           Just _ -> "success"
                           Nothing -> "failure"
              updstat ("reload config " ++ sucf)
              modify (\s -> s {cr = ncr, cfgtime = Just nwt})
            else return ()
          sendPingDelay' ckcfg 1000000
          loop
        _ -> loop
    _ -> loop

handleChords = do
  iss <- gets is
  ddff <- gets diff
  let dxff = fromIntegral ddff
  stt <- gets status
  hh <- gets h
  pvll <- gets pvl
  modify (\s -> s {pvl = IS.size iss})
  case stt of
    ChordOn d -> do
      case (IS.size iss `compare` pvll) of
        GT -> do
          updstat "chord growing while playing ignore"
          sendPingDelay d
          loop
        LT -> do
          updstat "chord dropping"
          modify (\s -> s {status = ChordOff, is = IS.empty})
          cancelChord
          loop
        EQ -> do
          modify (\s -> s {status = ChordOn d})
          sendPingDelay d
          loop
    Pinged -> case IS.size iss of
      _ | IS.size iss < pvll -> do
        modify (\s -> s {status = ChordOff, is = IS.empty})
        loop
      0 -> do
        modify (\s -> s {status = ChordOff})
        cancelChord
        loop
      1 -> do
        modify (\s -> s {status = ChordOff})
        loop
      _ | IS.size iss >= 2 -> do
        updstat "chord mature"
        ndxff <- compStats dxff
        let delay = ndxff * 10
        modify (\s -> s {status = Aging delay})
        sendPingDelay delay
        loop
    Aging d -> do
      case (IS.size iss `compare` pvll) of
        GT -> do
          sendPingDelay d
          loop
        LT -> do
          modify (\s -> s {status = ChordOff, is = IS.empty})
          cancelChord
          loop
        EQ -> do
          modify (\s -> s {status = ChordOn d})
          sendPingDelay d
          crr <- gets cr
          hist <- gets chist >>= return . DF.toList
          let chints = toIntervals iss
              mboc = routeChord hist crr (intervals chints)
          case mboc of
            Nothing -> do
              modify (\s -> s {status = ChordOff, is = IS.empty })
              loop
            _ -> do
              addHistory chints
              playChords mboc
              loop
    _ -> loop
  loop

playChords Nothing = loop

playChords (Just oc) = do
  pm <- gets portmap
  let mbcn = DM.lookup (outport oc) pm
  case mbcn of
    Nothing -> return ()
    Just cc -> do
      iss <- gets is
      let pc = buildChord iss oc
      oss <- gets os
      modify (\s -> s {statchg = True, os = DS.insert (outport oc, cc, outchan oc, pc) oss})
      hh <- gets h
      lift $ playChord hh cc (outchan oc) pc True
  playChords $ also oc

processNote ne note = do
  cn <- gets chan
  hh <- gets h
  let pitch = Event.unPitch $ Event.noteNote note
      velo = Event.unVelocity $ Event.noteVelocity note
  let note' = Event.simpleNote cn
                               (Event.Pitch pitch)
                               (Event.noteVelocity note)
  iss <- gets is
  let is' = compactChord $ case (ne, velo) of
              (Event.NoteOn, 0) -> IS.delete (fromIntegral pitch) iss
              (Event.NoteOn, _) -> IS.insert (fromIntegral pitch) iss
              (Event.NoteOff, _) -> IS.delete (fromIntegral pitch) iss
              _ -> iss
  cdtt <- lift getus
  pdtt <- gets dt
  modify (\s -> s {is = is', dt = cdtt})
  case IS.size is' of
    0 -> return ()
    1 -> modify (\s -> s {diff = 0})
    _ -> modify (\s -> s {diff = cdtt - pdtt})
  stt <- gets status
  case stt of
    _ | stt `elem` [ChordOff] -> do
      sendPingDelay 0
      modify (\s -> s {status = Pinged })
      return ()
    _ -> return ()
  loop

cancelChord = do
  hh <- gets h
  oss <- gets os
  forM_ oss $ \(_, cc, ochan, is) -> lift $ playChord hh cc ochan is False
  modify (\s -> s {statchg = True, is = IS.empty, os = DS.empty, status = ChordOff })
  loop

sendPingDelay d = sendPingDelay' ping d

sendPingDelay' ppp d = do
  hh <- gets h
  p <- gets ppp
  lift $ forkOS $ do
    threadDelay d
    sendPing hh p
  return ()

sendPing hh ping = do
  case ping of
    Just p -> do
      Event.outputDirect hh p
      return ()
    _ -> return ()
  Event.drainOutput hh
  return ()

compStats d = do
  samples <- gets tsamples
  let samples' = IS.insert d samples
  let st = map fromIntegral $ IS.toList samples'
  let tmean = mean st
  let tstd = stddev st
  let outlrs = filter (> (tmean + 3 * tstd)) st
  let keep = if length st > 10
               then filter (<= (tmean + 3 * tstd)) st
               else st
  let newmean = mean keep
  let newsamp = IS.fromList $ map round keep
  let newsamp' = if IS.size newsamp > 50 then IS.delete (IS.findMax newsamp) newsamp else newsamp
  modify (\s -> s {tsamples = newsamp', stats = Stats {
                                                  meann = tmean,
                                                  stddevv = tstd,
                                                  minn = fromIntegral $ IS.findMin samples',
                                                  maxx = fromIntegral $ IS.findMax samples'
                                                      }})
  return $ round newmean


{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -freduction-depth=100 #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
#else
{-# OPTIONS_GHC -fcontext-stack=50 #-}
#endif
-- | Instances for 'Generic' and 'HasMetadata'.
--
-- We define instances for datatypes from @generics-sop@ and
-- @base@ that are supported.
--
-- (There are only instances defined in this module, so the
-- documentation is empty.)
--
module Generics.SOP.Instances () where

import Control.Exception
import Data.Char
import Data.Complex
import Data.Data
import Data.Fixed
import Data.Monoid
import Data.Ord
#if !(MIN_VERSION_base(4,7,0))
import Data.Proxy
#endif
import Data.Version
import Foreign.C.Error
import Foreign.C.Types
import System.Console.GetOpt
import System.Exit
import System.IO
#if MIN_VERSION_base(4,7,0)
import Text.Printf
#endif
import Text.Read.Lex

import Generics.SOP.BasicFunctors
import Generics.SOP.TH

-- Types from Generics.SOP:

deriveGeneric ''I
deriveGeneric ''K
deriveGeneric ''(:.:)

-- Cannot derive instances for Sing
-- Cannot derive instances for Shape
-- Cannot derive instances for NP, NS, POP, SOP
-- Cannot derive instances for metadata types

-- Types from the Prelude:

deriveGeneric ''Bool
deriveGeneric ''Ordering
deriveGeneric ''Maybe
deriveGeneric ''Either
deriveGeneric ''()
deriveGeneric ''(,)              -- 2
deriveGeneric ''(,,)
deriveGeneric ''(,,,)
deriveGeneric ''(,,,,)           -- 5
deriveGeneric ''(,,,,,)
deriveGeneric ''(,,,,,,)
deriveGeneric ''(,,,,,,,)
deriveGeneric ''(,,,,,,,,)
deriveGeneric ''(,,,,,,,,,)      -- 10
deriveGeneric ''(,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,) -- 15
deriveGeneric ''(,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,) -- 20
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,) -- 25
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30
deriveGeneric ''[]

-- Other types from base:

-- From Control.Exception:
deriveGeneric ''IOException
deriveGeneric ''ArithException
deriveGeneric ''ArrayException
deriveGeneric ''AssertionFailed
deriveGeneric ''AsyncException
deriveGeneric ''NonTermination
deriveGeneric ''NestedAtomically
deriveGeneric ''BlockedIndefinitelyOnMVar
deriveGeneric ''BlockedIndefinitelyOnSTM
deriveGeneric ''Deadlock
deriveGeneric ''NoMethodError
deriveGeneric ''PatternMatchFail
deriveGeneric ''RecConError
deriveGeneric ''RecSelError
deriveGeneric ''RecUpdError
deriveGeneric ''ErrorCall
deriveGeneric ''MaskingState

-- From Data.Char:
deriveGeneric ''GeneralCategory

-- From Data.Complex:
deriveGeneric ''Complex

-- From Data.Data:
deriveGeneric ''DataRep
deriveGeneric ''Fixity
deriveGeneric ''ConstrRep

-- From Data.Fixed:
deriveGeneric ''Fixed

-- From Data.Monoid:
deriveGeneric ''Dual
deriveGeneric ''Endo
deriveGeneric ''All
deriveGeneric ''Any
deriveGeneric ''Sum
deriveGeneric ''Product
deriveGeneric ''First
deriveGeneric ''Last

-- From Data.Ord:
deriveGeneric ''Down

-- From Data.Proxy:
deriveGeneric ''Proxy

-- From Data.Version:
deriveGeneric ''Version

-- From Foreign.C.Error:
deriveGeneric ''Errno

-- From Foreign.C.Types:
deriveGeneric ''CChar
deriveGeneric ''CSChar
deriveGeneric ''CUChar
deriveGeneric ''CShort
deriveGeneric ''CUShort
deriveGeneric ''CInt
deriveGeneric ''CUInt
deriveGeneric ''CLong
deriveGeneric ''CULong
deriveGeneric ''CPtrdiff
deriveGeneric ''CSize
deriveGeneric ''CWchar
deriveGeneric ''CSigAtomic
deriveGeneric ''CLLong
deriveGeneric ''CULLong
deriveGeneric ''CIntPtr
deriveGeneric ''CUIntPtr
deriveGeneric ''CIntMax
deriveGeneric ''CUIntMax
deriveGeneric ''CClock
deriveGeneric ''CTime
deriveGeneric ''CUSeconds
deriveGeneric ''CSUSeconds
deriveGeneric ''CFloat
deriveGeneric ''CDouble

-- From System.Console.GetOpt:

deriveGeneric ''ArgOrder
deriveGeneric ''OptDescr
deriveGeneric ''ArgDescr

-- From System.Exit:

deriveGeneric ''ExitCode

-- From System.IO:

deriveGeneric ''IOMode
deriveGeneric ''BufferMode
deriveGeneric ''SeekMode
deriveGeneric ''Newline
deriveGeneric ''NewlineMode

-- From Text.Printf:

#if MIN_VERSION_base(4,7,0)
deriveGeneric ''FieldFormat
deriveGeneric ''FormatAdjustment
deriveGeneric ''FormatSign
deriveGeneric ''FormatParse
#endif

-- From Text.Read.Lex:

deriveGeneric ''Lexeme
#if MIN_VERSION_base(4,7,0)
deriveGeneric ''Number
#endif

-- Abstract / primitive datatypes (we don't derive Generic for these):
--
-- Ratio
-- Integer
-- ThreadId
-- Chan
-- MVar
-- QSem
-- QSemN
-- DataType
-- Dynamic
-- IORef
-- TypeRep
-- TyCon
-- TypeRepKey
-- KProxy -- not abstract, but intended for kind-level use
-- STRef
-- Unique
-- ForeignPtr
-- CFile
-- CFpos
-- CJmpBuf
-- Pool
-- Ptr
-- FunPtr
-- IntPtr
-- WordPtr
-- StablePtr
-- Char
-- Double
-- Float
-- Int
-- Int8
-- Int16
-- Int32
-- Int64
-- Word
-- Word8
-- Word16
-- Word32
-- Word64
-- IO
-- ST
-- (->)
-- RealWorld
-- Handle
-- HandlePosn
-- TextEncoding
-- StableName
-- Weak
-- ReadP
-- ReadPrec
--
-- Datatypes we cannot currently handle:
--
-- SomeException
-- SomeAsyncException
-- Handler
-- Coercion
-- (:~:)


{- |
Module      :  Coalpit.Core
Description :  Core Coalpit definitions
Maintainer  :  defanor <defanor@uberspace.net>
Stability   :  unstable
Portability :  non-portable (uses GHC extensions)

The 'Coalpit' class with instances, a few functions to work with it,
and 'Options' are defined here.
-}

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Coalpit.Core ( Coalpit(..)
                    , fromArgs
                    -- * Usage
                    , Usage(..)
                    , usage
                    , usageString
                    -- * Options
                    , Options(..)
                    , defOpt
                    ) where

import GHC.Generics
import Text.Megaparsec
import Text.Megaparsec.Char
import Data.Char (toLower)
import Data.Proxy (Proxy(..))
import qualified Data.List.NonEmpty as NE
import Data.Word (Word8, Word16, Word32, Word64)
import Numeric.Natural (Natural)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Time.Clock (DiffTime, NominalDiffTime, UniversalTime, UTCTime)
import Data.Time.Format ( TimeLocale, formatTime
                        , iso8601DateFormat, defaultTimeLocale)
import Data.Time.Calendar (Day)
import Data.Time.LocalTime (TimeOfDay, LocalTime, ZonedTime)
import Data.Scientific (Scientific, FPFormat(..), formatScientific, scientificP)
import Text.ParserCombinators.ReadP (readP_to_S)
import Data.Complex (Complex)
import Data.Version (Version, parseVersion, showVersion)
import System.Exit (ExitCode)
import Network.URI (URI, parseURIReference, uriToString)

import Coalpit.Parsing

-- | Usage description: can be translated into help messages or
-- documentation formats.
data Usage = UConstructor String
           -- ^ Data constructor.
           | URecursive String
           -- ^ Constructor of a recursive data structure (its second
           -- appearance in the tree).
           | USelector String Usage
           -- ^ Record selector.
           | UOptional Usage
           -- ^ Optional element.
           | USum Usage Usage
           -- ^ Sum.
           | UProduct Usage Usage
           -- ^ Product.
           | UUnit
           -- ^ Unit.
           | UType String
           -- ^ Type name, e.g. \"INT\".
           deriving (Show)

-- | Printing and parsing options.
data Options = Options { fieldSeparator :: Char
                       -- ^ DSV field separator ('showDSV',
                       -- 'readDSV').
                       , conNameMod :: String -> String
                       -- ^ Constructor name modifier.
                       , selNameMod :: String -> String
                       -- ^ Record selector name modifier.
                       , alwaysUseSelName :: Bool
                       -- ^ Add record selector name always, not just
                       -- for optional arguments.
                       , omitNamedOptions :: Bool
                       -- ^ Omit named Maybe values to indicate
                       -- 'Nothing'.
                       , timeLocale :: TimeLocale
                       , dateFormat :: String
                       -- ^ See "Data.Time.Format".
                       , timeFormat :: String
                       , dateTimeFormat :: String
                       , scientificFormat :: FPFormat
                       , scientificDecimals :: Maybe Int
                       , uriUserInfo :: String -> String
                       -- ^ Used to map userinfo parts of URIs.
                       }

-- | Default options.
defOpt :: Options
defOpt = Options ' ' (map toLower) (("--" ++) . map toLower) False True
  defaultTimeLocale (iso8601DateFormat Nothing) "%H:%M:%S"
  (iso8601DateFormat (Just "%H:%M:%S")) Generic Nothing id

-- | Parses arguments.
fromArgs :: Coalpit a => Options -> [String] -> Either String a
fromArgs opt args = case parse (argParser opt) "arguments" (map CLArg args) of
  Left err -> Left $ parseErrorPretty err
  Right x -> Right x

-- | Composes 'Usage' description.
usage :: Coalpit a => Options -> Proxy a -> Usage
usage opt = argHelper opt []

-- | Composes a usage string.
usageString :: Coalpit a => Options -> Proxy a -> String
usageString opt = usageToString . usage opt

-- | Translates 'Usage' into a string, used by 'usageString'.
usageToString :: Usage -> String
usageToString (UConstructor c) = c
usageToString (URecursive c) = c ++ "..."
usageToString (USelector s u) = s ++ " " ++ usageToString u
usageToString (UOptional u) = "[" ++ usageToString u ++ "]"
usageToString (USum ul ur) = concat [ "("
                                    , usageToString ul
                                    , " | "
                                    , usageToString ur
                                    , ")"]
usageToString (UProduct u1 UUnit) = usageToString u1
usageToString (UProduct u1 u2) = usageToString u1 ++ " " ++ usageToString u2
usageToString UUnit = ""
usageToString (UType t) = t

-- | Coalpit class: parsing, printing, usage strings.
class Coalpit a where
  argParser :: Options -> Parser a
  default argParser :: (Generic a, GCoalpit (Rep a)) => Options -> Parser a
  argParser opt = to <$> gArgParser opt

  toArgs :: Options -> a -> [String]
  default toArgs :: (Generic a, GCoalpit (Rep a)) => Options -> a -> [String]
  toArgs opt a = gToArgs opt (from a)

  argHelper :: Options -> [String] -> Proxy a -> Usage
  default argHelper :: (GCoalpit (Rep a))
                    => Options -> [String] -> Proxy a -> Usage
  argHelper opt path Proxy = gArgHelper opt path (Proxy :: Proxy (Rep a p))

class GCoalpit a where
  gArgParser :: Options -> Parser (a p)
  gToArgs :: Options -> a p -> [String]
  gArgHelper :: Options -> [String] -> Proxy (a p) -> Usage

-- Units
instance GCoalpit U1 where
  gArgParser _ = pure U1
  gToArgs _ U1 = []
  gArgHelper _ _ (Proxy :: Proxy (U1 f)) = UUnit

-- Products
instance (GCoalpit a, GCoalpit b) => GCoalpit (a :*: b) where
  gArgParser opt = (:*:) <$> gArgParser opt <*> gArgParser opt
  gToArgs opt (x :*: y) = gToArgs opt x ++ gToArgs opt y
  gArgHelper opt path (Proxy :: Proxy ((a :*: b) p)) =
    UProduct (gArgHelper opt path (Proxy :: Proxy (a p)))
    (gArgHelper opt path (Proxy :: Proxy (b p)))

-- Sums

-- | Handles recursive constructors.
handleRecCon :: GCoalpit a
             => String
             -- ^ Constructor name
             -> Options
             -> [String]
             -> Proxy (a p)
             -> Usage
handleRecCon nameA opt path (Proxy :: Proxy (a p)) =
  let n = conNameMod opt nameA
  in if nameA `elem` path
     then URecursive n
     else UProduct (UConstructor n)
          (gArgHelper opt (nameA : path) (Proxy :: Proxy (a p)))

instance (Constructor conA, GCoalpit a, GCoalpit (b :+: c)) =>
  GCoalpit ((b :+: c) :+: C1 conA a) where
  gArgParser opt =
    L1 <$> gArgParser opt
    <|>
    R1 <$> (pS (string (conNameMod opt $ conName (undefined :: C1 conA a p)))
            *> gArgParser opt)
  gToArgs opt (L1 x) = gToArgs opt x
  gToArgs opt (R1 x) = conNameMod opt (conName x) : gToArgs opt x
  gArgHelper opt path (Proxy :: Proxy (((b :+: c) :+: C1 conA a) p)) =
    let nameA = conName (undefined :: C1 conA f p)
    in USum (gArgHelper opt path (Proxy :: Proxy ((b :+: c) p)))
       (handleRecCon nameA opt path (Proxy :: Proxy (a p)))

instance (Constructor conA, GCoalpit a, GCoalpit (b :+: c)) =>
  GCoalpit (C1 conA a :+: (b :+: c)) where
  gArgParser opt =
    L1 <$> (pS (string (conNameMod opt $ conName (undefined :: C1 conA a p)))
            *> gArgParser opt)
    <|>
    R1 <$> gArgParser opt
  gToArgs opt (L1 x) = conNameMod opt (conName x) : gToArgs opt x
  gToArgs opt (R1 x) = gToArgs opt x
  gArgHelper opt path (Proxy :: Proxy ((C1 conA a :+: (b :+: c)) p)) =
    let nameA = conName (undefined :: C1 conA a p)
    in USum (handleRecCon nameA opt path (Proxy :: Proxy (a p)))
       (gArgHelper opt path (Proxy :: Proxy ((b :+: c) p)))

instance (Constructor conA, Constructor conB, GCoalpit a, GCoalpit b) =>
  GCoalpit (C1 conA a :+: C1 conB b) where
  gArgParser opt =
    L1 <$> (pS (string (conNameMod opt $
                        conName (undefined :: C1 conA a p)))
            *> gArgParser opt)
    <|>
    R1 <$> (pS (string (conNameMod opt $
                        conName (undefined :: C1 conB b p)))
            *> gArgParser opt)
  gToArgs opt (L1 x) = conNameMod opt (conName x) : gToArgs opt x
  gToArgs opt (R1 x) = conNameMod opt (conName x) : gToArgs opt x
  gArgHelper opt path (Proxy :: Proxy ((C1 conA a :+: C1 conB b) p)) =
    let nameA = conName (undefined :: C1 conA a p)
        nameB = conName (undefined :: C1 conB b p)
    in USum (handleRecCon nameA opt path (Proxy :: Proxy (a p)))
       (handleRecCon nameB opt path (Proxy :: Proxy (b p)))

instance {-# OVERLAPPABLE #-}
  (GCoalpit a, GCoalpit b) => GCoalpit (a :+: b) where
  gArgParser opt =
    L1 <$> gArgParser opt
    <|>
    R1 <$> gArgParser opt
  gToArgs opt (L1 x) = gToArgs opt x
  gToArgs opt (R1 x) = gToArgs opt x
  gArgHelper opt path (Proxy :: Proxy ((a :+: b) p)) =
    -- let nameA = conName (undefined :: a p)
    -- in
      USum (gArgHelper opt path (Proxy :: Proxy (a p)))
       (gArgHelper opt path (Proxy :: Proxy (b p)))

-- Record Selectors

parseS1 :: (GCoalpit a) => String -> Options -> Parser (S1 selA a p)
parseS1 nameA opt =
  let sName = case (nameA, alwaysUseSelName opt) of
        ("", _) -> pure ()
        (_, False) -> pure ()
        (_, True) -> pS (string (selNameMod opt nameA)) >> pure ()
  in M1 <$> (sName *> gArgParser opt)

printS1 :: (GCoalpit a, Selector selA) => Options -> S1 selA a p -> [String]
printS1 opt sel@(M1 x) = case (selName sel, alwaysUseSelName opt) of
                           ("", _) -> gToArgs opt x
                           (_, False) -> gToArgs opt x
                           (name, True) -> selNameMod opt name : gToArgs opt x

helpS1 :: (GCoalpit a)
       => String -> Options -> [String] -> Proxy (S1 selA a p) -> Usage
helpS1 nameA opt path (Proxy :: Proxy (S1 selA a p)) =
  case (nameA, alwaysUseSelName opt) of
    ("", _) -> gArgHelper opt path (Proxy :: Proxy (a p))
    (_, False) -> gArgHelper opt path (Proxy :: Proxy (a p))
    (_, True) -> USelector (selNameMod opt nameA)
      (gArgHelper opt path (Proxy :: Proxy (a p)))

instance (GCoalpit a, Selector selA) => GCoalpit (S1 selA a) where
  gArgParser = parseS1 (selName (undefined :: S1 selA a p))
  gToArgs = printS1
  gArgHelper = helpS1 (selName (undefined :: S1 selA a p))

-- Optional arguments
instance {-#OVERLAPPING#-}
  (Coalpit a, Coalpit (Maybe a), Selector selA) =>
  GCoalpit (S1 selA (Rec0 (Maybe a))) where
  gArgParser opt =
    let nameA = selName (undefined :: S1 selA (Rec0 (Maybe a)) p)
    in case (omitNamedOptions opt, null nameA) of
      (True, True) -> M1 <$> gArgParser opt
      (True, False) ->
        M1 . K1
        <$> optional (pS (string (selNameMod opt nameA)) *> argParser opt)
      _ -> parseS1 nameA opt
  gToArgs opt sel@(M1 (K1 x))
    | omitNamedOptions opt = case (selName sel, x) of
        ("", _) -> toArgs opt x
        (_, Nothing) -> []
        (nameA, Just x') -> selNameMod opt nameA : toArgs opt x'
    | otherwise = printS1 opt sel
  gArgHelper opt path (Proxy :: Proxy (S1 selA (Rec0 (Maybe a)) p)) =
    let nameA = selName (undefined :: S1 selA (Rec0 (Maybe a)) p)
    in case (omitNamedOptions opt, null nameA) of
      (True, True) -> gArgHelper opt path (Proxy :: Proxy (Rec0 (Maybe a) p))
      (True, False) -> UOptional $ USelector (selNameMod opt nameA)
                       (gArgHelper opt path (Proxy :: Proxy (Rec0 a p)))
      _ -> helpS1 nameA opt path (Proxy :: Proxy (S1 selA (Rec0 (Maybe a)) p))

-- Constructors

instance (GCoalpit a) => GCoalpit (C1 conA a) where
  gArgParser = fmap M1 . gArgParser
  gToArgs opt (M1 x) = gToArgs opt x
  gArgHelper opt path (Proxy :: Proxy (C1 conA a p)) =
    gArgHelper opt path (Proxy :: Proxy (a p))

-- Data types
instance (GCoalpit a) => GCoalpit (D1 conA a) where
  gArgParser = fmap M1 . gArgParser
  gToArgs opt (M1 x) = gToArgs opt x
  gArgHelper opt path (Proxy :: Proxy (D1 conA a p)) =
    gArgHelper opt path (Proxy :: Proxy (a p))

-- Constraints and such
instance (Coalpit a) => GCoalpit (K1 i a) where
  gArgParser = fmap K1 . argParser
  gToArgs opt (K1 x) = toArgs opt x
  gArgHelper opt path (Proxy :: Proxy (K1 x a p)) =
    argHelper opt path (Proxy :: Proxy a)

-- Common types

instance Coalpit Int where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "INT"

instance Coalpit Integer where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "INTEGER"

instance Coalpit Word8 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "WORD8"

instance Coalpit Word16 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "WORD16"

instance Coalpit Word32 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "WORD32"

instance Coalpit Word64 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "WORD64"

instance Coalpit Int8 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "INT8"

instance Coalpit Int16 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "INT16"

instance Coalpit Int32 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "INT32"

instance Coalpit Int64 where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "INT64"

instance Coalpit Natural where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "NATURAL"

instance Coalpit Rational where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "RATIONAL"

instance Coalpit Double where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "DOUBLE"

instance Coalpit Float where
  argParser _ = readArg
  toArgs _ i = [show i]
  argHelper _ _ _ = UType "FLOAT"

instance Coalpit Char where
  argParser _ = readArg
  toArgs _ c = [show c]
  argHelper _ _ _ = UType "CHAR"

instance {-#OVERLAPPING#-} Coalpit String where
  argParser _ = token (Right . unArg) Nothing
  toArgs _ i = [i]
  argHelper _ _ _ = UType "STRING"

instance Coalpit Scientific where
  argParser _ = try $ do
    x <- token (Right . unArg) Nothing
    case reverse $ readP_to_S scientificP x of
      (n, ""):_ -> pure n
      _ -> fail $ "Failed to read a scientific number: " ++ x
  toArgs opt n = [formatScientific
                  (scientificFormat opt) (scientificDecimals opt) n]
  argHelper _ _ _ = UType "SCIENTIFIC"

instance Coalpit Version where
  argParser _ = try $ do
    x <- token (Right . unArg) Nothing
    case reverse $ readP_to_S parseVersion x of
      (v, ""):_ -> pure v
      _ -> fail $ "Failed to read a version: " ++ x
  toArgs _ v = [showVersion v]
  argHelper _ _ _ = UType "VERSION"

-- | An URI reference (absolute or relative).
instance Coalpit URI where
  argParser _ = try $ do
    x <- token (Right . unArg) Nothing
    maybe (fail $ "Failed to parse URI: " ++ x) pure (parseURIReference x)
  toArgs opt u = [uriToString (uriUserInfo opt) u ""]
  argHelper _ _ _ = UType "URI"

-- | Uses 'dateTimeFormat'.
instance Coalpit UTCTime where
  argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)
  toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]
  argHelper _ _ _ = UType "UTC_TIME"

-- | Uses 'dateTimeFormat'.
instance Coalpit ZonedTime where
  argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)
  toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]
  argHelper _ _ _ = UType "ZONED_TIME"

-- | Uses 'dateTimeFormat'.
instance Coalpit LocalTime where
  argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)
  toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]
  argHelper _ _ _ = UType "LOCAL_TIME"

-- | Uses 'dateTimeFormat'.
instance Coalpit UniversalTime where
  argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)
  toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]
  argHelper _ _ _ = UType "UNIVERSAL_TIME"

-- | Uses 'timeFormat'.
instance Coalpit TimeOfDay where
  argParser opt = pTime (timeLocale opt) (timeFormat opt)
  toArgs opt t = [formatTime (timeLocale opt) (timeFormat opt) t]
  argHelper _ _ _ = UType "TIME_OF_DAY"

-- | Uses 'dateFormat'.
instance Coalpit Day where
  argParser opt = pTime (timeLocale opt) (dateFormat opt)
  toArgs opt t = [formatTime (timeLocale opt) (dateFormat opt) t]
  argHelper _ _ _ = UType "DAY"

-- | Converts to/from 'Scientific'.
instance Coalpit NominalDiffTime where
  argParser opt = fromRational . toRational
                  <$> (argParser opt :: Parser Scientific)
  toArgs opt = toArgs opt .
    (fromRational . toRational :: NominalDiffTime -> Scientific)
  argHelper _ _ _ = UType "NOMINAL_DIFF_TIME"

-- | Converts to/from 'Scientific'.
instance Coalpit DiffTime where
  argParser opt = fromRational . toRational
                  <$> (argParser opt :: Parser Scientific)
  toArgs opt = toArgs opt .
    (fromRational . toRational :: DiffTime -> Scientific)
  argHelper _ _ _ = UType "DIFF_TIME"

instance Coalpit ()
instance Coalpit Bool
instance Coalpit Ordering
instance Coalpit ExitCode
instance Coalpit a => Coalpit (Complex a)
instance Coalpit a => Coalpit (Maybe a)
instance Coalpit a => Coalpit [a]
instance Coalpit a => Coalpit (NE.NonEmpty a)
instance (Coalpit a, Coalpit b) => Coalpit (Either a b)
instance (Coalpit a, Coalpit b) => Coalpit (a, b)
instance (Coalpit a, Coalpit b, Coalpit c) => Coalpit (a, b, c)
instance (Coalpit a, Coalpit b, Coalpit c, Coalpit d) => Coalpit (a, b, c, d)