-- 
-- (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 = tyConsToTCL defaultTyCons

tyConsToTCL :: [(Kind, TypeName)] -> TyConLib
tyConsToTCL tcs
    = (Map.fromListWith (\new old -> old) [ tup | k <- [0..7], tup <- tcsByK ! k ], tcsByK)
    where tnsByK :: Array Kind [TypeName]
	  tnsByK = accumArray (flip (:)) [] (0,7) (reverse (nub tcs))
	  tcsByK :: Array Kind [(TypeName,TyCon)]
	  tcsByK = listArray (0,7) [ tnsToTCs (tnsByK ! k) | k <- [0..7] ]
	  tnsToTCs :: [TypeName] -> [(TypeName,TyCon)]
	  tnsToTCs tns = zipWith (\ i tn -> (tn, i)) [0..] 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 = [(0, "()"), (1, "[]")] ++ [ (i, tuplename i) | i<-[2..tupleMax] ] ++ [(0, "Int"), (0, "Char"), (0, "Bool"), (0, "Integer"), (0, "Double"), (0, "Float"), (1,"Maybe"), (1,"IO"), (2,"Either"), (0,"Ordering"),  (1,"Gen")]
tupleMax = 7
{- can be used at least with lthprof
defaultTyCons = []
tupleMax = 0
-}

{-
defaultTyCons :: [(TypeName, Kind)]
defaultTyCons = [("()",Star), ("[]",Star::->Star)] ++ [ (tuplename i, intToRank1Kind i) | i<-[2..7] ] ++ [("Char",Star), ("Integer",Star), ("Int",Star), ("Double",Star), ("Float",Star), ("IO",Star::->Star), ("Bool",Star)] -- ここに出てくる奴がVirtual.hsでも出てくるとエラーになるので注意．
-- defaultTyCons = [("*","()"), ("* -> *","[]"), 
-}

tuplename i = '(':replicate (i-1) ',' ++")"
{-
intToRank1Kind :: Int -> Kind
intToRank1Kind 0 = Star
intToRank1Kind i = Star ::-> intToRank1Kind (i-1)
-- なるべくこいつらを使う．省スペースのため．tuplesってlistを作るべき?
-- first-order kind のほうがただしかったような。
unit  = Con 0 "()" Star
list  = Con 1 "[]" (Star::->Star)
tuple n = Con (fromIntegral n) (tuplename n) (intToRank1Kind n)
-- arrow = Con 2 "(->)" 2
-- tuple n = Con (n+1) (tuplename n) n
-}
{-
unit    = Con 0 0
list    = Con 1 0
tuple n = Con n 0
-}

unit  tcl   = nameToTyCon tcl "()"
list  tcl   = nameToTyCon tcl "[]"
disj  tcl   = nameToTyCon tcl "Either"
tuple tcl n = nameToTyCon tcl (tuplename n)

nameToTyCon :: TyConLib -> String -> TyCon
nameToTyCon (fm,_) name = case Map.lookup name fm of
	                    Nothing -> error "nameToTyCon: unknown TyCon"
	                    Just c  -> c

thTypesToTCL thts = tyConsToTCL (thTypesToTyCons thts ++ defaultTyCons)
thTypesToTyCons :: [TH.Type] -> [(Kind,TypeName)]
thTypesToTyCons thtys = [ tycon | thty <- thtys, tycon <- thTypeToTyCons 0 thty ]

thTypeToTyCons :: Kind -> TH.Type -> [(Kind,TypeName)]
thTypeToTyCons k (TH.ForallT names _cxt t) = thTypeToTyCons k t
thTypeToTyCons k (TH.AppT  t u)    = thTypeToTyCons (k+1) t ++ thTypeToTyCons 0 u
thTypeToTyCons 2 TH.ArrowT         = []
thTypeToTyCons 1 TH.ListT          = [(1, "[]")] -- It should be in defaultTyCons
thTypeToTyCons _ (TH.VarT  _name)  = []
thTypeToTyCons k (TH.ConT  qname)  = [(k, show qname)]
thTypeToTyCons k (TH.TupleT  i)    | k == i = [(i, tuplename i)]
thTypeToTyCons k tht = error ("thTypeToTyCons :: Kind error. k = "++show k++" and tht = "++TH.pprint tht)