module Type.Spine.Kinds where
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Control.Monad ((<=<), liftM)
import qualified Control.Arrow as Arrow
parameterKinds :: [Kind]
parameterKinds =
[StarK, ArrowK StarK StarK, ArrowK StarK (ArrowK StarK StarK)]
maxParameters = 5 :: Int
allKinds = [ k | n <- [0..maxParameters], k <- generateK parameterKinds n ]
badParseK s = fail $ "Data.Proxy.TH.Aux could not parse: " ++ s
parseK_ :: Monad m => String -> m Kind
parseK_ s = parseK s >>= \(k, s) -> case trim s of
"" -> return k
_ -> badParseK s
trim = dropWhile (==' ')
parseK :: Monad m => String -> m (Kind, String)
parseK s = w s where
bad = badParseK s
w s = w1 s >>= \p@(k, s) -> case trim s of
'-' : '>' : s -> Arrow.first (ArrowK k) `liftM` w s
_ -> return p
w1 (' ' : s) = w1 s
w1 ('(' : s) = w s >>= \(k, s) -> case trim s of
')' : s -> return (k, s)
_ -> bad
w1 ('*' : s) = return (StarK, s)
w1 _ = bad
stringK = w where
w StarK = "S"
w (ArrowK k1 k2) = 'T' : w k1 ++ w k2
nameK = mkName . ('K' :) . stringK where
typeK = conT . nameK
declareK k = do
let n = nameK k
let dec = DataD [] n [KindedTV (mkName "t") k] [] []
i <- recover (return Nothing) $ Just `fmap` reify n
case i of
Nothing -> return [dec]
Just (TyConI (DataD [] _ [PlainTV _] [] [])) | StarK == k -> return []
Just (TyConI (DataD [] _ [KindedTV _ ((== k) -> True)] [] [])) -> return []
_ -> fail $ "Data.Proxy.TH.Aux: " ++ show n ++ " is already declared (and not equivalently)"
qK :: QuasiQuoter
qK = QuasiQuoter (error "Type.Spine.Kinds.qK Exp")
(error "Type.Spine.Kinds.qK Pat")
(typeK <=< parseK_) (declareK <=< parseK_)
generateK pks 0 = [StarK]
generateK pks n = concatMap (\k ->
(map (flip ArrowK k) pks)) (generateK pks (n 1))
forallAppsK :: (Kind -> Kind -> Q a) -> Q [a]
forallAppsK w = mapM (uncurry w) [ (ak, k)
| n <- [0..maxParameters 1], k <- generateK parameterKinds n,
ak <- parameterKinds]