multirec-alt-deriver-0.1.3: 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
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((<$>))

askConstructorNameModifier :: RQ (String -> String -> String)
askConstructorNameModifier = asks (constructorNameModifier . derivOptions)

askVerbose ::  RQ Bool
askVerbose = asks (verbose . derivOptions)

askSumMode :: RQ SumMode
askSumMode = asks (sumMode . derivOptions)


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

data Env = Env {
    derivOptions :: DerivOptions,
    familyTypesMap :: Map AppliedTyCon String
}
      
type RQ = ReaderT Env Q

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

foreachTypeNumbered :: (Int -> Int -> (AppliedTyCon,String) -> RQ a) -> RQ [a]
foreachTypeNumbered f = do
  ns <- toList <$> asks familyTypesMap
  zipWithM (f (length ns)) [0..] ns  
           
                 

runRQ :: RQ a -> DerivOptions -> 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
        ftm = fromListWithKey collision ft''

    runReaderT x Env { derivOptions = opts, familyTypesMap = ftm } 
 where
    collision :: AppliedTyCon -> String -> String -> a
    collision k a b = error ("collision : "
                            ++ "\n    key = "++pprintUnqual k
                            ++ "\n    values = "++show(a,b)
                            )