-- 
-- (c) Susumu Katayama
--

\begin{code}
{-# OPTIONS -cpp #-}
module MagicHaskeller.ReadTHType(thTypeToType, typeToTHType, showTypeName, plainTV, unPlainTV) where

import MagicHaskeller.Types as Types
import MagicHaskeller.TyConLib
import Language.Haskell.TH as TH hiding (plainTV) -- Since template-haskell-2.12.0.0, TH.Lib.plainTV is exported to TH. Its definition is plainTV=PlainTV.
import Data.Array((!), inRange, bounds)
import Data.Char(ord,chr)
import Data.List(nub, union)
import Data.Map(lookup)

showTypeName :: Name -> String
showTypeName = Name -> String
TH.nameBase -- 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).
-- showTypeName = show -- maybe in future, when TypeRep can be shown qualified.

-- Since GHC-8.4, ForallT is not inserted by default if the outermost forall is omitted. So thTypeToType has to bind unbound variables.
unboundTHTyvars :: [Name] -> Type -> [Name]
unboundTHTyvars [Name]
vs (ForallT [TyVarBndr]
bs []    Type
t) = [Name] -> Type -> [Name]
unboundTHTyvars ([Name]
vs[Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++(TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrToName [TyVarBndr]
bs) Type
t
unboundTHTyvars [Name]
_  (ForallT [TyVarBndr]
_ (Type
_:[Type]
_) Type
t) = String -> [Name]
forall a. HasCallStack => String -> a
error String
"Type classes are not supported yet."
unboundTHTyvars [Name]
_  (TupleT Int
_)      = []
unboundTHTyvars [Name]
_  Type
ListT           = []
unboundTHTyvars [Name]
_  Type
ArrowT          = []
unboundTHTyvars [Name]
vs (AppT Type
ht0 Type
ht1)  = [Name] -> Type -> [Name]
unboundTHTyvars [Name]
vs Type
ht0 [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
`union` [Name] -> Type -> [Name]
unboundTHTyvars [Name]
vs Type
ht1
unboundTHTyvars [Name]
_  (ConT Name
name) = []
unboundTHTyvars [Name]
vs (VarT Name
name) = case Name -> [(Name, Integer)] -> Maybe Integer
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup Name
name ([(Name, Integer)] -> Maybe Integer)
-> [(Name, Integer)] -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ [Name] -> [Integer] -> [(Name, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
vs [Integer
0..] of Maybe Integer
Nothing -> [Name
name]
                                                                            Just Integer
_  -> []

thTypeToType :: TyConLib -> TH.Type -> Types.Type
thTypeToType :: TyConLib -> Type -> Type
thTypeToType TyConLib
tcl Type
t = -- trace ("thTypeToType " ++ show t) $ --  pprint t)
                     Type -> Type
normalize (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ TyConLib -> [Name] -> Type -> Type
thTypeToType' TyConLib
tcl ([Name] -> Type -> [Name]
unboundTHTyvars [] Type
t) Type
t
thTypeToType' :: TyConLib -> [Name] -> Type -> Type
thTypeToType' TyConLib
tcl [Name]
vs (ForallT [TyVarBndr]
bs []    Type
t) = TyConLib -> [Name] -> Type -> Type
thTypeToType' TyConLib
tcl ([Name]
vs[Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++(TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrToName [TyVarBndr]
bs) Type
t
thTypeToType' TyConLib
tcl [Name]
_  (ForallT [TyVarBndr]
_ (Type
_:[Type]
_) Type
t) = String -> Type
forall a. HasCallStack => String -> a
error String
"Type classes are not supported yet."
thTypeToType' TyConLib
tcl [Name]
_  (TupleT Int
n)      = TyCon -> Type
TC (TyConLib -> Int -> TyCon
tuple TyConLib
tcl Int
n)
thTypeToType' TyConLib
tcl [Name]
_ Type
ListT           = TyCon -> Type
TC (TyConLib -> TyCon
list TyConLib
tcl)
-- thTypeToType' tcl (HsTyFun ht0 ht1)
--     = thTypeToType' tcl ht0 :-> thTypeToType' tcl ht1
thTypeToType' TyConLib
tcl [Name]
vs (AppT (AppT Type
ArrowT      Type
ht0) Type
ht1)                           = TyConLib -> [Name] -> Type -> Type
thTypeToType' TyConLib
tcl [Name]
vs  Type
ht0 Type -> Type -> Type
:-> TyConLib -> [Name] -> Type -> Type
thTypeToType' TyConLib
tcl [Name]
vs  Type
ht1
thTypeToType' TyConLib
tcl [Name]
vs (AppT (AppT (ConT Name
name) Type
ht0) Type
ht1) | Name -> String
nameBase Name
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"(->)" = TyConLib -> [Name] -> Type -> Type
thTypeToType' TyConLib
tcl [Name]
vs  Type
ht0 Type -> Type -> Type
:>  TyConLib -> [Name] -> Type -> Type
thTypeToType' TyConLib
tcl [Name]
vs  Type
ht1
thTypeToType' TyConLib
tcl [Name]
vs (AppT Type
ht0 Type
ht1)                                              = Type -> Type -> Type
TA (TyConLib -> [Name] -> Type -> Type
thTypeToType' TyConLib
tcl [Name]
vs  Type
ht0) (TyConLib -> [Name] -> Type -> Type
thTypeToType' TyConLib
tcl [Name]
vs  Type
ht1)
thTypeToType' (Map String TyCon
fm,Array Int [(String, TyCon)]
_) [Name]
_ (ConT Name
name) = let nstr :: String
nstr = Name -> String
showTypeName Name
name
                                     in case String -> Map String TyCon -> Maybe TyCon
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup String
nstr Map String TyCon
fm of
                                          Maybe TyCon
Nothing -> -- TC $ (-1 - bakaHash nstr)
                                                     String -> Type
forall a. HasCallStack => String -> a
error (String -> Type) -> String -> Type
forall a b. (a -> b) -> a -> b
$ String
"thTypeToType' : "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nstrString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" : unknown TyCon"
                                          Just TyCon
c  -> TyCon -> Type
TC TyCon
c
{- この辺は単なるコメントアウトでいいんだっけ？ 
thTypeToType' tcl (HsTyCon (Special HsUnitCon)) = TC (unit tcl)
thTypeToType' tcl (HsTyCon (Special HsListCon)) = TC (list tcl)
-}
thTypeToType' TyConLib
_  [Name]
_ Type
ArrowT = String -> Type
forall a. HasCallStack => String -> a
error String
"Partially applied (->)."
thTypeToType' TyConLib
_  [Name]
vs (VarT Name
name) = TyCon -> Type
TV (TyCon -> Type) -> TyCon -> Type
forall a b. (a -> b) -> a -> b
$ case Name -> [(Name, TyCon)] -> Maybe TyCon
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup Name
name ([(Name, TyCon)] -> Maybe TyCon) -> [(Name, TyCon)] -> Maybe TyCon
forall a b. (a -> b) -> a -> b
$ [Name] -> [TyCon] -> [(Name, TyCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
vs [TyCon
0..] of Maybe TyCon
Nothing -> String -> TyCon
forall a. HasCallStack => String -> a
error String
"thTypeToType : unbound type variable"
                                                                                  Just TyCon
i  -> TyCon
i
-- thTypeToType' _   hst = error ("thTypeToType': "++show hst)

tyVarBndrToName :: TyVarBndr -> Name
tyVarBndrToName (PlainTV Name
name)    = Name
name
tyVarBndrToName (KindedTV Name
name Type
_) = Name
name

{- tcKindを廃止するので．ま，tcKindがなくてもhigher-order kindでなければトップレベルのkindから推論できるし．
-- copied from svn/MagicHaskeller/memodeb/RandomFilter.hs
typeToTHType :: TyConLib -> Types.Type -> TH.Type
typeToTHType tcl ty = TH.ForallT (map tvToName $ tyvars ty) [] (typeToTHType' tcl ty)
typeToTHType' (_,ar) (TC tc) | tcid >= 0 = TH.ConT (TH.mkName $ fst ((ar ! tcKind tc) !! tcid))
                             where tcid = tcID tc
typeToTHType' tcl    (TV tv) = TH.VarT $ tvToName tv
typeToTHType' tcl (TA t0 t1) = TH.AppT (typeToTHType' tcl t0) (typeToTHType' tcl t1)
typeToTHType' tcl (t0:->t1)  = TH.AppT (TH.AppT TH.ArrowT (typeToTHType' tcl t0)) (typeToTHType' tcl t1)
typeToTHType' tcl (t0:> t1)  = TH.AppT (TH.AppT sectionedArrow (typeToTHType' tcl t0)) (typeToTHType' tcl t1)
tvToName = TH.mkName . return . chr . (+ ord 'a') . tvID
-}
typeToTHType :: TyConLib -> Types.Type -> TH.Type
typeToTHType :: TyConLib -> Type -> Type
typeToTHType TyConLib
tcl Type
ty = (case Type -> [TyCon]
tyvars Type
ty of []  -> Type -> Type
forall a. a -> a
id
                                         [TyCon]
tvs -> [TyVarBndr] -> [Type] -> Type -> Type
TH.ForallT ((TyCon -> TyVarBndr) -> [TyCon] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> TyVarBndr
plainTV (Name -> TyVarBndr) -> (TyCon -> Name) -> TyCon -> TyVarBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Name
forall a. Show a => a -> Name
tvToName) ([TyCon] -> [TyVarBndr]) -> [TyCon] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ [TyCon] -> [TyCon]
forall a. Eq a => [a] -> [a]
nub [TyCon]
tvs) [])
                                                               (TyConLib -> Int -> Type -> Type
forall i a b.
(Num i, Ix i, Show i) =>
(a, Array i [(String, b)]) -> i -> Type -> Type
typeToTHType' TyConLib
tcl Int
0 Type
ty)
typeToTHType' :: (a, Array i [(String, b)]) -> i -> Type -> Type
typeToTHType' (a
_,Array i [(String, b)]
ar) i
k (TC TyCon
tc) | TyCon
tc TyCon -> TyCon -> Bool
forall a. Ord a => a -> a -> Bool
>= TyCon
0 = if String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"[]" then Type
ListT else Name -> Type
TH.ConT (String -> Name
TH.mkName String
name)
                             where name :: String
name = if (i, i) -> i -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Array i [(String, b)] -> (i, i)
forall i e. Array i e -> (i, i)
bounds Array i [(String, b)]
ar) i
k then (String, b) -> String
forall a b. (a, b) -> a
fst ((Array i [(String, b)]
ar Array i [(String, b)] -> i -> [(String, b)]
forall i e. Ix i => Array i e -> i -> e
! i
k) [(String, b)] -> Int -> (String, b)
forall a. [a] -> Int -> a
!! TyCon -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyCon
tc)
                                                                   else Char
'K'Char -> String -> String
forall a. a -> [a] -> [a]
:i -> String -> String
forall a. Show a => a -> String -> String
shows i
k (Char
'I'Char -> String -> String
forall a. a -> [a] -> [a]
:TyCon -> String
forall a. Show a => a -> String
show TyCon
tc) -- useful with defaultTCL 
typeToTHType' (a, Array i [(String, b)])
tcl    i
_ (TV TyCon
tv) = Name -> Type
TH.VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ TyCon -> Name
forall a. Show a => a -> Name
tvToName TyCon
tv
typeToTHType' (a, Array i [(String, b)])
tcl    i
k (TA Type
t0 Type
t1) = Type -> Type -> Type
TH.AppT ((a, Array i [(String, b)]) -> i -> Type -> Type
typeToTHType' (a, Array i [(String, b)])
tcl (i
ki -> i -> i
forall a. Num a => a -> a -> a
+i
1) Type
t0) ((a, Array i [(String, b)]) -> i -> Type -> Type
typeToTHType' (a, Array i [(String, b)])
tcl i
0 Type
t1)
typeToTHType' (a, Array i [(String, b)])
tcl    i
0 (Type
t0:->Type
t1)  = Type -> Type -> Type
TH.AppT (Type -> Type -> Type
TH.AppT Type
TH.ArrowT ((a, Array i [(String, b)]) -> i -> Type -> Type
typeToTHType' (a, Array i [(String, b)])
tcl i
0 Type
t0)) ((a, Array i [(String, b)]) -> i -> Type -> Type
typeToTHType' (a, Array i [(String, b)])
tcl i
0 Type
t1)
typeToTHType' (a, Array i [(String, b)])
tcl    i
0 (Type
t0:> Type
t1)  = Type -> Type -> Type
TH.AppT (Type -> Type -> Type
TH.AppT Type
sectionedArrow ((a, Array i [(String, b)]) -> i -> Type -> Type
typeToTHType' (a, Array i [(String, b)])
tcl i
0 Type
t0)) ((a, Array i [(String, b)]) -> i -> Type -> Type
typeToTHType' (a, Array i [(String, b)])
tcl i
0 Type
t1)
-- tvToName = TH.mkName . return . chr . (+ ord 'a')

-- Maybe this should be dealt with by the version number of template-haskell, but how can I tell the number in the source code?
#if __GLASGOW_HASKELL__<=610
plainTV = id
unPlainTV = id
#else
plainTV :: Name -> TyVarBndr
plainTV = Name -> TyVarBndr
PlainTV
unPlainTV :: TyVarBndr -> Name
unPlainTV (PlainTV Name
v) = Name
v
unPlainTV (KindedTV Name
v Type
_) = Name
v -- Uh, are there be problems?
#endif
tvToName :: a -> Name
tvToName a
n = String -> Name
TH.mkName (Char
't'Char -> String -> String
forall a. a -> [a] -> [a]
:a -> String
forall a. Show a => a -> String
show a
n)

-- secionedArrow = TH.ConT ''(->) -- 多分こっちでもOK
sectionedArrow :: Type
sectionedArrow = Name -> Type
TH.ConT (String -> Name
mkName String
"GHC.Prim.(->)")

{-
Prelude> :module +Language.Haskell.TH
Prelude Language.Haskell.TH> AppT (AppT (ConT $ mkName "GHC.Prim.(->)") (ConT $ mkName "GHC.Base.Int")) (ConT $ mkName  "Char")
AppT (AppT (ConT GHC.Prim.(->)) (ConT GHC.Base.Int)) (ConT Char)
Prelude Language.Haskell.TH> AppT (AppT ArrowT (ConT $ mkName "GHC.Base.Int")) (ConT $ mkName  "Char")
AppT (AppT ArrowT (ConT GHC.Base.Int)) (ConT Char)
-}

\end{code}