{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances    #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- MShow instances for the Haskell-Src-Exts datatypes
--
-----------------------------------------------------------------------------
module WinDll.Structs.MShow.HaskellSrcExts(isList, isFun) where

import WinDll.Structs.MShow.MShow
import WinDll.Structs.Folds.HaskellSrcExts
import WinDll.Structs.Types
import WinDll.Utils.KnownTypes
-- import WinDll.Utils.Types

import qualified Language.Haskell.Exts as Exts
import qualified Language.Haskell.Exts.SrcLoc as Span
import Language.Haskell.Exts.Pretty

import Data.List

import qualified Debug.Trace as D

instance MShow Exts.Name where
    mshow (Exts.Ident  s) = s
    mshow (Exts.Symbol s) = s
    
instance MShow Exts.QName where
    mshow (Exts.Qual (Exts.ModuleName a)  b) = a ++ "." ++ mshow b
    mshow (Exts.UnQual                    a) = mshow a
    mshow (Exts.Special                   a) = mshow a
    
instance MShow Exts.SpecialCon where
    mshow Exts.UnitCon          = "()"
    mshow Exts.ListCon          = "[]"
    mshow Exts.FunCon           = "->"
    mshow (Exts.TupleCon b a)   = []
    mshow Exts.Cons             = "(:)"
    mshow Exts.UnboxedSingleCon = "()"
    
instance MShow Exts.Boxed where
    mshow Exts.Boxed   = "#"
    mshow Exts.Unboxed = ""
    
instance MShow NamedTypes where
    mshow [] = []
    mshow x  = "{" ++ comma (map (\(a,b)->a++"::"++mshow b) x) ++ "}"
     where comma = foldl1 (\a b->a++", "++b)
     
instance MShow AnnNamedTypes where
    mshow = mshow . map (\x->(antName x, antType x))
    
instance MShow Exts.Type where
    mshow = foldType (const . const id
                     ,(\a b->a++" -> "++b)
                     ,(\a b->showTuple a b mshow)
                     ,(\a->"(Ptr ("++a++"))")
                     ,(\a b->"(" ++ a ++ " " ++ b ++ ")")
                     ,mshow
                     ,mshow
                     ,(\a->"("++a++")")
                     ,(\a c b->a++" "++mshow c++" "++b)
                     ,const
                     )
                     
    mshowM 0 = mshow
    -- Incomplete, used to translate HS to C
    mshowM 1  = foldType (const . const id
                     ,(\a b->a++" -> "++b)
                     ,(\_ b->"Tuple"++show (length b)++"_t*")
                     ,(\a->a++"*")
                     ,(\a b->a) -- ++"_t*")
                     ,mshow
                     ,mshow
                     ,id -- (\a->"("++a++")") -- C types can't have braces around them
                     ,(\a c b->a++" "++mshow c++" "++b)
                     ,const
                     )
                     
    mshowM 2  = prettyPrint
    
    mshowM 3  = fold True
        where -- I'm adding the functionality of generating a count field in the show function.
              -- I don't really want to modify the original function signature. Also
              -- In the case that the function itself returns a list, we need a foreign pointer
              -- So we can write that information back to the host.
          fold f (Exts.TyForall a b c) = (const . const id) a b (fold f c)
          fold f (Exts.TyFun      a b) = (fold f a) ++" -> "++ (fold f b)
          fold f t@(Exts.TyTuple  a b) = case f of
                                            True  -> showTuple a b (fold f)
                                            False -> prettyPrint t
          fold f t@(Exts.TyList     a) = case f of
                                            True  -> "(Ptr ("++ (fold f a) ++ "))"
                                            False -> prettyPrint t
          fold f (Exts.TyApp      a b) = let name = (fold True a)
                                         in case name of 
                                              "IO" -> name ++ " (" ++ fold f b ++ ")"
                                              _    -> name ++ " " ++ fold False b
          fold f (Exts.TyVar        a) = mshow a
          fold f (Exts.TyCon        a) = mshow a
          fold f (Exts.TyParen      a) = "(" ++ (fold f a) ++ ")"
          fold f (Exts.TyInfix  a b c) = (fold f a) ++ " " ++ mshow  b ++ " " ++ (fold f c)
          fold f (Exts.TyKind     a b) = const (fold f a) b

    mshowM 4 = fold True
        where
          fold f (Exts.TyForall a b c) = (const . const id) a b (fold f c)
          fold f (Exts.TyFun      a b) = (fold f a) ++" -> "++ (fold f b)
          fold f t@(Exts.TyTuple  a b) = case f of
                                            True  -> showTuple a b (fold f)
                                            False -> prettyPrint t
          fold f t@(Exts.TyList     a) = case f of
                                            True  -> "(Ptr ("++ (fold (isPrime a) a) ++ "))"
                                            False -> prettyPrint t
          fold f (Exts.TyApp      a b) = let name = (fold True a)
                                         in case name of 
                                              "IO" ->        name ++ " (" ++ fold f b     ++ ")"
                                              _    | isPrime a || "Ptr" `isSuffixOf` name
                                                               -> "(" ++ name ++ " "  ++ fold (not $ isList b)  b ++ ")"
                                                   | otherwise -> "(" ++ name ++ " "  ++ fold True b ++ ")"
          fold f (Exts.TyVar        a) = mshow a
          fold f (Exts.TyCon        a) = case f of
                                           True  -> mshow a
                                           False -> "(Ptr " ++ mshow a ++ ")"
          fold f (Exts.TyParen      a) = "(" ++ (fold f a) ++ ")"
          fold f (Exts.TyInfix  a b c) = (fold f a) ++ " " ++ mshow  b ++ " " ++ (fold f c)
          fold f (Exts.TyKind     a b) = const (fold f a) b


-- | Checks to see if the given type is a list. Also checks in Parens
isList :: Type -> Bool
isList (Exts.TyList  _) = True
isList (Exts.TyParen a) = isList a
isList _                = False

-- | Checks to see if the given type is a constructor. Also checks in Parens
isCon :: Type -> Bool
isCon (Exts.TyCon   _) = True
isCon (Exts.TyParen a) = isCon a
isCon _                = False

-- | checks to see if a type is part of the known list of primitives
isPrime :: Type -> Bool
isPrime ty = if isCon ty
                then (take ty) `elem` knownPrimitives
                else False
  where take :: Type -> TypeName
        take (Exts.TyParen a) = take a
        take x                = prettyPrint x

-- | Checks to see if the given type is a function. Also checks in Parens
isFun :: Type -> Bool
isFun (Exts.TyFun _  _) = True
isFun (Exts.TyParen  a) = isFun a
isFun _                 = False
          
-- | A template code to show tuple
showTuple _ b f = case len > 1 of
                    True  -> "(Tuple"++show len++"Ptr " ++ unwords (map (adjust.f) b) ++ ")"
                    False -> "(" ++ unwords (map (adjust.f) b) ++ ")"
    where adjust a = showParen (' ' `elem` a) (a++) ""
          len = length b