{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-} -- for Reifies constraints in instances
module Voting.Protocol.Version where

import Control.Applicative (Applicative(..), Alternative(..))
import Control.DeepSeq (NFData)
import Control.Monad (Monad(..))
import Data.Aeson (ToJSON(..), FromJSON(..))
import Data.Bool
import Data.Eq (Eq(..))
import Data.Function (($), (.), id)
import Data.Functor ((<$>), (<$))
import Data.Maybe (Maybe(..), fromJust)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Reflection (Reifies(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import GHC.Generics (Generic)
import GHC.TypeLits (Nat, Symbol, natVal, symbolVal, KnownNat, KnownSymbol)
import Numeric.Natural (Natural)
import Prelude (fromIntegral)
import Text.Show (Show(..), showChar, showString, shows)
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Text.ParserCombinators.ReadP as Read
import qualified Text.Read as Read

import Voting.Protocol.Utils

-- * Type 'Version'
-- | Version of the Helios-C protocol.
data Version = Version
 { version_branch :: [Natural]
 , version_tags   :: [(Text, Natural)]
 } deriving (Eq,Ord,Generic,NFData)
instance IsString Version where
	fromString = fromJust . readVersion
instance Show Version where
	showsPrec _p Version{..} =
		List.foldr (.) id
		 (List.intersperse (showChar '.') $
			shows <$> version_branch) .
		List.foldr (.) id
		 ((\(t,n) -> showChar '-' . showString (Text.unpack t) .
			if n > 0 then shows n else id)
		 <$> version_tags)
instance ToJSON Version where
	toJSON     = toJSON     . show
	toEncoding = toEncoding . show
instance FromJSON Version where
	parseJSON (JSON.String s)
	 | Just v <- readVersion (Text.unpack s)
	 = return v
	parseJSON json = JSON.typeMismatch "Version" json

hasVersionTag :: Version -> Text -> Bool
hasVersionTag v tag = List.any (\(t,_n) -> t == tag) (version_tags v)

-- ** Type 'ExperimentalVersion'
type ExperimentalVersion = V [1,6] '[ '(VersionTagQuicker,0)]
experimentalVersion :: Version
experimentalVersion = stableVersion{version_tags = [(versionTagQuicker,0)]}

-- ** Type 'StableVersion'
type StableVersion = V [1,6] '[]
stableVersion :: Version
stableVersion = "1.6"

-- ** Type 'VersionTagQuicker'
type VersionTagQuicker = "quicker"
versionTagQuicker :: Text
versionTagQuicker = "quicker"

readVersion :: String -> Maybe Version
readVersion = parseReadP $ do
	version_branch <- Read.sepBy1
	 (Read.read <$> Read.munch1 Char.isDigit)
	 (Read.char '.')
	version_tags <- Read.many $ (,)
		 <$> (Text.pack <$ Read.char '-' <*> Read.munch1 Char.isAlpha)
		 <*> (Read.read <$> Read.munch1 Char.isDigit <|> return 0)
	return Version{..}

-- ** Type 'V'
-- | Type-level representation of a specific 'Version'.
data V (branch::[Nat]) (tags::[(Symbol,Nat)])
-- | Like a normal 'reflect' but this one takes
-- its 'Version' from a type-level 'V'ersion
-- instead of a term-level 'Version'.
instance (VersionBranchVal branch, VersionTagsVal tags) => Reifies (V branch tags) Version where
	reflect _ = Version
	 { version_branch = versionBranchVal (Proxy @branch)
	 , version_tags   = versionTagsVal (Proxy @tags)
	 }

-- *** Class 'VersionBranchVal'
class VersionBranchVal a where
	versionBranchVal :: proxy a -> [Natural]
instance KnownNat h => VersionBranchVal '[h] where
	versionBranchVal _ = [fromIntegral (natVal (Proxy @h))]
instance
 ( KnownNat h
 , KnownNat hh
 , VersionBranchVal (hh ':t)
 ) => VersionBranchVal (h ': hh ': t) where
	versionBranchVal _ =
		fromIntegral (natVal (Proxy @h)) :
		versionBranchVal (Proxy @(hh ':t))

-- *** Class 'VersionTagsVal'
class VersionTagsVal a where
	versionTagsVal :: proxy a -> [(Text,Natural)]
instance VersionTagsVal '[] where
	versionTagsVal _ = []
instance
 ( KnownSymbol s
 , KnownNat n
 , VersionTagsVal t
 ) => VersionTagsVal ('(s,n) ': t) where
	versionTagsVal _ =
		( Text.pack (symbolVal (Proxy @s))
		, fromIntegral (natVal (Proxy @n))
		) : versionTagsVal (Proxy :: Proxy t)