module DDC.Type.DataDef
( DataDef (..)
, DataDefs (..)
, DataMode (..)
, DataType (..)
, DataCtor (..)
, emptyDataDefs
, insertDataDef
, fromListDataDefs
, lookupModeOfDataType)
where
import DDC.Type.Exp
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Control.Monad
data DataDef n
= DataDef
{
dataDefTypeName :: !n
, dataDefParamKinds :: ![Kind n]
, dataDefCtors :: !(Maybe [(n, [Type n])]) }
deriving Show
data DataDefs n
= DataDefs
{ dataDefsTypes :: !(Map n (DataType n))
, dataDefsCtors :: !(Map n (DataCtor n)) }
deriving Show
data DataMode n
= DataModeSmall ![n]
| DataModeLarge
deriving Show
data DataType n
= DataType
{
dataTypeName :: !n
, dataTypeParamKinds :: ![Kind n]
, dataTypeMode :: !(DataMode n) }
deriving Show
data DataCtor n
= DataCtor
{
dataCtorName :: !n
, dataCtorTag :: !Integer
, dataCtorFieldTypes :: ![Type n]
, dataCtorTypeName :: !n }
deriving Show
emptyDataDefs :: DataDefs n
emptyDataDefs
= DataDefs
{ dataDefsTypes = Map.empty
, dataDefsCtors = Map.empty }
insertDataDef :: Ord n => DataDef n -> DataDefs n -> DataDefs n
insertDataDef (DataDef nType ks mCtors) dataDefs
= let defType = DataType
{ dataTypeName = nType
, dataTypeParamKinds = ks
, dataTypeMode = defMode }
defMode = case mCtors of
Nothing -> DataModeLarge
Just ctors -> DataModeSmall (map fst ctors)
makeDefCtor tag (nCtor, tsFields)
= DataCtor
{ dataCtorName = nCtor
, dataCtorTag = tag
, dataCtorFieldTypes = tsFields
, dataCtorTypeName = nType }
defCtors = case mCtors of
Nothing -> Nothing
Just cs -> Just $ zipWith makeDefCtor [0..] cs
in dataDefs
{ dataDefsTypes = Map.insert nType defType (dataDefsTypes dataDefs)
, dataDefsCtors = Map.union (dataDefsCtors dataDefs)
$ Map.fromList [(n, def)
| def@(DataCtor n _ _ _) <- concat $ maybeToList defCtors ]}
fromListDataDefs :: Ord n => [DataDef n] -> DataDefs n
fromListDataDefs defs
= foldr insertDataDef emptyDataDefs defs
lookupModeOfDataType :: Ord n => n -> DataDefs n -> Maybe (DataMode n)
lookupModeOfDataType n defs
= liftM dataTypeMode $ Map.lookup n (dataDefsTypes defs)