Hs2lib-0.5.7: WinDll/Structs/MShow/HaskellSrcExts.hs
{-# 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