Instances.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Module containing definitions for misc instances, for commonly used 
-- datatypes like Maybe, Either etc
--
-----------------------------------------------------------------------------

module WinDll.Lib.Instances
 (module WinDll.Lib.Instances
 ,module WinDll.Lib.InstancesTypes) where

import WinDll.Lib.NativeMapping
import WinDll.Lib.InstancesTypes
import WinDll.Lib.Native
import WinDll.Structs.Structures
import WinDll.Structs.MShow.HaskellSrcExts
import WinDll.Structs.MShow.MShow
import WinDll.Parsers

import Foreign
import Foreign.C
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils

import Control.Monad
import Control.Monad.Instances
import Control.Arrow

import Data.List
import Data.Maybe
import Data.Generics hiding (DataType)

import qualified Language.Haskell.Exts as Exts

import Debug.Trace

-- | Constant of known instances
knownDataInstances = map fst instanceMappings

-- | Mapping of instance names to specializeable datatypes
instanceMappings = [("Maybe"  , specMaybe )
                   ,("Either" , specEither)
                   ] -- ,("Located", specLocated)]

-- | A mapping from Type name to Specialization function
getSpecializations :: DataTypes -> [(Name,[Exts.Type])] -> DataTypes
getSpecializations _ []     = [] -- trace (unlines $ map show list) $
getSpecializations dyn list = nub $ getSpecialization list
  where mapping = map (getName &&& id) dyn ++ instanceMappings
  
        getSpecialization :: [(Name,[Exts.Type])] -> DataTypes
        getSpecialization []         = []
        getSpecialization ((n,t):xs) = 
            case lookup n mapping of
                Nothing -> getSpecialization xs
                Just f  -> let adt = specialize t f
                               typ = getTypes adt
                               cls = concatMap (\x-> maybe [] (flip selectTypePre x) ((getHead . stripTop) x)) typ
                               emb = getSpecializations dyn cls
                           in adt  : emb ++ getSpecialization xs --(map translate t)
                
-- | A mapping from Type name to the simple identity types that are needed
--   Since the problem with Overlapping instances in GHC only doing head matches
--   is preventing me to solve this with general classes.
getInstances :: Defs -> [(Name,Types)] -> [Types]
getInstances _    []          = []
getInstances defs ((n,t):xs)  = 
    case lookup n instanceMappings of
        Nothing -> getInstances defs xs
        Just f  -> map (translate defs) t : getInstances defs xs

-- | Specializable constant for Maybe
specMaybe :: DataType
specMaybe = let con = [Constr "Nothing" []
                      ,Constr "Just" [AnnType "maybe_just_var1" ty noAnn ty]
                      ]
                ty  = Exts.TyVar (Exts.Ident "a")
            in DataType "Maybe" ["a"] con NoTag
            
specEither :: DataType
specEither = let con = [Constr "Left"  [AnnType "either_left_var1" tyA noAnn tyA]
                       ,Constr "Right" [AnnType "either_right_var1" tyB noAnn tyB]
                       ]
                 tyA = Exts.TyVar (Exts.Ident "a")
                 tyB = Exts.TyVar (Exts.Ident "b")
             in DataType "Either" ["a","b"] con NoTag 
            
-- | Specializable constant for Located
specLocated :: DataType
specLocated = let con = [Constr "L" [AnnType "located_l_var1" tyA noAnn tyA
                                    ,AnnType "located_l_var2" tyB noAnn tyB]
                        ]
                  tyA = Exts.TyCon (Exts.UnQual (Exts.Ident "SrcSpan"))
                  tyB = Exts.TyVar (Exts.Ident "e")
              in DataType "Located" ["e"] con NoTag
            
-- | A function that can specialize any DataType
specialize :: [Exts.Type] -> DataType -> DataType
specialize newtypes dt@(NewType n t f g ) =
    case specialize newtypes (DataType n t [f] g) of
      (DataType n' t' f' g') -> NewType n' t' (head f') g'
specialize newtypes dt@(DataType n t c d) 
        | length t <= length newtypes = let newc    = everywhere (mkT spectype) c
                                        in DataType n (map (mshowM 2) newtypes) newc d
        | otherwise = error $ "fatal error in specialization of '" ++ show n ++ "' the supplied list does not contain sufficient elements to do a specialization"
                 where spectype :: Type -> Type
                       spectype = foldr (.) id $ zipWith ($) (map swapTypes t)  newtypes