{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ExplicitForAll #-}

module Data.Radius.Attribute.TH (
  unsafeTypedNumberSetTemplate,
  ) where

import Control.Applicative ((<$>), pure)
import Data.Char (toLower)
import qualified Data.Set as Set
import Language.Haskell.TH
  (Name, nameBase, mkName, Q, Type, Exp, Dec,
   sigD, valD, varP, normalB, conE, varE, listE)

import Data.Radius.Attribute.Pair
  (TypedNumber, unsafeTypedNumber, TypedNumberSet)


varNameFromDCon :: Name -> Name
varNameFromDCon :: Name -> Name
varNameFromDCon = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
d (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase  where
  d :: String -> String
d (Char
c:String
cs)  =  Char -> Char
toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
  d  []     =  []

unsafeTypedNumberTemplate :: Maybe (Q Type) -> Q Type -> Q Exp -> Name -> Q ([Dec], Name)
unsafeTypedNumberTemplate :: Maybe (Q Type) -> Q Type -> Q Exp -> Name -> Q ([Dec], Name)
unsafeTypedNumberTemplate Maybe (Q Type)
mayVsaType Q Type
valueType Q Exp
abstConE Name
conName  = do
  let varName :: Name
varName = Name -> Name
varNameFromDCon Name
conName
  Dec
sig <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
varName (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$
         Q Type -> (Q Type -> Q Type) -> Maybe (Q Type) -> Q Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
         [t| forall a . Ord a => TypedNumber a $Q Type
valueType |]
         (\Q Type
vsaTy -> [t| TypedNumber $Q Type
vsaTy $Q Type
valueType |])
         Maybe (Q Type)
mayVsaType
  Dec
val <- Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD
         (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
varName)
         (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| unsafeTypedNumber ($Q Exp
abstConE $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName)) |])
         []
  ([Dec], Name) -> Q ([Dec], Name)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec
sig, Dec
val], Name
varName)

unsafeTypedNumberSetTemplate :: String
                             -> Maybe (Q Type)
                             -> Q Type
                             -> [(Q Exp, [Name])]
                             -> Q [Dec]
unsafeTypedNumberSetTemplate :: String -> Maybe (Q Type) -> Q Type -> [(Q Exp, [Name])] -> Q [Dec]
unsafeTypedNumberSetTemplate String
setVarStr Maybe (Q Type)
mayVsaType Q Type
valueType [(Q Exp, [Name])]
conPairs = do
  [([Dec], Name)]
decPairs <-
    [[([Dec], Name)]] -> [([Dec], Name)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[([Dec], Name)]] -> [([Dec], Name)])
-> Q [[([Dec], Name)]] -> Q [([Dec], Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q [([Dec], Name)]] -> Q [[([Dec], Name)]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
    [ (Name -> Q ([Dec], Name)) -> [Name] -> Q [([Dec], Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe (Q Type) -> Q Type -> Q Exp -> Name -> Q ([Dec], Name)
unsafeTypedNumberTemplate Maybe (Q Type)
mayVsaType Q Type
valueType Q Exp
abstConE) [Name]
conNames
    | (Q Exp
abstConE, [Name]
conNames) <- [(Q Exp, [Name])]
conPairs]

  let setVarName :: Name
setVarName = String -> Name
mkName String
setVarStr
  Dec
setSig <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
setVarName (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$
            Q Type -> (Q Type -> Q Type) -> Maybe (Q Type) -> Q Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            [t| forall a . Ord a => TypedNumberSet  a     $(Q Type
valueType) |]
            (\Q Type
vsaTy -> [t| TypedNumberSet $Q Type
vsaTy $(Q Type
valueType) |])
            Maybe (Q Type)
mayVsaType
  Dec
setVal <- Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD
            (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
setVarName)
            (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| Set.fromList $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n | ([Dec]
_, Name
n) <- [([Dec], Name)]
decPairs]) |])
            []
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
setSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
setVal Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Dec]
decs | ([Dec]
decs, Name
_) <- [([Dec], Name)]
decPairs ]