{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE TypeSynonymInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Structures used in WinDll
--
-----------------------------------------------------------------------------

module WinDll.Structs.Structures(module WinDll.Structs.Structures
                                ,module WinDll.Structs.Types
                                ,module WinDll.Utils.TypeFolds) where

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

import Data.Data hiding (DataType)
import Data.Typeable
import Data.Monoid
import Data.Maybe
import Data.List
import Control.Arrow

import Data.Generics hiding (DataType)

import WinDll.Structs.Folds.HaskellSrcExts
import WinDll.Structs.MShow.HaskellSrcExts
import WinDll.Structs.MShow.MShow
import WinDll.Structs.Types
import WinDll.Utils.TypeFolds

import qualified Debug.Trace as D

type DataTypes     = [DataType]
type Instances     = [Instance]
               
-- | Simplifies a a type, this basically just removes top level parents
stripTop :: Type -> Type
stripTop (Exts.TyParen a) = stripTop a
stripTop b                = b

-- | Split the type in head and tail in the cases of -> (future work, when we suppor higherorder functions) and ($) types, else just return Nothing
getHead :: Type -> Maybe TypeName
getHead (Exts.TyApp a b) = Just (head $ collectTypes a)
getHead (Exts.TyParen a) = getHead a
getHead x                = Nothing

-- | A function to select all occurences of one type with another
replaceTypes :: TypeNames -> TypeNames -> Type -> Type
replaceTypes in_ out_ = everywhere (mkT inner)
    where inner :: Exts.Name -> Exts.Name
          inner (Exts.Ident  s) = Exts.Ident (find s)
          inner (Exts.Symbol s) = Exts.Ident (find s)
          
          find s = maybe s (out_!!) (findIndex (==s) in_)
                        
-- * Datatype declarations

-- | A special type consisting of a tuple of all the comments that belong to a specific decl.
--   Basically the "matched" comments
type CommentDecl = ([String],Exts.Decl)

-- | Module export declarations.
data Export = Export { exName    :: Name       -- ^ The original name of the function to be exported
                     , exAs      :: ExportName -- ^ The name to export the function under
                     , exType    :: Type       -- ^ The modified type. (preprocessed to support lists etc)
                     , exOrgType :: Type       -- ^ The original unmodified type
                     , exModule  :: ModuleName -- ^ The definition site for the export
                     }
    deriving(Eq,Data,Typeable)
    
-- | Module header declaration. Contains the module name that was just parsed. And a list of 
--   exported function which is used to avoid compile errors if a function was marked to be 
--   exported but is not visible outside the module.
data Header = Header { headername :: Name
                     , exportname :: [ExportName]
                     }
    deriving(Eq,Data,Typeable)

-- | Datatype and Newtype declarations Tagged with some extra information
--   like the full type name. This is needed because the declarations will be 
--   processed independently of their module declarations. So this information is needed
data DataType = DataType Name [TypeName] DataTypes TypeTag
              | NewType  Name [TypeName] DataType  TypeTag
              | Constr   Name DataFixity AnnNamedTypes
    deriving(Eq,Data,Typeable)
    
-- | The fixity of the constructor
data DataFixity = Infix | Normal
    deriving(Eq,Data,Typeable)
    
-- | Determine if a datatype is a Simple type (e.g. ahs no type variables) or a datatype that needs to be specialized
isSimpleData :: DataType -> Bool
isSimpleData (DataType _ a _ _) = null a
isSimpleData (NewType  _ a _ _) = null a
isSimpleData _                  = error "isSimpleData: Cannot be called with anything other than DataType and NewType"
    
-- | TypeDecl datatype
data TypeDecL = TypeDecL { typeName :: Name       -- ^ @typeName@ The type name
                         , typeVars :: [TypeName] -- ^ @typeVars@ The free variables of the type
                         , repTypes :: Type       -- ^ @repTypes@ The type represented by this type
                         }
              | TypeDecN { typeName :: Name       -- ^ @typeName@ The type name
                         , typeVars :: [TypeName] -- ^ @typeVars@ The free variables of the type
                         , repTypes :: Type       -- ^ @repTypes@ The type represented by this type
                         }
    deriving(Show,Eq,Data,Typeable)

-- | Check if this type is a closed type. e.g. has no type variables. In which case we can do replacements
--   instead of unification (which would fail. on these types).
isClosed :: TypeDecL -> Bool
isClosed = null . typeVars

-- | A method to lift a Exts.Type to a TypeDecL
-- But since no name is defined for any arbitrary lifted type then this method
-- should generate an exception if you try to inspect the name field of this 
-- TypeDecL. As such it is set to undefined.
liftType :: Type -> TypeDecL
liftType t = TypeDecL undefined (collectTypeVars t) t
    
-- | Get the name of a datatype
getName :: DataType -> Name
getName (NewType name  _ _ _) = name
getName (DataType name _ _ _) = name
getName _                     = error "getName: Cannot be called with anything other than DataType and NewType"
   
-- | Get the types of the constructors in the datatypes that might need specialization
--   Due to a bug this sill no longer emit Applied types on Type vars
getTypes :: DataType -> [Type]
getTypes (NewType  _ _ t _) = getTypes t
getTypes (DataType _ _ t _) = concatMap getTypes t
getTypes (Constr    _  _ t) = filter hasVars $ map antType t

-- | Checks to see if this type is a TyVar           
isVar :: Type -> Bool
isVar (Exts.TyVar _) = True
isVar _              = False

-- | Checks to see if the given type has any type variables
hasVars :: Type -> Bool
hasVars = null . listify isVar

-- | Function declaration
data Function = Function { fnName     :: Name -- ^ The function name
                         , fnArity    :: Int  -- ^ The arity of the function
                         , fnType     :: Type -- ^ The preprocessed type (to support lists etc)
                         , fnAnn      :: Ann  -- ^ The accompanying function type annotations
                         , fnOrigType :: Type -- ^ The original unmodified type
                         }
    deriving(Eq,Data,Typeable)

type Opt = String

-- | A mapping for a sigle callback function, holds the definition for callback functions
data Callback = Callback{ cbName      :: Name -- ^ The name of the callback function
                        , cbOrigType  :: Type -- ^ The initial type of the function
                        , cbNewType   :: Type -- ^ The marshalable callback function.
                        , cbInputType :: Type -- ^ The unprocessed type 
                        , cbAnn       :: Ann  -- ^ Type Annotations
                        }
        deriving(Eq,Show,Data,Typeable)
        
-- | Represents a StablePtr implementation that needs to be freed.
data Stable = Stable { stName   :: Name -- ^ The user displayed name for the StablePtr
                     , stType   :: Type -- ^ The actual type of the StablePtr
                     , stModule :: ModuleName -- ^ The module that defined the StablePtr
                     }
        deriving(Eq,Show,Data,Typeable)
    
-- | Datatype to hold user defined pragmas
data Pragma = Pragma Name [Opt]
    deriving(Show,Eq,Data,Typeable)
    
-- |  complete parsed module definition. Used as the main AST for this preprocessor
data Module = Module { header    :: Header
                     , filepath  :: FilePath
                     , imports   :: [Import]
                     , exports   :: [Export]
                     , datatypes :: DataTypes
                     , functions :: [Function]
                     , instances :: Instances
                     , types     :: [TypeDecL]
                     }
    deriving(Eq,Data,Typeable)
   
instance Monoid Module where
    mempty = Module undefined [] [] [] [] [] [] []
    mappend (Module _ _ i1 e1 d1 f1 o1 t1) 
            (Module _ _ i2 e2 d2 f2 o2 t2) = Module (Header "Internal.Merged" []) [] (i1++i2) (e1++e2) (d1++d2)
                                                                                     (f1++f2) (o1++o2) (t1++t2)

-- | A datatype used originally to replace the dual constructor type of the 
--   comment format used by Haskell-src-exts. However since that was changed in 
--   the newer versions of the library, this datatructure should be refactored out.
data MyComment = MyComment Span.SrcSpan String
    deriving (Eq,Ord,Show,Data,Typeable)
        
-- | A datatype to hold instance declaration names. These are just used to check so 
--   that we don't redefine already existing instances
data Instance = Instance Types -- ^ Default constructor for only Storable classes    
              | QualifiedInstance Name Types -- ^ The rest, A fully qualified instance
    deriving(Eq,Ord,Show,Data,Typeable)
    
-- | A datatype to hold the type's fullname (including module name)
--   whether it has been evaluated by the preprocessor
--   and whether it's been resolved to a user-defined type or a Primitive type
--   To be used in the next version. 
data TypeTag = TypeTag String Bool Bool
             | NoTag
    deriving(Eq,Ord,Show,Data,Typeable)
    
-- | A simpler kind of Unification to solve type synonyms. I call it unification
--   because I can't think of another name.
unifyType :: TypeDecL -> Type -> Type
unifyType tdecl  t = 
       foldType ((\a b c->Exts.TyForall a b (rep c))
                ,(\a b  ->Exts.TyFun (rep a) (rep b))
                ,(\a b  ->Exts.TyTuple a (map rep b))
                ,Exts.TyList . rep
                ,(\a b  ->rep $ Exts.TyApp a (unifyType tdecl b))
                ,Exts.TyVar
                ,Exts.TyCon
                ,Exts.TyParen . rep
                ,(\a c b->Exts.TyInfix (rep a) c (rep b))
                ,(\a b  ->Exts.TyKind  (rep a) b)
                ) t
    where rep :: Type -> Type
          rep p = if adj True p then make p else p 

          name = typeName tdecl

          make p = let vars = typeVars tdecl
                       rigs = tail $ collectRealTypes p
                   in case length vars == length rigs of
                        False -> error $ "Panic: cannot unify type " ++ mshowM 2 p  ++ 
                                         " with type " ++ mshowM 2 (repTypes tdecl) ++
                                         " . reason: not enough type variables"
                        True  -> fillType (zip vars rigs) (repTypes tdecl)

          fillType :: [(TypeName, Type)] -> Type -> Type
          fillType lst = 
             foldType ((\a b c->Exts.TyForall a b c)
                ,(\a b->Exts.TyFun a b)
                ,(\a b->Exts.TyTuple a b)
                ,Exts.TyList
                ,(\a b->Exts.TyApp a b)
                ,(\a -> fromJust $ lookup (mshow a) lst)
                ,Exts.TyCon
                ,Exts.TyParen
                ,(\a c b->Exts.TyInfix a c b)
                ,(\a b  ->Exts.TyKind a b)
                )

          adj :: Bool -> Type -> Bool
          adj top t@(Exts.TyCon   h) = mshow h == name && not top
          adj top t@(Exts.TyVar   h) = mshow h == name && not top
          adj _ t@(Exts.TyApp l r)   = adj False l
          adj _ x                    = False