-- ReadHsTypeでhaskell-srcの代わりにhaskell-src-extsを使ったもの．
-- 実際の所，これを使うより，ghcにtextとしてreadableなhiを出力させてparseするなり，module GHCで同様のことをするほうが簡単で柔軟性がありそう．
-- exportされている関数のみを使用するべきな訳で．
-- あと，そもそもまずはclass関係のパーサをちゃんと作るべき．
module MagicHaskeller.ReadHsExtsType(readHsTypeSigs) where
import Language.Haskell.TH as TH
import Language.Haskell.Exts
import Data.List

import MagicHaskeller.ReadTHType(plainTV)

-- | @readHsTypeSigs@ reads a module string and returns an Exp that can be supplied to MagicHaskeller.p
readHsTypeSigs :: String -> TH.Exp
readHsTypeSigs str = TupE [ mkSigE hsname hsqty
                            | TypeSig _loc hsnames hsqty <- readHsDecls str
                            , hsname <- hsnames ]

mkSigE :: Name l -> Type l -> TH.Exp
mkSigE hsname hsqty = SigE (VarE $ hsNameToTHName hsname) (hsTypeToTHType hsqty)

hsTypeToTHType :: Type -> TH.Type
-- hsQTypeToTHType (HsQualType cxt hsty) = ForallT (map (plainTV . hsNameToTHName) $ map head $ group $ sort $ varnames [] hsty) (map hsAsstToTHType cxt) (hsTypeToTHType hsty) -- This is incorrect since template-haskell-2.4*, so just forget the contexts. 
hsTypeToTHType (TyForall _l Nothing [] hsty) = ForallT (map (plainTV . hsNameToTHName) $ map head $ group $ sort $ varnames [] hsty) [] (hsTypeToTHType hsty)
hsTypeToTHType (TyForall _l _bnd _cxt _hsty) = error "Contexts and type binding are not supported yet."
hsTypeToTHType (TyTuple _l Boxed hts)   = foldl AppT (TupleT (length hts)) (map hsTypeToTHType hts)
hsTypeToTHType (TyFun _l ht0 ht1) = ArrowT `AppT` (hsTypeToTHType ht0) `AppT` (hsTypeToTHType ht1)
hsTypeToTHType (TyApp _l ht0 ht1) = (hsTypeToTHType ht0) `AppT` (hsTypeToTHType ht1)
hsTypeToTHType (TyCon _l hsqname) = hsQNameToTHType hsqname
hsTypeToTHType (TyVar _l hsname)  = VarT $ hsNameToTHName hsname
-- The above definition should be exhaustive
varnames vs (TyTuple _l _ hts)   = foldl varnames vs hts
varnames vs (TyFun _l ht0 ht1) = varnames (varnames vs ht0) ht1
varnames vs (TyApp _l ht0 ht1) = varnames (varnames vs ht0) ht1
varnames vs (TyCon _l _)       = vs
varnames vs (TyVar _l hsname)  = hsname:vs

hsNameToTHName = mkName . hsNameToString

hsNameToString (Ident  _l str) = str
hsNameToString (Symbol _l str) = str -- Was: '(':str++")"

hsAsstToTHType :: HsAsst -> TH.Type
hsAsstToTHType (hsqname, hstypes) = foldl AppT (hsQNameToTHType hsqname) (map hsTypeToTHType hstypes)

hsQNameToTHType (UnQual _l hsname) = ConT $ hsNameToTHName hsname
hsQNameToTHType (Qual _l _ hsname) = ConT $ hsNameToTHName hsname -- qualifications over type names are ignored for now.
hsQNameToTHType (Special _l (FunCon _l))  = ArrowT
hsQNameToTHType (Special _l (UnitCon _l)) = ConT $ mkName "()"
hsQNameToTHType (Special _l (ListCon _l)) = ListT
hsQNameToTHType (Special _l (TupleCon _l Boxed n)) = TupleT n


readHsDecls :: String -> [HsDecl]
readHsDecls src = case parseFileContents src of ParseOk (Module _loc _namEx _pragma _imports decls) -> decls
                                                ParseFailed (SrcLoc _fn line column) str
                                                        -> error (str ++ " in " ++ shows line ":" ++ shows column " of\n" ++ src)