module CryptoID.TH where

import ClassyPrelude

import Language.Haskell.TH

import Data.CryptoID.Class.ImplicitNamespace
import Data.UUID.Types (UUID)
import Data.Binary (Binary(..))
import Data.Binary.SerializationLength

import Data.CaseInsensitive (CI)
import System.FilePath (FilePath)

import Database.Persist.Sql (toSqlKey, fromSqlKey)


decCryptoIDs :: [Name] -> DecsQ
decCryptoIDs = fmap concat . mapM decCryptoID
  where
    decCryptoID :: Name -> DecsQ
    decCryptoID n@(conT -> t) = do
      instances <- [d|
          instance Binary $(t) where
            get = $(varE 'toSqlKey) <$> get
            put = put . $(varE 'fromSqlKey)
          instance HasFixedSerializationLength $(t) where
            type SerializationLength $(t) = SerializationLength Int64

          type instance CryptoIDNamespace a $(t) = $(litT $ strTyLit ns)
        |]

      synonyms <- mapM cryptoIDSyn
        [ (ConT ''UUID, "UUID")
        , (ConT ''CI `AppT` ConT ''FilePath, "FileName")
        ]

      return $ concat
        [ instances
        , synonyms
        ]
      where
        ns = (\nb -> fromMaybe nb $ stripSuffix "Id" nb) $ nameBase n
        cryptoIDSyn (ct, str) = tySynD (mkName $ "Crypto" ++ str ++ ns) [] $ conT ''CryptoID `appT` return ct `appT` t