module MagicHaskeller.TyConLib where
import qualified Data.Map as Map
import MagicHaskeller.Types
import Data.Array.IArray
import qualified Language.Haskell.TH as TH
import Data.List(nub)
type Map = Map.Map
type TyConLib = (Map TypeName TyCon, Array Kind [(TypeName,TyCon)])
defaultTCL :: TyConLib
defaultTCL = [(Kind, TypeName)] -> TyConLib
tyConsToTCL [(Kind, TypeName)]
defaultTyCons
tyConsToTCL :: [(Kind, TypeName)] -> TyConLib
tyConsToTCL :: [(Kind, TypeName)] -> TyConLib
tyConsToTCL [(Kind, TypeName)]
tcs
= ((TyCon -> TyCon -> TyCon)
-> [(TypeName, TyCon)] -> Map TypeName TyCon
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (\TyCon
new TyCon
old -> TyCon
old) [ (TypeName, TyCon)
tup | Kind
k <- [Kind
0..Kind
7], (TypeName, TyCon)
tup <- Array Kind [(TypeName, TyCon)]
tcsByK Array Kind [(TypeName, TyCon)] -> Kind -> [(TypeName, TyCon)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Kind
k ], Array Kind [(TypeName, TyCon)]
tcsByK)
where tnsByK :: Array Kind [TypeName]
tnsByK :: Array Kind [TypeName]
tnsByK = ([TypeName] -> TypeName -> [TypeName])
-> [TypeName]
-> (Kind, Kind)
-> [(Kind, TypeName)]
-> Array Kind [TypeName]
forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(i, e')] -> a i e
accumArray ((TypeName -> [TypeName] -> [TypeName])
-> [TypeName] -> TypeName -> [TypeName]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] (Kind
0,Kind
7) ([(Kind, TypeName)] -> [(Kind, TypeName)]
forall a. [a] -> [a]
reverse ([(Kind, TypeName)] -> [(Kind, TypeName)]
forall a. Eq a => [a] -> [a]
nub [(Kind, TypeName)]
tcs))
tcsByK :: Array Kind [(TypeName,TyCon)]
tcsByK :: Array Kind [(TypeName, TyCon)]
tcsByK = (Kind, Kind)
-> [[(TypeName, TyCon)]] -> Array Kind [(TypeName, TyCon)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Kind
0,Kind
7) [ [TypeName] -> [(TypeName, TyCon)]
tnsToTCs (Array Kind [TypeName]
tnsByK Array Kind [TypeName] -> Kind -> [TypeName]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Kind
k) | Kind
k <- [Kind
0..Kind
7] ]
tnsToTCs :: [TypeName] -> [(TypeName,TyCon)]
tnsToTCs :: [TypeName] -> [(TypeName, TyCon)]
tnsToTCs [TypeName]
tns = (TyCon -> TypeName -> (TypeName, TyCon))
-> [TyCon] -> [TypeName] -> [(TypeName, TyCon)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ TyCon
i TypeName
tn -> (TypeName
tn, TyCon
i)) [TyCon
0..] [TypeName]
tns
defaultTyCons :: [(Kind, TypeName)]
defaultTyCons :: [(Kind, TypeName)]
defaultTyCons = [(Kind
0, TypeName
"()"), (Kind
1, TypeName
"[]")] [(Kind, TypeName)] -> [(Kind, TypeName)] -> [(Kind, TypeName)]
forall a. [a] -> [a] -> [a]
++ [ (Kind
i, Kind -> TypeName
tuplename Kind
i) | Kind
i<-[Kind
2..Kind
tupleMax] ] [(Kind, TypeName)] -> [(Kind, TypeName)] -> [(Kind, TypeName)]
forall a. [a] -> [a] -> [a]
++ [(Kind
0, TypeName
"Int"), (Kind
0, TypeName
"Char"), (Kind
0, TypeName
"Bool"), (Kind
0, TypeName
"Integer"), (Kind
0, TypeName
"Double"), (Kind
0, TypeName
"Float"), (Kind
1,TypeName
"Maybe"), (Kind
1,TypeName
"IO"), (Kind
2,TypeName
"Either"), (Kind
0,TypeName
"Ordering"), (Kind
1,TypeName
"Ratio"), (Kind
1,TypeName
"Gen")]
tupleMax :: Kind
tupleMax = Kind
7
tuplename :: Kind -> TypeName
tuplename Kind
i = Char
'('Char -> TypeName -> TypeName
forall a. a -> [a] -> [a]
:Kind -> Char -> TypeName
forall a. Kind -> a -> [a]
replicate (Kind
iKind -> Kind -> Kind
forall a. Num a => a -> a -> a
-Kind
1) Char
',' TypeName -> TypeName -> TypeName
forall a. [a] -> [a] -> [a]
++TypeName
")"
unit :: TyConLib -> TyCon
unit TyConLib
tcl = TyConLib -> TypeName -> TyCon
nameToTyCon TyConLib
tcl TypeName
"()"
list :: TyConLib -> TyCon
list TyConLib
tcl = TyConLib -> TypeName -> TyCon
nameToTyCon TyConLib
tcl TypeName
"[]"
disj :: TyConLib -> TyCon
disj TyConLib
tcl = TyConLib -> TypeName -> TyCon
nameToTyCon TyConLib
tcl TypeName
"Either"
tuple :: TyConLib -> Kind -> TyCon
tuple TyConLib
tcl Kind
n = TyConLib -> TypeName -> TyCon
nameToTyCon TyConLib
tcl (Kind -> TypeName
tuplename Kind
n)
nameToTyCon :: TyConLib -> String -> TyCon
nameToTyCon :: TyConLib -> TypeName -> TyCon
nameToTyCon (Map TypeName TyCon
fm,Array Kind [(TypeName, TyCon)]
_) TypeName
name = case TypeName -> Map TypeName TyCon -> Maybe TyCon
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeName
name Map TypeName TyCon
fm of
Maybe TyCon
Nothing -> TypeName -> TyCon
forall a. HasCallStack => TypeName -> a
error TypeName
"nameToTyCon: unknown TyCon"
Just TyCon
c -> TyCon
c
thTypesToTCL :: [Type] -> TyConLib
thTypesToTCL [Type]
thts = [(Kind, TypeName)] -> TyConLib
tyConsToTCL ([Type] -> [(Kind, TypeName)]
thTypesToTyCons [Type]
thts [(Kind, TypeName)] -> [(Kind, TypeName)] -> [(Kind, TypeName)]
forall a. [a] -> [a] -> [a]
++ [(Kind, TypeName)]
defaultTyCons)
thTypesToTyCons :: [TH.Type] -> [(Kind,TypeName)]
thTypesToTyCons :: [Type] -> [(Kind, TypeName)]
thTypesToTyCons [Type]
thtys = [ (Kind, TypeName)
tycon | Type
thty <- [Type]
thtys, (Kind, TypeName)
tycon <- Kind -> Type -> [(Kind, TypeName)]
thTypeToTyCons Kind
0 Type
thty ]
thTypeToTyCons :: Kind -> TH.Type -> [(Kind,TypeName)]
thTypeToTyCons :: Kind -> Type -> [(Kind, TypeName)]
thTypeToTyCons Kind
k (TH.ForallT [TyVarBndr]
names [Type]
_cxt Type
t) = Kind -> Type -> [(Kind, TypeName)]
thTypeToTyCons Kind
k Type
t
thTypeToTyCons Kind
k (TH.AppT Type
t Type
u) = Kind -> Type -> [(Kind, TypeName)]
thTypeToTyCons (Kind
kKind -> Kind -> Kind
forall a. Num a => a -> a -> a
+Kind
1) Type
t [(Kind, TypeName)] -> [(Kind, TypeName)] -> [(Kind, TypeName)]
forall a. [a] -> [a] -> [a]
++ Kind -> Type -> [(Kind, TypeName)]
thTypeToTyCons Kind
0 Type
u
thTypeToTyCons Kind
2 Type
TH.ArrowT = []
thTypeToTyCons Kind
1 Type
TH.ListT = [(Kind
1, TypeName
"[]")]
thTypeToTyCons Kind
_ (TH.VarT Name
_name) = []
thTypeToTyCons Kind
k (TH.ConT Name
qname) = [(Kind
k, Name -> TypeName
forall a. Show a => a -> TypeName
show Name
qname)]
thTypeToTyCons Kind
k (TH.TupleT Kind
i) | Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
i = [(Kind
i, Kind -> TypeName
tuplename Kind
i)]
thTypeToTyCons Kind
k Type
tht = TypeName -> [(Kind, TypeName)]
forall a. HasCallStack => TypeName -> a
error (TypeName
"thTypeToTyCons :: Kind error. k = "TypeName -> TypeName -> TypeName
forall a. [a] -> [a] -> [a]
++Kind -> TypeName
forall a. Show a => a -> TypeName
show Kind
kTypeName -> TypeName -> TypeName
forall a. [a] -> [a] -> [a]
++TypeName
" and tht = "TypeName -> TypeName -> TypeName
forall a. [a] -> [a] -> [a]
++Type -> TypeName
forall a. Ppr a => a -> TypeName
TH.pprint Type
tht)