module CryptoID.TH where

import ClassyPrelude

import Language.Haskell.TH

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

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

import Data.Binary (Binary)
import qualified Data.Binary as Binary

import Database.Persist.Sql


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

          instance {-# OVERLAPPING #-} Binary $(t) where
            put = Binary.put . fromSqlKey
            putList = Binary.putList . map fromSqlKey
            get = toSqlKey <$> Binary.get

          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