-- 
-- (c) Susumu Katayama
--
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


 -- other info is used when adding type constructors as functions
-- listToFM_C op = addListToFM_C op emptyFM -- moved to XFiniteMap
{-
defaultTyCons :: Kind -> [TypeName]
defaultTyCons 0 = ["()", "Char", "Integer", "Int", "Double", "Float", "Bool"]
defaultTyCons 1 = ["[]", "IO"]
defaultTyCons i | i<=7 = tuplename i
-}
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
{- can be used at least with lthprof
defaultTyCons = []
tupleMax = 0
-}

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
"[]")] -- It should be in defaultTyCons
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)