{-# LANGUAGE TemplateHaskell #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.TH.TypeLib
-- Copyright   :  (c) SAM Group, KTH/ICT/ECS 2007-2008
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  forsyde-dev@ict.kth.se
-- Stability   :  experimental
-- Portability :  portable
--
-- This module provides basic functions related to Template-Haskell's 'Type'.
--
-----------------------------------------------------------------------------
module Language.Haskell.TH.TypeLib
 (Context,
  mkContext,
  monoContext,
  isPoly,
  contextVarNames,
  contextConstraints,
  mkForallT,
  unArrowT,
  unAppT,
  (-->),
  reAppT,
  reArrowT,
  dynTHType,
  thTypeOf,
  typeRep2Type,
  tyCon2Type,
  type2TypeRep)
 where

import Data.Typeable.Internal
import Data.Dynamic
import Language.Haskell.TH (Type(..), Cxt, TyVarBndr(..), pprint, mkName, nameModule, nameBase)
import Text.Regex.Posix ((=~))
import Data.Maybe(isJust, fromMaybe)

-- Due to type translations
import Data.Word (Word, Word8, Word16, Word32, Word64)
import Data.Int (Int8, Int16, Int32, Int64)
import System.IO (Handle)
import Data.IORef (IORef)
import Foreign (Ptr, FunPtr, StablePtr, ForeignPtr)
--import Control.OldException (Exception,
--                          AsyncException,
--                          ArrayException,
--                          ArithException,
--                          IOException)
import Data.Ratio (Ratio)
import Control.Concurrent.MVar (MVar)

-----------
-- Context
-----------

-- | A 'Context' represents the forall part and constraints of a type
--   (see 'ForallT')
--  For instance, the context of the type
--  @
--  forall a b. (Show a, Show b) => (a,b)
--  @
--  is @forall a b. (Show a, Show b) =>@
--  where @a@ and @b@ are the the context variables and
--  @(Show a, Show b)@ are the context constraints
data Context = Context
                   [TyVarBndr] -- Variable names
                   Cxt         -- Constraints (the context itself)

instance Show Context where
-- FIXME: this is really ugly, refactor and improve its look
 showsPrec _ (Context tvb cxt) =
   showVars tvb . showConstraints cxt
   where showVars tvb = showForall (not (null tvb))  (showVars' tvb)
         showVars' ((PlainTV n):tvbs) = shows n . showChar ' ' . showVars' tvbs
         showVars' []   = id
         showConstraints c = (\s -> if not (null c) then ' ':s else s).
                             showParen (length c > 1) (showConstraints' c) .
                             (\s -> if not (null c) then s ++ " =>" else s)
         showConstraints' [c]    = shows c
         showConstraints' (c:cx) = showString (pprint c) . showString ", " .
                                   showConstraints' cx
         showConstraints' []    = id
         showForall b s = if b then showString "forall " . s . showChar '.'
                               else s

-- | 'Context' constructor
mkContext :: [TyVarBndr] -> Cxt -> Context
mkContext tvb c = Context tvb c

-- | Empty context for monomorphic types
monoContext :: Context
monoContext = Context [] []

-- | Tells if the context corresponds to a polymorphic type
isPoly :: Context -> Bool
isPoly (Context [] _) = False
isPoly _              = True

-- | Returns the variable names related to a context
contextVarNames :: Context -> [TyVarBndr]
contextVarNames (Context tvb _) = tvb

-- | Returns the context constraints
contextConstraints :: Context -> Cxt
contextConstraints (Context _ cxt) = cxt

-- | Builds a 'ForallT' type out of a context and a type
mkForallT :: Context -> Type -> Type
mkForallT (Context tvb cxt) t = ForallT tvb cxt t

--------------------------------
-- Functions to observe a 'Type'
--------------------------------

-- | Obtains the arguments and return type of a given 'Type'
--   (normally a function)
--   together with its 'Context' (non-empty if the type is polymorphic)
unArrowT :: Type                    -- ^ Type to observe
        ->  ([Type], Type, Context) -- ^ (args 'Type', ret 'Type', 'Context')
unArrowT (ForallT names cxt t) = let (args,ret) = unArrowT' t
                                 in (args, ret, Context names cxt)
unArrowT t = let (args,ret) = unArrowT' t
             in (args, ret, Context [] [])

-- unArrowT for non-Forall Types
unArrowT' :: Type -> ([Type], Type)
unArrowT' ((ArrowT `AppT` first) `AppT` rest) = let (args, ret) = unArrowT' rest
                                                in  (first:args, ret)
unArrowT' t = ([],t)

-- | Obtains the type constructor of a 'Type' together with its
--   arguments and its 'Context' (non-empty if the type is polymorphic)
unAppT :: Type                    -- ^ Type to observe
       -> (Type, [Type], Context) -- ^ (Constructor, args 'Type', Context)
unAppT (ForallT names cxt t) = let (cons, args)  = unAppT' t
                               in (cons, args, Context names cxt)
unAppT t = let (cons, args)  = unAppT' t
           in (cons, args, Context [] [])

-- unAppT for non-Forall Types
unAppT' :: Type -> (Type, [Type])
unAppT' t = (first,rest)
  where first:rest = unAppT'ac [] t
        -- Since the constructor is a leaf of the Type tree representation,
        -- it is the last element to be gathered and thus, an accumulator
        -- is used to reverse the list to be returned
        unAppT'ac :: [Type] -> Type -> [Type]
        unAppT'ac acum (prefix `AppT` lastarg) = unAppT'ac (lastarg:acum) prefix
        unAppT'ac acum cons                   = cons:acum
------------------------------
-- Functions to build a 'Type'
------------------------------

-- | Form a function type out of two types
(-->) :: Type -- ^ Argument type
      -> Type -- ^ Return type
      -> Type -- ^ Resulting function
arg --> ret = (ArrowT `AppT` arg) `AppT` ret

-- | Rebuild a type out of a constructor, its argument types and its context
--   (inverse of 'unAppT')
reAppT :: (Type, [Type], Context)  -- ^ (Constructor, type arguments, context)
       -> Type                     -- ^ resulting 'Type'
-- Polymorphic types
reAppT (cons, args, cxt) | isPoly cxt =
 mkForallT cxt (reAppT (cons, args, monoContext))
-- Monomorphic types
reAppT (cons, args, _) = foldl1 AppT (cons:args)

-- | Rebuild a function type out of its argument types, return type
--   and context (inverse of 'ArrowT')
reArrowT :: ([Type], Type, Context)  -- ^ (Constructor, type arguments, context)
           -> Type                   -- ^ resulting 'Type'
-- Polymorphic types
reArrowT (args, ret, cxt) | isPoly cxt =
 mkForallT cxt (reArrowT (args, ret, monoContext))
-- Monomorphic types
reArrowT (args, ret, _) = foldr1 (-->) (args ++ [ret])

-------------------------------------------------------------------
-- Transforming Language.Haskell.TH.Type into Data.Typeable.TypeRep
-------------------------------------------------------------------

-- | Translate monomorphic Template Haskell Types to TypeReps
--   If the type os polymorhpic 'Nothing' will be returned
type2TypeRep :: Type -> Maybe TypeRep
-- Note: In the case of constructors, we don't need to translate to a TyCon first
-- because:
--
-- mkTyConApp tCon [t1 .. tn] = mkTyConApp tCon [] `mkAppTy` t1 ... `mkAppTy` tn
type2TypeRep (ForallT (_:_) _ _) = Nothing
type2TypeRep (ForallT _ (_:_) _) = Nothing
type2TypeRep (ForallT _ _ t) = type2TypeRep t
type2TypeRep (VarT _) = Nothing
-- Tuple tyCon strings don't correspond to hierarchical names. They are
-- simply sequences of commas plus paranthesis: e.g. 2-tuple "(,)"   3-tuple "(,,)" ....
type2TypeRep (TupleT n) = Just $  strCon ('(':replicate (n-1) ','++")")
type2TypeRep ArrowT = Just $ typeableCon (undefined :: () -> ())
type2TypeRep ListT = Just $ typeableCon (undefined :: [()])
type2TypeRep (t1 `AppT` t2) = do
  tRep1 <- type2TypeRep t1
  tRep2 <- type2TypeRep t2
  return $ tRep1 `mkAppTy` tRep2
-- Constructors
type2TypeRep (ConT name)
  -- FIXME: This should not be needed in the newer versions of ghc:
  -- There are certain TyCons whose string does not correspond
  -- to the hierarchical name of the constructor (the instances generated
  -- in Data.Typeable), we have to cover all those cases by hand
  -- See http://hackage.haskell.org/trac/ghc/ticket/1841 for details
  | isJust mSpecialTypeRep = mSpecialTypeRep
  -- Tuples (they cannot be put in the table)
  | isTup = Just $ strCon tupCons
  -- General case
  | otherwise = Just $  strCon (show name)
 where (isTup, tupCons) =
         case (show name =~ "^Data\\.Tuple\\.\\((,+)\\)$")
               :: (String, String, String, [String]) of
            -- it's a tuple, we get the commas subpart (,+)
            (_, _, _, [commas]) -> (True, commas)
            _ -> (False, "")
       mSpecialTypeRep = lookup name specialConTable
       specialConTable =
           [(''()             , typeableCon (undefined :: ())             ),
            (''[]             , typeableCon (undefined :: [()])           ),
            (''Maybe          , typeableCon (undefined :: Maybe ())       ),
            (''Ratio          , typeableCon (undefined :: Ratio ())       ),
            (''Either         , typeableCon (undefined :: Either () ())   ),
            (''(->)           , typeableCon (undefined :: () -> ())       ),
            (''MVar           , typeableCon (undefined :: MVar ())        ),
            --(''Exception      , typeableCon (undefined :: Exception)      ),
            --(''IOException    , typeableCon (undefined :: IOException)    ),
            --(''ArithException , typeableCon (undefined :: ArithException) ),
            --(''ArrayException , typeableCon (undefined :: ArrayException) ),
            --(''AsyncException , typeableCon (undefined :: AsyncException) ),
            (''Ptr            , typeableCon (undefined :: Ptr ())         ),
            (''FunPtr         , typeableCon (undefined :: FunPtr ())      ),
            (''ForeignPtr     , typeableCon (undefined :: ForeignPtr ())  ),
            (''StablePtr      , typeableCon (undefined :: StablePtr ())   ),
            (''IORef          , typeableCon (undefined :: IORef ())       ),
            (''Bool           , typeableCon (undefined :: Bool)           ),
            (''Char           , typeableCon (undefined :: Char)           ),
            (''Float          , typeableCon (undefined :: Float)          ),
            (''Double         , typeableCon (undefined :: Double)         ),
            (''Int            , typeableCon (undefined :: Int)            ),
            (''Word           , typeableCon (undefined :: Word)           ),
            (''Integer        , typeableCon (undefined :: Integer)        ),
            (''Ordering       , typeableCon (undefined :: Ordering)       ),
            (''Handle         , typeableCon (undefined :: Handle)         ),
            (''Int8           , typeableCon (undefined :: Int8)           ),
            (''Int16          , typeableCon (undefined :: Int16)          ),
            (''Int32          , typeableCon (undefined :: Int32)          ),
            (''Int64          , typeableCon (undefined :: Int64)          ),
            (''Word8          , typeableCon (undefined :: Word8)          ),
            (''Word16         , typeableCon (undefined :: Word16)         ),
            (''Word32         , typeableCon (undefined :: Word32)         ),
            (''Word64         , typeableCon (undefined :: Word64)         ),
            (''TyCon          , typeableCon (undefined :: TyCon)          ),
            (''TypeRep        , typeableCon (undefined :: TypeRep)        )]


-------------------------------------------------------------------
-- Transforming Data.Typeable.TypeRep into Language.Haskell.TH.Type
-------------------------------------------------------------------

-- | Obtain the Template Haskel type of a dynamic object
dynTHType :: Dynamic -> Type
dynTHType = typeRep2Type . dynTypeRep

-- | Give the template haskell 'Type' of a Typeable object
thTypeOf :: Typeable a => a -> Type
thTypeOf = typeRep2Type . typeOf

-- | Translate a 'TypeRep' to a Template Haskell 'Type'
typeRep2Type :: TypeRep -> Type
typeRep2Type rep = let (con, reps) = splitTyConApp rep
  in reAppT (tyCon2Type con, map typeRep2Type reps, monoContext)

-- | Gives the corresponding Template Haskell 'Type' of a 'TyCon'
tyCon2Type :: TyCon -> Type
tyCon2Type = tyConStr2Type . tyConName


----------------------------
-- Internal Helper Functions
----------------------------

-- | transfrom a Typeable type constructor to a Template Haskell Type
tyConStr2Type :: String -> Type
-- NOTE: The tyCon strings of basic types are not qualified and buggy in
-- some cases.
-- See http://hackage.haskell.org/trac/ghc/ticket/1841
-- FIXME: update this function whenever the bug is fixed
-- FIXME FIXME: This code is incorrect:
-- mkName doesn't generate global names! ''Maybe /= mkName "Data.Maybe.Maybe"
-- in addition global names contain a packagename which cannot be guessed from
-- the type representation.
tyConStr2Type "->" = ArrowT
tyConStr2Type  tupStr | tupStr =~ "^,+$" =
 ConT (mkName $ "Data.Tuple.(" ++ tupStr ++ ")")
tyConStr2Type str  = ConT $ mkName str

-- Get the type constructor corresponding to a String
-- in form of a type representation
strCon :: String -> TypeRep
strCon str = mkTyCon3 pkg mod base `mkTyConApp` []
        where
                name = mkName str
                pkg  = ""
                mod  = fromMaybe "" (nameModule name)
                base = nameBase name


-- Get the type constructor corresponding to a typeable value
-- in form of a type representation
typeableCon :: Typeable a => a -> TypeRep
typeableCon t = (typeRepTyCon . typeOf) t `mkTyConApp` []