-- 
-- (c) Susumu Katayama
--
{-# LANGUAGE CPP #-}
module MagicHaskeller.ReadTypeRep where
import Data.Typeable
import MagicHaskeller.Types as Types
import MagicHaskeller.TyConLib
import Data.Array.IArray((!))
import qualified Data.Map(lookup)

import qualified Language.Haskell.TH as TH

#if __GLASGOW_HASKELL__ < 700
tyConName = tyConString
#endif

{- mkTyCon is now obsolete.
typeToTR ::  TyConLib -> Type -> TypeRep
typeToTR tcl ty = tyToTR tcl 0 ty
tyToTR :: TyConLib -> Kind -> Type -> TypeRep
tyToTR _      0 (TV _)    = typeOf 'c' -- めんどくさいのでとりあえずChar
tyToTR (_,ar) k (TC tc)   | tc >= 0   = mkTyConApp (mkTyCon $ fst ((ar!k) !! fromIntegral tc)) []
                          | otherwise = error "tyToTR: impossible (tc<0)."
tyToTR tcl    k (TA a b)  = mkAppTy (tyToTR tcl (k+1) a) (tyToTR tcl 0 b)
tyToTR tcl    0 (a :-> b) = mkFunTy (tyToTR tcl 0 a) (tyToTR tcl 0 b)
-}

-- とりあえずはFakeでないDynamicでのtype checkに使うだけなので，効率は考えなくてよい．
-- でもまあ，monomorphic限定ならTypeRepの方が速いみたい（？）．ソースを見た感じ，特に，equalityに関しては効率的な実装をやってるみたい．

{- -- 間違ってもう一回同じものを作ってしまった．kindに関してはtcIDを使った方がいいかも？
typeToTR ::  TyConLib -> Type -> TypeRep
typeToTR _       (TV _) = typeOf 'c' -- めんどくさいのでとりあえずChar
typeToTR (_,ar) (TC tc) | tcid >= 0 = mkTyConApp (mkTyCon $ fst ((ar ! tcKind tc) !! tcid)) []
                        | otherwise = error "tyToTR: impossible (tcid<0)."
                        where tcid = tcID tc
typeToTR tcl   (TA f a) = mkAppTy (typeToTR tcl f) (typeToTR tcl a)
typeToTR tcl  (a :-> r) = mkFunTy (typeToTR tcl a) (typeToTR tcl r)
-}

trToType :: TyConLib -> TypeRep -> Types.Type
trToType :: TyConLib -> TypeRep -> Type
trToType TyConLib
tcl TypeRep
tr = case TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
tr of
                    (TyCon
tc,[TypeRep]
trs) -> (if TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
funTyCon Bool -> Bool -> Bool
|| TyCon -> String
forall a. Show a => a -> String
show TyCon
tc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> String
forall a. Show a => a -> String
show TyCon
funTyCon -- dunno why, but sometimes |tc==funTyCon| is not enough.
                                   then TyConLib -> TypeRep -> Type
trToType TyConLib
tcl ([TypeRep] -> TypeRep
forall a. [a] -> a
head [TypeRep]
trs) Type -> Type -> Type
:-> TyConLib -> TypeRep -> Type
trToType TyConLib
tcl ([TypeRep] -> TypeRep
forall a. [a] -> a
head ([TypeRep] -> [TypeRep]
forall a. [a] -> [a]
tail [TypeRep]
trs))
                                   else (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
TA (TyCon -> Type
TC (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ Maybe TyCon -> TyCon
forall p. Maybe p -> p
fromJust (Maybe TyCon -> TyCon) -> Maybe TyCon -> TyCon
forall a b. (a -> b) -> a -> b
$ String -> Map String TyCon -> Maybe TyCon
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup (TyCon -> String
tyConString' TyCon
tc) (TyConLib -> Map String TyCon
forall a b. (a, b) -> a
fst TyConLib
tcl)) ((TypeRep -> Type) -> [TypeRep] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TyConLib -> TypeRep -> Type
trToType TyConLib
tcl) [TypeRep]
trs))
                        where fromJust :: Maybe p -> p
fromJust (Just p
x) = p
x
                              fromJust Maybe p
Nothing  = String -> p
forall a. HasCallStack => String -> a
error (TyCon -> String
tyConString' TyCon
tc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not appear in the component library. (This is a known bug.) For now, please use a type variable instead of "String -> String -> String
forall a. [a] -> [a] -> [a]
++TyCon -> String
forall a. Show a => a -> String
show TyCon
tc
                                                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and use `matching :: Int -> Memo -> TH.Type -> [[TH.Exp]]'.\n(or maybe you forgot to set a component library?)")
--                              fromJust Nothing = error ("tyConString = "++show (tyConString' tc) ++ ", and fst tcl = "++show (fst tcl))
--                              fromJust Nothing  = error (show tc ++ " does not appear in the component library. Forgot to set one? BTW tc==funTyCon is "++show (tc==funTyCon)++" and funTyCon is "++show funTyCon)
                              tyConString' :: TyCon -> String
tyConString' TyCon
tc = case TyCon -> String
tyConName TyCon
tc of
                                                                         str :: String
str@(Char
',':String
_) -> Char
'('Char -> String -> String
forall a. a -> [a] -> [a]
:String
strString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")" -- tyConString mistakenly prints "," instead of "(,)".
                                                                         String
str         -> String -> String
unqualify String
str
                                                                         -- Use the unqualified name to avoid confusion
                                                                         -- because Data.Typeable.tyConString shows the unqualified name
                                                                         -- for types defined in the Standard Hierarchical Library
                                                                         -- (though the qualified name is shown when Typeable is derived).
                              unqualify :: String -> String
                              unqualify :: String -> String
unqualify = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'.') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse

-- Do the following, because (mkTyCon "(->)") may or may not be equivalent to TyCon for functions in general.
funTyCon :: Data.Typeable.TyCon
funTyCon :: TyCon
funTyCon = TypeRep -> TyCon
typeRepTyCon ((Bool -> Bool -> Bool) -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Bool -> Bool -> Bool
(&&)) 
{- mkTyConApp and mkTyCon3 have been obsoleted since base-4.10.
funTyCon = typeRepTyCon (mkFunTy undefTC undefTC)
-- undef = error "funTyCon" -- Dunno why, but seemingly mkFunTy is strict.
undefTC = mkTyConApp (mkTyCon3 "base" "Prelude" "Hoge") []
-}

trToTHType :: TypeRep -> TH.Type
trToTHType :: TypeRep -> Type
trToTHType TypeRep
tr = case TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
tr of
                  (TyCon
tc,[TypeRep]
trs) -> if TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
funTyCon Bool -> Bool -> Bool
|| TyCon -> String
forall a. Show a => a -> String
show TyCon
tc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> String
forall a. Show a => a -> String
show TyCon
funTyCon -- dunno why, but sometimes |tc==funTyCon| is not enough.
                                   then Type -> Type -> Type
TH.AppT Type
TH.ArrowT (TypeRep -> Type
trToTHType ([TypeRep] -> TypeRep
forall a. [a] -> a
head [TypeRep]
trs)) Type -> Type -> Type
`TH.AppT` TypeRep -> Type
trToTHType ([TypeRep] -> TypeRep
forall a. [a] -> a
head ([TypeRep] -> [TypeRep]
forall a. [a] -> [a]
tail [TypeRep]
trs))
                                   else (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT (String -> Name
TH.mkName (TyCon -> String
tyConName TyCon
tc))) ((TypeRep -> Type) -> [TypeRep] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TypeRep -> Type
trToTHType [TypeRep]
trs)
                        where tyConToName :: TyCon -> Type
tyConToName TyCon
str = case TyCon -> String
tyConName TyCon
str of   String
"[]"        -> Type
TH.ListT
                                                                        str :: String
str@(Char
',':String
_) -> Int -> Type
TH.TupleT (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) -- tyConString mistakenly prints "," instead of "(,)".
                                                                        String
str         -> Name -> Type
TH.ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName String
str