{-# LANGUAGE TypeFamilies, TemplateHaskell, KindSignatures, EmptyDataDecls #-}

{- |

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

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

Declares the type wrappers (mappings @k -> *@) for 'allKinds' and then defines
functions for referencing them. Also provides a Template Haskell function for
generating the @Spine@ type instances for user-defined datatypes.

-}
module Type.Spine.Stage0 where

import Language.Haskell.TH

import Type.Spine.TH (liftNameG, tyConSignature)
import Type.Spine.Kinds (allKinds, declareK, nameK)

import Control.Monad ((<=<))


-- | The @Spine@ type family represents its argument as either a 'TypeName' or
-- an application via ':@'.
type family Spine t

-- | @TypeName@ represents an occurrence of totally unapplied type name.
data TypeName x



fmap concat $ mapM declareK allKinds

-- | @kNameG k@ returns the globally unique name (i.e. TH's @NameG@) of the
-- declared wrapper for types of kind @k@.
kNameG :: Kind -> Q Name
kNameG k = $(caseE [| k |] $ [
  let n = nameK k in
  match (let p StarK = conP 'StarK []
             p (ArrowK k1 k2) = conP 'ArrowK [p k1, p k2] in p k)
  (normalB $ [| return $(liftNameG n) |]) []
    | k <- allKinds ] ++
  [match wildP (normalB [| fail $ show k ++ " is not supported by type-kinds" |]) []])

-- | @kTypeG = conT <=< kNameG@.
kTypeG :: Kind -> Q Type
kTypeG = conT <=< kNameG




-- | @spineType n@ generates the @Spine@ instance for the type named @n@.
spineType :: Name -> Q [Dec]
spineType n = do
  (ks, k) <- tyConSignature n
  spineType_ n ks k


-- | @spineType_ n ks k@ generates the @Spine@ instance for the type named @n@
-- with parameter kind @ks@ and range kind @k@.
spineType_ :: Name -> [Kind] -> Kind -> Q [Dec]
spineType_ n ks k = do
  let kq = kTypeG $ foldr ArrowK k ks
      t = [t| $kq $(conT n) |]
  (:[]) `fmap` tySynInstD ''Spine [t] [t| TypeName $t |]