{-# LANGUAGE ViewPatterns #-}

{- |

Module      :  Type.Spine.Kinds
Copyright   :  (c) The University of Kansas 2011
License     :  BSD3

Maintainer  :  nicolas.frisby@gmail.com
Stability   :  experimental
Portability :  see LANGUAGE pragmas (... GHC)

Kinds for the spine-view on types.

-}
module Type.Spine.Kinds where

import Language.Haskell.TH
import Language.Haskell.TH.Quote

import Control.Monad ((<=<), liftM)

import qualified Control.Arrow as Arrow


-- | The set of kinds that this library will initially support as type
-- parameters.
parameterKinds :: [Kind]
parameterKinds =
  [StarK, ArrowK StarK StarK, ArrowK StarK (ArrowK StarK StarK)]

-- | The default number of parameters that this library will initially support.
maxParameters = 5 :: Int

-- | The kinds consequent from @parameterKinds@ and @maxParameters@.
allKinds = [ k | n <- [0..maxParameters], k <- generateK parameterKinds n ]



-------------------- parsing kinds
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

-------------------- serializing kind as Haskell identifier
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|...|]@ is either the declaration of a type that takes one parameter
-- of the corresponding kind, or an occurrence of that type constructor. (The
-- name is an encoding of that parameter's kind based on prefix notation for
-- application.)
qK :: QuasiQuoter
qK = QuasiQuoter (error "Type.Spine.Kinds.qK Exp")
     (error "Type.Spine.Kinds.qK Pat")
     (typeK <=< parseK_) (declareK <=< parseK_)


-- | @generateK pks n@ generates all 'Kind's with @0@ to @n@ parameters taken
-- from @pks@.
generateK pks 0 = [StarK]
generateK pks n = concatMap (\k ->
  (map (flip ArrowK k) pks)) (generateK pks (n - 1))


-- | Calls its argument once for each parameter and kind pair implied by
-- @maxParameters@ and @parameterKinds@.
forallAppsK :: (Kind -> Kind -> Q a) -> Q [a]
forallAppsK w = mapM (uncurry w) [ (ak, k)
  | n <- [0..maxParameters - 1], k <- generateK parameterKinds n,
    ak <- parameterKinds]