multirec-alt-deriver-0.1.1: MonadRQ.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs           #-}
{-# LANGUAGE KindSignatures  #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MonomorphismRestriction #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS -fwarn-missing-signatures #-}



module MonadRQ
   where

import Generics.MultiRec.TH.Alt.DerivOptions(DerivOptions(verbose,
                                                          familyTypes))
import THUtils(AppliedTyCon, toAppliedTyCon, pprintUnqual)
import Control.Monad.Reader(Monad(return, fail, (>>=)),
                            Functor(..), (=<<), mapM, sequence, 
                            MonadTrans(..), when, zipWithM,
                            ReaderT(runReaderT), asks)
import Language.Haskell.TH(Q, TypeQ, Type, report, runIO)
import Data.Map(Map, fromListWithKey, toList)
import Control.Applicative((<$>))




message :: String -> RQ ()
message x = 
    do
      b <- asks verbose
      when b (liftq . runIO . putStrLn $ x ++ "\n")
           
messageReport :: String -> RQ ()
messageReport x = 
    do
      b <- asks verbose
      when b (liftq . report False $ x ++ "\n")
                  
-- checkOptions :: DerivOptions -> Q ()
-- checkOptions (DerivOptions{..}) = 
--     do
--       when (null familyTypes) (fail "empty family")
      
type RQ = ReaderT (DerivOptions (Map AppliedTyCon String)) Q

liftq :: Q a -> RQ a
liftq = lift
        
foreachType :: ((AppliedTyCon,String) -> RQ a) -> RQ [a]
foreachType f = mapM f . toList =<< asks familyTypes

foreachTypeNumbered :: (Int -> Int -> (AppliedTyCon,String) -> RQ a) -> RQ [a]
foreachTypeNumbered f = do
  ns <- toList <$> asks familyTypes
  zipWithM (f (length ns)) [0..] ns  
           
collision :: AppliedTyCon -> String -> String -> a
collision k a b = error ("collision : "
                         ++ "\n    key = "++pprintUnqual k
                         ++ "\n    values = "++show(a,b)
                        )
                 

runRQ :: RQ a -> DerivOptions [(TypeQ,String)] -> Q a
runRQ x opts = do
  ft' <- sequence
        . fmap (\(x,y) -> x >>= (\x' -> return (x',y))) 
        . familyTypes $ opts
          
          :: Q [(Type,String)]
            
  when (Prelude.null ft') (fail ("Empty family not supported."))
            
  ft'' <- mapM (\(t,s) -> do
                 t' <- toAppliedTyCon t
                 case t' of
                   Left err -> fail err
                   Right t'' -> return (t'',s))
              ft'
  
  let
      ft''' = fromListWithKey collision ft''

  runReaderT x (fmap (const ft''') opts)