module MagicHaskeller.ReadHsType(readHsTypeSigs) where
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 Language.Haskell.Syntax
import Language.Haskell.Parser
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 :: String -> Exp
readHsTypeSigs String
str = [Maybe Exp] -> Exp
TupE [
#if __GLASGOW_HASKELL__ >= 810
                            Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$
#endif
                            HsName -> HsQualType -> Exp
mkSigE HsName
hsname HsQualType
hsqty
                            | HsTypeSig SrcLoc
_loc [HsName]
hsnames HsQualType
hsqty <- String -> [HsDecl]
readHsDecls String
str
                            , HsName
hsname <- [HsName]
hsnames ]

mkSigE :: HsName -> HsQualType -> TH.Exp
mkSigE :: HsName -> HsQualType -> Exp
mkSigE HsName
hsname HsQualType
hsqty = Exp -> Type -> Exp
SigE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ HsName -> Name
hsNameToTHName HsName
hsname) (HsQualType -> Type
hsQTypeToTHType HsQualType
hsqty)

hsQTypeToTHType :: HsQualType -> 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. 
hsQTypeToTHType :: HsQualType -> Type
hsQTypeToTHType (HsQualType [] HsType
hsty) = [TyVarBndr] -> Cxt -> Type -> Type
ForallT ((HsName -> TyVarBndr) -> [HsName] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> TyVarBndr
plainTV (Name -> TyVarBndr) -> (HsName -> Name) -> HsName -> TyVarBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsName -> Name
hsNameToTHName) ([HsName] -> [TyVarBndr]) -> [HsName] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ ([HsName] -> HsName) -> [[HsName]] -> [HsName]
forall a b. (a -> b) -> [a] -> [b]
map [HsName] -> HsName
forall a. [a] -> a
head ([[HsName]] -> [HsName]) -> [[HsName]] -> [HsName]
forall a b. (a -> b) -> a -> b
$ [HsName] -> [[HsName]]
forall a. Eq a => [a] -> [[a]]
group ([HsName] -> [[HsName]]) -> [HsName] -> [[HsName]]
forall a b. (a -> b) -> a -> b
$ [HsName] -> [HsName]
forall a. Ord a => [a] -> [a]
sort ([HsName] -> [HsName]) -> [HsName] -> [HsName]
forall a b. (a -> b) -> a -> b
$ [HsName] -> HsType -> [HsName]
varnames [] HsType
hsty) [] (HsType -> Type
hsTypeToTHType HsType
hsty)
hsQTypeToTHType (HsQualType [HsAsst]
_cxt HsType
_hsty) = String -> Type
forall a. HasCallStack => String -> a
error String
"Contexts are not supported yet."
hsTypeToTHType :: HsType -> Type
hsTypeToTHType (HsTyTuple [HsType]
hts)   = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT ([HsType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsType]
hts)) ((HsType -> Type) -> [HsType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map HsType -> Type
hsTypeToTHType [HsType]
hts)
hsTypeToTHType (HsTyFun HsType
ht0 HsType
ht1) = Type
ArrowT Type -> Type -> Type
`AppT` (HsType -> Type
hsTypeToTHType HsType
ht0) Type -> Type -> Type
`AppT` (HsType -> Type
hsTypeToTHType HsType
ht1)
hsTypeToTHType (HsTyApp HsType
ht0 HsType
ht1) = (HsType -> Type
hsTypeToTHType HsType
ht0) Type -> Type -> Type
`AppT` (HsType -> Type
hsTypeToTHType HsType
ht1)
hsTypeToTHType (HsTyCon HsQName
hsqname) = HsQName -> Type
hsQNameToTHType HsQName
hsqname
hsTypeToTHType (HsTyVar HsName
hsname)  = Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ HsName -> Name
hsNameToTHName HsName
hsname
-- The above definition should be exhaustive
varnames :: [HsName] -> HsType -> [HsName]
varnames [HsName]
vs (HsTyTuple [HsType]
hts)   = ([HsName] -> HsType -> [HsName])
-> [HsName] -> [HsType] -> [HsName]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [HsName] -> HsType -> [HsName]
varnames [HsName]
vs [HsType]
hts
varnames [HsName]
vs (HsTyFun HsType
ht0 HsType
ht1) = [HsName] -> HsType -> [HsName]
varnames ([HsName] -> HsType -> [HsName]
varnames [HsName]
vs HsType
ht0) HsType
ht1
varnames [HsName]
vs (HsTyApp HsType
ht0 HsType
ht1) = [HsName] -> HsType -> [HsName]
varnames ([HsName] -> HsType -> [HsName]
varnames [HsName]
vs HsType
ht0) HsType
ht1
varnames [HsName]
vs (HsTyCon HsQName
_)       = [HsName]
vs
varnames [HsName]
vs (HsTyVar HsName
hsname)  = HsName
hsnameHsName -> [HsName] -> [HsName]
forall a. a -> [a] -> [a]
:[HsName]
vs

hsNameToTHName :: HsName -> Name
hsNameToTHName = String -> Name
mkName (String -> Name) -> (HsName -> String) -> HsName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsName -> String
hsNameToString

hsNameToString :: HsName -> String
hsNameToString (HsIdent  String
str) = String
str
hsNameToString (HsSymbol String
str) = String
str -- Was: '(':str++")"

hsAsstToTHType :: HsAsst -> TH.Type
hsAsstToTHType :: HsAsst -> Type
hsAsstToTHType (HsQName
hsqname, [HsType]
hstypes) = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (HsQName -> Type
hsQNameToTHType HsQName
hsqname) ((HsType -> Type) -> [HsType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map HsType -> Type
hsTypeToTHType [HsType]
hstypes)

hsQNameToTHType :: HsQName -> Type
hsQNameToTHType (UnQual HsName
hsname) = Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ HsName -> Name
hsNameToTHName HsName
hsname
hsQNameToTHType (Qual Module
_ HsName
hsname) = Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ HsName -> Name
hsNameToTHName HsName
hsname -- qualifications over type names are ignored for now.
hsQNameToTHType (Special HsSpecialCon
HsFunCon)  = Type
ArrowT
hsQNameToTHType (Special HsSpecialCon
HsUnitCon) = Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"()"
hsQNameToTHType (Special HsSpecialCon
HsListCon) = Type
ListT
hsQNameToTHType (Special (HsTupleCon Int
n)) = Int -> Type
TupleT Int
n


readHsDecls :: String -> [HsDecl]
readHsDecls :: String -> [HsDecl]
readHsDecls String
src = case String -> ParseResult HsModule
parseModule String
src of ParseOk (HsModule SrcLoc
_loc Module
_nam Maybe [HsExportSpec]
_ex [HsImportDecl]
_imports [HsDecl]
decls) -> [HsDecl]
decls
                                          ParseFailed (SrcLoc String
_fn Int
line Int
column) String
str
                                                        -> String -> [HsDecl]
forall a. HasCallStack => String -> a
error (String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Show a => a -> String -> String
shows Int
line String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Show a => a -> String -> String
shows Int
column String
" of\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src)