{-# LANGUAGE TemplateHaskell #-}

----------------------------------------------------------------------
-- |
-- Module      :  Data.StarToStar.Iso.TH
-- Copyright   :  (c) Nicolas Frisby 2010
-- License     :  http://creativecommons.org/licenses/by-sa/3.0/
-- 
-- Maintainer  :  nicolas.frisby@gmail.com
-- Stability   :  experimental
-- Portability :  see LANGUAGE pragmas
-- 
-- A template haskell definition for automatically generating the instance for
-- 'Data.StarToStar.Iso.Iso'. For example:
--
-- > decl_fix "ReaderST" ["s"] [t| ReaderT (Map String ($me Int) (ST $(tvar "s")) |]
--
-- generates
--
-- @
-- newtype ReaderST s me a = ReaderST (ReaderT (Map String (me Int)) (ST s) a)
-- unReaderST (ReaderST x) = x
-- type ReaderST_inner s me = ReaderT (Map String (me Int)) (ST s)
-- @
--
-- @
-- instance Iso (Fix (ReaderST s)) where
--   type Other (Fix (ReaderST s)) = ReaderST_inner s (Fix (ReaderST s))
--   from = unReaderST . fromFix
--   to = toFix . ReaderST
-- @
----------------------------------------------------------------------

module Data.StarToStar.Iso.TH (me, tvar, decl_fix, decl_fix_kinds) where

import Language.Haskell.TH (varT)
import Language.Haskell.TH.Syntax

compose x y = InfixE (Just x) (VarE (mkName ".")) (Just y)

tvar = varT . mkName
me = tvar "me"

unTVB (PlainTV n) = VarT n
unTVB (KindedTV n k) = SigT (VarT n) k
unTVB_ (PlainTV n) = VarT n
unTVB_ (KindedTV n k) = VarT n

fix_module_name = mkName "Data.StarToStar"
fix_name = mkName (show fix_module_name ++ ".Fix")
iso_name = mkName (show fix_module_name ++ ".Iso.Iso")

decl_fix :: String -> [String] -> Q Type -> Q [Dec]
decl_fix n tvars = decl_fix_kinds n (map (PlainTV . mkName) tvars)

decl_fix_kinds :: String -> [TyVarBndr] -> Q Type -> Q [Dec]
decl_fix_kinds s tyvarbndrs inner_type = do
  inner_type <- inner_type
  let n = mkName s
      unN = mkName ("un" ++ s)
      this_type = foldl AppT (ConT n) (map unTVB tyvarbndrs)
      this_type_ = foldl AppT (ConT n) (map unTVB_ tyvarbndrs)
      tvbs = tyvarbndrs ++ [KindedTV (mkName "me") (StarK `ArrowK` StarK)]
      syn_name = mkName (s ++ "_inner")
      instance_type = ConT fix_name `AppT` this_type
      instance_type_ = ConT fix_name `AppT` this_type_
  return $
    [let hole = mkName "a"
     in NewtypeD [] n (tvbs ++ [PlainTV hole]) (NormalC n [(NotStrict, inner_type `AppT` VarT hole)]) [],
     TySynD syn_name tvbs inner_type,
     let x = mkName "x"
     in FunD unN [Clause [ConP n [VarP x]] (NormalB (VarE x)) []],
     InstanceD [] (ConT iso_name `AppT` instance_type)
       [TySynInstD (mkName "Other") [instance_type_]
                     (foldl AppT (ConT syn_name) (map unTVB_ tyvarbndrs ++ [instance_type_])),
        ValD (VarP (mkName "from")) (NormalB (compose (VarE unN) (VarE (mkName "fromFix")))) [],
        ValD (VarP (mkName "to")) (NormalB (compose (VarE (mkName "toFix")) (ConE n))) []]]