module DataConstructors(
AliasType(..),
boxPrimitive,
collectDeriving,
conSlots,
constructionExpression,
Constructor(..),
DataFamily(..),
DataTable(..),
DataTableMonad(..),
dataTablePrims,
deconstructionExpression,
deriveClasses,
extractIO,
extractIO',
extractPrimitive,
ExtTypeInfo(..),
extTypeInfoExtType,
followAlias,
followAliases,
getConstructor,
getConstructorArities,
getProduct,
getSiblings,
lookupExtTypeInfo,
mktBox,
modBox,
numberSiblings,
onlyChild,
pprintTypeOfCons,
primitiveAliases,
removeNewtypes,
samplePrimitiveDataTable,
showDataTable,
Slot(..),
slotTypes,
slotTypesHs,
tAbsurd,
toDataTable,
typesCompatable,
updateLit
) where
import Control.Monad.Identity
import Control.Monad.Writer(tell,execWriter)
import Data.Maybe
import Data.Monoid hiding(getProduct)
import Data.List(sortBy)
import qualified Data.Map as Map hiding(map)
import qualified Data.Set as Set hiding(map)
import C.Prims
import Data.Binary
import Data.DeriveTH
import Doc.DocLike as D
import Doc.PPrint
import Doc.Pretty
import E.Binary()
import E.E
import E.Show
import E.Subst
import E.Traverse
import E.TypeCheck
import E.Values
import FrontEnd.Class(instanceName)
import FrontEnd.HsSyn
import FrontEnd.SrcLoc
import FrontEnd.Syn.Traverse
import FrontEnd.Tc.Type
import GenUtil
import Info.Types
import Name.Id
import Name.Name as Name
import Name.Names
import Name.VConsts
import PackedString
import Support.CanType
import Support.FreeVars
import Support.MapBinaryInstance
import Support.Unparse
import Util.HasSize
import Util.SameShape
import Util.SetLike as S
import Util.VarName
import qualified Cmm.Op as Op
import qualified Util.Graph as G
import qualified Util.Seq as Seq
tipe' (TAp t1 t2) = liftM2 eAp (tipe' t1) (tipe' t2)
tipe' (TArrow t1 t2) = do
t1' <- tipe' t1
t2' <- tipe' t2
return $ EPi (tVr emptyId (t1')) t2'
tipe' (TCon (Tycon n k)) | Just n' <- Map.lookup n primitiveAliases = return $ ELit litCons { litName = n', litType = kind k }
tipe' (TCon (Tycon n k)) = return $ ELit litCons { litName = n, litType = kind k }
tipe' (TVar tv@Tyvar { tyvarKind = k}) = do
v <- lookupName tv
return $ EVar $ tVr v (kind k)
tipe' (TForAll [] (_ :=> t)) = tipe' t
tipe' (TExists [] (_ :=> t)) = tipe' t
tipe' (TForAll xs (_ :=> t)) = do
xs' <- flip mapM xs $ \tv -> do
v <- newName (map anonymous [35 .. ]) () tv
return $ tVr v (kind $ tyvarKind tv)
t' <- tipe' t
return $ foldr EPi t' xs'
tipe' ~(TExists xs (_ :=> t)) = do
xs' <- flip mapM xs $ \tv -> do
return $ (kind $ tyvarKind tv)
t' <- tipe' t
return $ ELit litCons { litName = unboxedNameTuple TypeConstructor (length xs' + 1), litArgs = (t':xs'), litType = eHash }
kind (KBase KUTuple) = eHash
kind (KBase KHash) = eHash
kind (KBase Star) = eStar
kind (KBase (KNamed t)) = ESort (ESortNamed t)
kind (Kfun k1 k2) = EPi (tVr emptyId (kind k1)) (kind k2)
kind k = error $ "DataConstructors.kind: cannot convert " ++ show k
data AliasType = ErasedAlias | RecursiveAlias
deriving(Eq,Ord,Show)
data DataFamily =
DataAbstract
| DataNone
| DataPrimitive
| DataEnum !Int
| DataNormal [Name]
| DataAlias !AliasType
deriving(Eq,Ord,Show)
data Constructor = Constructor {
conName :: Name,
conType :: E,
conExpr :: E,
conOrigSlots :: [Slot],
conInhabits :: Name,
conVirtual :: Maybe [Name],
conChildren :: DataFamily,
conCTYPE :: Maybe ExtType
} deriving(Show)
data Slot =
SlotNormal E
| SlotUnpacked E !Name [E]
| SlotExistential TVr
deriving(Eq,Ord,Show)
mapESlot f (SlotExistential t) = SlotExistential t { tvrType = f (tvrType t) }
mapESlot f (SlotNormal e) = SlotNormal $ f e
mapESlot f (SlotUnpacked e n es) = SlotUnpacked (f e) n (map f es)
conSlots s = getSlots $ conOrigSlots s
getSlots ss = concatMap f ss where
f (SlotNormal e) = [e]
f (SlotUnpacked _ _ es) = es
f (SlotExistential e) = [tvrType e]
getHsSlots ss = map f ss where
f (SlotNormal e) = e
f (SlotUnpacked e _ es) = e
f (SlotExistential e) = tvrType e
newtype DataTable = DataTable (Map.Map Name Constructor)
deriving(Monoid)
instance Binary DataTable where
put (DataTable dt) = putMap dt
get = fmap DataTable getMap
emptyConstructor = Constructor {
conName = error "emptyConstructor.conName",
conType = Unknown,
conOrigSlots = [],
conExpr = Unknown,
conInhabits = error "emptyConstructor.conInhabits",
conVirtual = Nothing,
conCTYPE = Nothing,
conChildren = DataNone
}
instance HasSize DataTable where
size (DataTable d) = Map.size d
getConstructor :: Monad m => Name -> DataTable -> m Constructor
getConstructor n _ | isJust me = return (emptyConstructor {
conName = n, conType = e,
conExpr = foldr ELam (foldl eAp (mktBox e) (map EVar tvrs)) tvrs,
conInhabits = s_Star, conOrigSlots = map SlotNormal sts }) where
sts = map tvrType ss
tvrs = [ tvr { tvrIdent = i , tvrType = t } | i <- anonymousIds | t <- sts ]
(_,ss) = fromPi e
me@(~(Just e)) = fromConjured modBox n `mplus` fromConjured modAbsurd n
getConstructor n _ | RawType <- nameType n = return $ primitiveConstructor n
getConstructor n _ | Just v <- fromUnboxedNameTuple n, DataConstructor <- nameType n = return $ snd $ tunboxedtuple v
getConstructor n _ | Just v <- fromUnboxedNameTuple n, TypeConstructor <- nameType n = return $ fst $ tunboxedtuple v
getConstructor n (DataTable map) = case Map.lookup n map of
Just x -> return x
Nothing -> fail $ "getConstructor: " ++ show (nameType n,n)
getProduct :: Monad m => DataTable -> E -> m Constructor
getProduct dataTable e | (ELit LitCons { litName = cn }) <-
followAliases dataTable e, Just c <- getConstructor cn dataTable = f c where
f c | DataNormal [x] <- conChildren c = getConstructor x dataTable
| otherwise = fail "Not Product type"
getProduct _ _ = fail "Not Product type"
tunboxedtuple :: Int -> (Constructor,Constructor)
tunboxedtuple n = (typeCons,dataCons) where
dataCons = emptyConstructor {
conName = dc,
conType = dtipe,
conOrigSlots = map (SlotNormal . EVar) typeVars,
conExpr = foldr ($) (ELit litCons
{ litName = dc
, litArgs = map EVar vars
, litType = ftipe
}) (map ELam vars),
conInhabits = tc
}
typeCons = emptyConstructor {
conName = tc,
conType = foldr EPi eHash (replicate n tvr { tvrType = eStar }),
conOrigSlots = replicate n (SlotNormal eStar),
conExpr = tipe,
conInhabits = s_Hash,
conChildren = DataNormal [dc]
}
dc = unboxedNameTuple DataConstructor n
tc = unboxedNameTuple TypeConstructor n
tipe = foldr ELam ftipe typeVars
typeVars = take n [ tvr { tvrType = eStar, tvrIdent = v } | v <- anonymousIds ]
vars = [ tvr { tvrType = EVar t, tvrIdent = v } | v <- map anonymous [ n + 8, n + 9 ..] | t <- typeVars ]
ftipe = ELit (litCons { litName = tc, litArgs = map EVar typeVars, litType = eHash })
dtipe = foldr EPi (foldr EPi ftipe [ v { tvrIdent = emptyId } | v <- vars]) typeVars
tAbsurd k = ELit (litCons {
litName = nameConjured modAbsurd k, litArgs = [], litType = k })
mktBox k = ELit (litCons {
litName = nameConjured modBox k, litArgs = [],
litType = k, litAliasFor = af }) where
af = case k of
EPi TVr { tvrType = t1 } t2 -> Just (ELam tvr { tvrType = t1 } (mktBox t2))
_ -> Nothing
tarrow = emptyConstructor {
conName = tc_Arrow,
conType = EPi (tVr emptyId eStar) (EPi (tVr emptyId eStar) eStar),
conOrigSlots = [SlotNormal eStar,SlotNormal eStar],
conExpr = ELam (tVr va1 eStar) (ELam (tVr va2 eStar) (EPi (tVr emptyId (EVar $ tVr va1 eStar)) (EVar $ tVr va2 eStar))),
conInhabits = s_Star,
conChildren = DataAbstract
}
primitiveConstructor name = emptyConstructor {
conName = name,
conType = eHash,
conExpr = ELit (litCons { litName = name, litArgs = [], litType = eHash }),
conInhabits = s_Hash,
conChildren = DataPrimitive
}
sortName :: ESort -> Name
sortName s = f s where
f EStar = s_Star
f EBang = s_Bang
f EHash = s_Hash
f ETuple = s_Tuple
f EHashHash = s_HashHash
f EStarStar = s_StarStar
f (ESortNamed n) = n
sortConstructor name ss = emptyConstructor {
conName = name,
conType = ESort ss,
conExpr = ESort (ESortNamed name),
conInhabits = sortName ss
}
typesCompatable :: forall m . Monad m => E -> E -> m ()
typesCompatable a b = f etherealIds a b where
f :: [Id] -> E -> E -> m ()
f _ (ESort a) (ESort b) = when (a /= b) $ fail $ "Sorts don't match: " ++ pprint (ESort a,ESort b)
f _ (EVar a) (EVar b) = when (a /= b) $ fail $ "Vars don't match: " ++ pprint (a,b)
f c (ELit (LitCons { litAliasFor = Just af, litArgs = as })) b = do
f c (foldl eAp af as) b
f c a (ELit (LitCons { litAliasFor = Just af, litArgs = as })) = do
f c a (foldl eAp af as)
f c (ELit LitCons { litName = n, litArgs = xs, litType = t }) (ELit LitCons { litName = n', litArgs = xs', litType = t' }) | n == n' = do
f c t t'
when (not $ sameShape1 xs xs') $ fail "Arg lists don't match"
zipWithM_ (f c) xs xs'
f c (EAp a b) (EAp a' b') = do
f c a a'
f c b b'
f c (ELam va ea) (ELam vb eb) = lam va ea vb eb c
f c (EPi va ea) (EPi vb eb) = lam va ea vb eb c
f c (EPi (TVr { tvrIdent = eid, tvrType = a}) b) (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t })) | eid == emptyId, conName tarrow == n, t == eStar = do
f c a a'
f c b b'
f c (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t })) (EPi (TVr { tvrIdent = eid, tvrType = a}) b) | eid == emptyId, conName tarrow == n, t == eStar = do
f c a a'
f c b b'
f _ a b | boxCompat a b || boxCompat b a = return ()
f _ a b = fail $ "Types don't match:" ++ pprint (a,b)
lam :: TVr -> E -> TVr -> E -> [Id] -> m ()
lam va ea vb eb ~(c:cs) = do
f (c:cs) (tvrType va) (tvrType vb)
f cs (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb)
boxCompat (ELit (LitCons { litName = n })) t | Just e <- fromConjured modBox n = e == getType t
boxCompat _ _ = False
extractPrimitive :: Monad m => DataTable -> E -> m (E,(ExtType,E))
extractPrimitive dataTable e = case followAliases dataTable (getType e) of
st@(ELit LitCons { litName = c, litArgs = [], litType = t })
| t == eHash -> return (e,(ExtType (packString $ show c),st))
| otherwise -> do
Constructor { conChildren = DataNormal [cn] } <- getConstructor c dataTable
Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable
(ELit LitCons { litName = n, litArgs = []}) <- return $ followAliases dataTable st
let tvra = tVr vn st
(vn:_) = newIds (freeIds e)
return (eCase e [Alt (litCons { litName = cn, litArgs = [tvra],
litType = (getType e) }) (EVar tvra)] Unknown,(ExtType (packString $ show n),st))
e' -> fail $ "extractPrimitive: " ++ show (e,e')
boxPrimitive ::
Monad m
=> DataTable
-> E
-> E
-> m (E,(ExtType,E))
boxPrimitive dataTable e et = case followAliases dataTable et of
st@(ELit LitCons { litName = c, litArgs = [], litType = t })
| t == eHash -> return (e,(ExtType . packString $ show c,st))
| otherwise -> do
Constructor { conChildren = DataNormal [cn] } <- getConstructor c dataTable
Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable
(ELit LitCons { litName = n, litArgs = []}) <- return $ followAliases dataTable st
let tvra = tVr vn st
(vn:_) = newIds (freeVars (e,et))
if isManifestAtomic e then
return $ (ELit litCons { litName = cn, litArgs = [e], litType = et },(ExtType . packString $ show n,st))
else
return $ (eStrictLet tvra e $ ELit litCons { litName = cn, litArgs = [EVar tvra], litType = et },(ExtType . packString $ show n,st))
e' -> fail $ "boxPrimitive: " ++ show (e,e')
extractIO :: Monad m => E -> m E
extractIO e = f e where
f (ELit LitCons { litName = c, litArgs = [x] }) | c == tc_IO = return x
f (ELit LitCons { litAliasFor = Just af, litArgs = as }) = f (foldl eAp af as)
f _ = fail "extractIO: not an IO type"
extractIO' :: E -> ([E],Bool,E)
extractIO' e = f e [] where
f (ELit LitCons { litName = c, litArgs = [x] }) rs | c == tc_IO = (reverse rs, True,x)
f (ELit LitCons { litName = c, litArgs = [_,x] }) rs | c == tc_ST = (reverse rs, True,x)
f (expandAlias -> Just t) rs = f t rs
f (fromPi -> (fromUnboxedTuple -> Just [s',x],[getType -> s''])) rs
| isState_ s' && isState_ s'' = (reverse rs, True,x)
f (EPi v e) rs = f e (getType v:rs)
f e rs = (reverse rs, False,e)
data ExtTypeInfo
= ExtTypeVoid
| ExtTypeRaw ExtType
| ExtTypeBoxed Name E ExtType
extTypeInfoExtType (ExtTypeRaw et) = et
extTypeInfoExtType (ExtTypeBoxed _ _ et) = et
extTypeInfoExtType ExtTypeVoid = "void"
lookupExtTypeInfo :: Monad m => DataTable -> E -> m ExtTypeInfo
lookupExtTypeInfo dataTable oe = f Set.empty oe where
f :: Monad m => Set.Set Name -> E -> m ExtTypeInfo
f _ e@(ELit LitCons { litName = c }) | c == tc_Unit || c == tc_State_ = return ExtTypeVoid
f seen e@(ELit LitCons { litName = c, litArgs = [ta] }) | c == tc_Ptr = do
ExtTypeBoxed b t _ <- g seen e
case f seen ta of
Just (ExtTypeBoxed _ _ (ExtType et)) -> return $ ExtTypeBoxed b t (ExtType $ et `mappend` "*")
Just (ExtTypeRaw (ExtType et)) -> return $ ExtTypeBoxed b t (ExtType $ et `mappend` "*")
_ -> return $ ExtTypeBoxed b t "HsPtr"
f seen e@(ELit LitCons { litName = c, litArgs = [ta] }) | c == tc_Complex = do
case f seen ta of
Just (ExtTypeRaw (ExtType et)) -> return $ ExtTypeRaw (ExtType $ "_Complex " `mappend` et)
_ -> fail "invalid _Complex type"
f seen e@(ELit LitCons { litName = c }) | Just (conCTYPE -> Just et) <- getConstructor c dataTable = do
return $ case g seen e of
Just (ExtTypeBoxed b t _) -> ExtTypeBoxed b t et
Just ExtTypeVoid -> ExtTypeVoid
_ -> ExtTypeRaw et
f seen e = g seen e
g _ (ELit LitCons { litName = c })
| Just et <- Map.lookup c rawExtTypeMap = return (ExtTypeRaw et)
g _ (ELit LitCons { litName = c, litAliasFor = Nothing })
| Just Constructor { conChildren = DataNormal [cn] } <- getConstructor c dataTable,
Just Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable,
Just (ExtTypeRaw et) <- lookupExtTypeInfo dataTable st = return $ ExtTypeBoxed cn st et
g seen e@(ELit LitCons { litName = n }) | Just e' <- followAlias dataTable e,
n `Set.notMember` seen = f (Set.insert n seen) e'
g _ e = fail $ "lookupExtTypeInfo: " ++ show (oe,e)
expandAlias :: Monad m => E -> m E
expandAlias (ELit LitCons { litAliasFor = Just af, litArgs = as }) = return (foldl eAp af as)
expandAlias _ = fail "expandAlias: not alias"
followAlias :: Monad m => DataTable -> E -> m E
followAlias _ (ELit LitCons { litAliasFor = Just af, litArgs = as }) = return (foldl eAp af as)
followAlias _ _ = fail "followAlias: not alias"
followAliases :: DataTable -> E -> E
followAliases _dataTable e = f e where
f (ELit LitCons { litAliasFor = Just af, litArgs = as }) = f (foldl eAp af as)
f e = e
dataTablePrims = DataTable $ Map.fromList ([ (conName x,x) | x <- [tarrow] ])
deriveClasses :: IdMap Comb -> DataTable -> [(SrcLoc,Name,Name)] -> [(TVr,E)]
deriveClasses cmap dt@(DataTable mp) ctd = concatMap f ctd where
f (_,cd,t) | Just c <- getConstructor t dt, TypeConstructor == nameType (conName c), Just is <- conVirtual c = g is c cd
f _ = []
g is c cl = h cl where
lupvar v = EVar (combHead comb) where
Just comb = mlookup (toId v) cmap
typ = conExpr c
DataNormal [con] = conChildren c
Just conr = getConstructor con (DataTable mp)
[it@(ELit LitCons { litName = it_name })] = conSlots conr
Just itr = getConstructor it_name (DataTable mp)
DataEnum mv = conChildren itr
v1 = tvr { tvrIdent = anonymous 1, tvrType = typ }
v2 = tvr { tvrIdent = anonymous 2, tvrType = typ }
i1 = tvr { tvrIdent = anonymous 3, tvrType = it }
i2 = tvr { tvrIdent = anonymous 4, tvrType = it }
b3 = tvr { tvrIdent = anonymous 5, tvrType = tBoolzh }
val1 = tvr { tvrIdent = anonymous 7, tvrType = typ }
unbox e = ELam v1 (ELam v2 (ec (EVar v1) i1 (ec (EVar v2) i2 e))) where
ec v i e = eCase v [Alt (litCons { litName = con, litArgs = [i], litType = typ }) e] Unknown
h cl | cl == class_Eq = [mkCmpFunc v_equals Op.Eq]
h cl | cl == class_Ord = [
mkCmpFunc v_geq Op.UGte,
mkCmpFunc v_leq Op.ULte,
mkCmpFunc v_lt Op.ULt,
mkCmpFunc v_gt Op.UGt]
h cl | Just ans <- lookup cl mthds = ans where
mthds = [(class_Enum,[
(iv_te,ib_te),
(iv_fe,ib_fe),
iv v_succ succ_body,
iv v_pred pred_body,
iv v_enumFrom from_body,
iv v_enumFromTo fromTo_body,
iv v_enumFromThen fromThen_body,
iv v_enumFromThenTo fromThenTo_body
]),
(class_Ix,[
iv v_range range_body,
iv v_index index_body
])]
iv_te = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName v_toEnum (nameName $ conName c), tvrType = getType ib_te }
iv_fe = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName v_fromEnum (nameName $ conName c), tvrType = getType ib_fe }
iv fname body = (setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName fname (nameName $ conName c), tvrType = getType body },body)
succ_body = foldl EAp (lupvar v_enum_succ) [typ, box, debox, max]
pred_body = foldl EAp (lupvar v_enum_pred) [typ, box, debox]
from_body = foldl EAp (lupvar v_enum_from) [typ, box, debox, max]
fromTo_body = foldl EAp (lupvar v_enum_fromTo) [typ, box, debox]
fromThen_body = foldl EAp (lupvar v_enum_fromThen) [typ, box, debox, max]
fromThenTo_body = foldl EAp (lupvar v_enum_fromThenTo) [typ, box, debox]
range_body = foldl EAp (lupvar v_ix_range) [typ, box, debox]
index_body = foldl EAp (lupvar v_ix_index) [typ, box, debox]
ib_te = foldl EAp (lupvar v_enum_toEnum) [typ, box, toEzh (mv 1)]
ib_fe = ELam val1 (create_uintegralCast_toInt con tEnumzh (EVar val1))
max = ELit (LitInt (fromIntegral $ mv 1) tEnumzh)
box = ELam i1 (ELit (litCons { litName = con, litArgs = [EVar i1], litType = typ }))
debox = ELam v1 (ec (EVar v1) i1 (EVar i1)) where
ec v i e = eCase v [Alt (litCons { litName = con, litArgs = [i], litType = typ }) e] Unknown
h _ = []
mkCmpFunc fname op = (iv_eq,ib_eq) where
ib_eq = unbox (eStrictLet b3 (oper_IIB op (EVar i1) (EVar i2)) (ELit (litCons { litName = dc_Boolzh, litArgs = [EVar b3], litType = tBool })))
iv_eq = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName fname (nameName $ conName c), tvrType = getType ib_eq }
oper_IIB op a b = EPrim (Op (Op.BinOp op Op.bits16 Op.bits16) Op.bits16) [a,b] tBoolzh
create_integralCast conv c1 t1 c2 t2 e t = eCase e [Alt (litCons { litName = c1, litArgs = [tvra], litType = te }) cc] Unknown where
te = getType e
ELit LitCons { litName = n1, litArgs = [] } = t1
ELit LitCons { litName = n2, litArgs = [] } = t2
Just n1' = nameToOpTy n1
Just n2' = nameToOpTy n2
tvra = tVr va2 t1
tvrb = tVr va3 t2
cc = if n1 == n2 then ELit (litCons { litName = c2, litArgs = [EVar tvra], litType = t }) else
eStrictLet tvrb (EPrim (Op (Op.ConvOp conv n1') n2') [EVar tvra] t2) (ELit (litCons { litName = c2, litArgs = [EVar tvrb], litType = t }))
nameToOpTy n = do RawType <- return $ nameType n; Op.readTy (show n)
create_uintegralCast_toInt c1 t1 e = create_integralCast Op.U2U c1 t1 dc_Int tIntzh e tInt
updateLit :: DataTable -> Lit e t -> Lit e t
updateLit _ l@LitInt {} = l
updateLit dataTable lc@LitCons { litAliasFor = Just {} } = lc
updateLit dataTable lc@LitCons { litName = n } = lc { litAliasFor = af } where
af = do
Constructor { conChildren = DataNormal [x], conOrigSlots = cs } <- getConstructor n dataTable
Constructor { conChildren = DataAlias ErasedAlias, conOrigSlots = [SlotNormal sl] } <- getConstructor x dataTable
return (foldr ELam sl [ tVr i s | s <- getSlots cs | i <- anonymousIds])
removeNewtypes :: DataTable -> E -> E
removeNewtypes dataTable e = runIdentity (f e) where
f ec@ECase {} = emapEGH f f return ec { eCaseAlts = map g (eCaseAlts ec) } where
g (Alt l e) = Alt (gl $ updateLit dataTable l) e
f (ELit l) = emapEGH f f return (ELit (gl $ updateLit dataTable l))
f e = emapEGH f f return e
gl lc@LitCons { litAliasFor = Just e } = lc { litAliasFor = Just $ removeNewtypes dataTable e }
gl l = l
collectDeriving :: [HsDecl] -> [(SrcLoc,Name,Name)]
collectDeriving ds = concatMap f ds where
f decl@HsDataDecl {} = g decl
f decl@HsDeclDeriving {} = h decl
f _ = []
g decl = [(hsDeclSrcLoc decl, toName ClassName c,
toName TypeConstructor (hsDeclName decl)) | c <- hsDeclDerives decl ]
h decl@(hsDeclClassHead -> ch) | [(ltc -> Just t)] <- hsClassHeadArgs ch = [(hsDeclSrcLoc decl,toName ClassName (hsClassHead ch), t)] where
ltc (HsTyApp t1 _) = ltc t1
ltc (HsTyCon n) = Just (toName TypeConstructor n)
ltc x = Nothing
h _ = []
toDataTable :: (Map.Map Name Kind) -> (Map.Map Name Type) -> [HsDecl] -> DataTable -> DataTable
toDataTable km cm ds currentDataTable = newDataTable where
newDataTable = DataTable (Map.mapWithKey fixupMap $
Map.fromList [ (conName x,procNewTypes x) | x <- ds', conName x `notElem` keys primitiveAliases ])
fullDataTable = (newDataTable `mappend` currentDataTable)
procNewTypes c = c { conExpr = f (conExpr c), conType = f (conType c), conOrigSlots = map (mapESlot f) (conOrigSlots c) } where
f = removeNewtypes fullDataTable
fixupMap k _ | Just n <- getConstructor k dataTablePrims = n
fixupMap _ n = n
ds' = Seq.toList $ execWriter (mapM_ f ds)
newtypeLoopBreakers = map fst $ fst $ G.findLoopBreakers (const 0) (const True) (G.newGraph newtypeDeps fst snd) where
newtypeDeps = [ (n,concatMap (fm . hsBangType) $ hsConDeclArgs c) |
HsDataDecl { hsDeclDeclType = DeclTypeNewtype, hsDeclName = n, hsDeclCons = (head -> c) } <- ds ]
fm t = execWriter $ f t
f HsTyCon { hsTypeName = n } = tell [n]
f t = traverseHsType_ f t
f decl@HsDataDecl { hsDeclDeclType = DeclTypeNewtype, hsDeclName = nn, hsDeclCons = cs } =
dt decl (if nn `elem` newtypeLoopBreakers then DataAlias RecursiveAlias else DataAlias ErasedAlias) cs
f decl@HsDataDecl { hsDeclDeclType = DeclTypeKind } = dkind decl
f decl@HsDataDecl { hsDeclCons = cs } = dt decl DataNone cs
f _ = return ()
dt decl DataNone cs@(_:_:_) | all null (map hsConDeclArgs cs) = do
let virtualCons'@(fc:_) = map (makeData DataNone typeInfo) cs
typeInfo@(theType,_,_) = makeType decl (hsDeclCTYPE decl)
virt = Just (map conName virtualCons')
f (n,vc) = vc { conExpr = ELit (litCons { litName = consName, litArgs = [ELit (LitInt (fromIntegral n) rtype)], litType = conType vc }), conVirtual = virt }
virtualCons = map f (zip [(0 :: Int) ..] virtualCons')
consName = mapName (id,(++ "#")) $ toName DataConstructor (nameName (conName theType))
rtypeName = mapName (id,(++ "#")) $ toName TypeConstructor (nameName (conName theType))
rtype = ELit litCons { litName = rtypeName, litType = eHash, litAliasFor = Just tEnumzh }
dataCons = fc { conName = consName, conType = getType (conExpr dataCons), conOrigSlots = [SlotNormal rtype], conExpr = ELam (tVr (anonymous 3) rtype) (ELit (litCons { litName = consName, litArgs = [EVar (tVr (anonymous 6) rtype)], litType = conExpr theType })) }
rtypeCons = emptyConstructor {
conName = rtypeName,
conType = eHash,
conExpr = rtype,
conInhabits = s_Hash,
conChildren = DataEnum (length virtualCons)
}
tell (Seq.fromList virtualCons)
tell (Seq.singleton dataCons)
tell (Seq.singleton rtypeCons)
tell $ Seq.singleton theType { conChildren = DataNormal [consName], conVirtual = virt }
return ()
dt decl alias cs = do
let dataCons = map (makeData alias typeInfo) cs
typeInfo@(theType,_,_) = makeType decl (hsDeclCTYPE decl)
tell (Seq.fromList dataCons)
tell $ Seq.singleton theType { conChildren = DataNormal (map conName dataCons) }
dkind HsDataDecl { .. } = do
tell $ Seq.singleton $ (sortConstructor hsDeclName EHashHash) {
conChildren = DataNormal (map hsConDeclName hsDeclCons) }
flip mapM_ hsDeclCons $ \ HsConDecl { .. } -> do
let Just theKind = kind `fmap` (Map.lookup hsConDeclName km)
(theTypeFKind,theTypeKArgs') = fromPi theKind
theTypeArgs = [ tvr { tvrIdent = x } | tvr <- theTypeKArgs' | x <- anonymousIds ]
theTypeExpr = ELit litCons {
litName = hsConDeclName,
litArgs = map EVar theTypeArgs,
litType = theTypeFKind }
tell $ Seq.singleton emptyConstructor {
conName = hsConDeclName,
conType = theKind,
conOrigSlots = map (SlotNormal . tvrType) theTypeArgs,
conExpr = foldr ($) theTypeExpr (map ELam theTypeArgs),
conInhabits = hsDeclName
}
dkind _ = error "dkind passed bad decl"
makeData alias (theType,theTypeArgs,theTypeExpr) x = theData where
theData = emptyConstructor {
conName = dataConsName,
conType =foldr ($) (getType theExpr) (map EPi theTypeArgs),
conOrigSlots = origSlots,
conExpr = theExpr,
conInhabits = conName theType,
conChildren = alias
}
dataConsName = toName Name.DataConstructor (hsConDeclName x)
theExpr = foldr ELam (strictize tslots $ ELit litCons { litName = dataConsName, litArgs = map EVar dvars, litType = theTypeExpr }) hsvars
strictize tslots con = E.Subst.subst tvr { tvrIdent = sillyId } Unknown $ f tslots con where
f (Left (v,False):rs) con = f rs con
f (Left (v,True):rs) con = eStrictLet v (EVar v) (f rs con)
f (Right (v,dc,rcs):rs) con = eCase (EVar v) [Alt pat (f rs con)] Unknown where
pat = litCons { litName = dc, litArgs = rcs, litType = (getType v) }
f [] con = con
(ELit LitCons { litArgs = thisTypeArgs }, origArgs) = fromPi $ runVarName $ do
let (vs,ty) = case Map.lookup dataConsName cm of Just (TForAll vs (_ :=> ty)) -> (vs,ty); ~(Just ty) -> ([],ty)
mapM_ (newName anonymousIds ()) vs
tipe' ty
subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = p }) | EVar tv <- thisTypeArgs | p <- anonymousIds ]
origSlots = map SlotExistential existentials ++ map f tslots where
f (Left (e,_)) = SlotNormal (getType e)
f (Right (e,n,es)) = SlotUnpacked (getType e) n (map getType es)
hsvars = existentials ++ map f tslots where
f (Left (e,_)) = e
f (Right (e,_,_)) = e
dvars = existentials ++ concatMap f tslots where
f (Left (e,_)) = [e]
f (Right (_,_,es)) = es
tslots = f (newIds fvset) (map isHsBangedTy (hsConDeclArgs x)) origArgs where
f (i:is) (False:bs) (e:es) = Left (e { tvrIdent = i, tvrType = subst (tvrType e) },False):f is bs es
f (i:j:is) (True:bs) (e:es) = maybe (Left (e { tvrIdent = i, tvrType = subst (tvrType e) },True):f is bs es) id $ g e (tvrType e) where
g e te = do
ELit LitCons { litName = n } <- return $ followAliases fullDataTable te
Constructor { conChildren = DataNormal [dc] } <- getConstructor n fullDataTable
con <- getConstructor dc fullDataTable
case (conChildren con,slotTypes fullDataTable dc te) of
(DataAlias ErasedAlias,[nt]) -> g e nt
(_,[st]) -> do
let nv = tvr { tvrIdent = j, tvrType = st }
return $ Right (e { tvrIdent = i, tvrType = subst (tvrType e)},dc,[nv]):f is bs es
_ -> fail "not unboxable"
f _ [] [] = []
f _ _ _ = error "DataConstructors.tslots"
fvset = freeVars (thisTypeArgs,origArgs) `mappend` fromList (take (length theTypeArgs + 2) anonymousIds)
existentials = values $ freeVars (map getType origArgs) S.\\ (freeVars thisTypeArgs :: IdMap TVr)
makeType decl ct = (theType,theTypeArgs,theTypeExpr) where
theTypeName = toName Name.TypeConstructor (hsDeclName decl)
Just theKind = kind `fmap` (Map.lookup theTypeName km)
(theTypeFKind,theTypeKArgs') = fromPi theKind
theTypeArgs = [ tvr { tvrIdent = x } | tvr <- theTypeKArgs' | x <- anonymousIds ]
theTypeExpr = ELit litCons { litName = theTypeName, litArgs = map EVar theTypeArgs, litType = theTypeFKind }
theType = emptyConstructor {
conCTYPE = fmap (ExtType . packString) ct,
conExpr = foldr ($) theTypeExpr (map ELam theTypeArgs),
conInhabits = if theTypeFKind == eStar then s_Star else s_Hash,
conName = theTypeName,
conOrigSlots = map (SlotNormal . tvrType) theTypeArgs,
conType = theKind,
conVirtual = Nothing
}
isHsBangedTy HsBangedTy {} = True
isHsBangedTy _ = False
getConstructorArities :: DataTable -> [(Name,Int)]
getConstructorArities (DataTable dt) = [ (n,length $ conSlots c) | (n,c) <- Map.toList dt]
constructionExpression ::
DataTable
-> Name
-> E
-> E
constructionExpression dataTable n typ@(ELit LitCons { litName = pn, litArgs = xs })
| DataAlias ErasedAlias <- conChildren mc = ELam var (EVar var)
| DataAlias RecursiveAlias <- conChildren mc = let var' = var { tvrType = st } in ELam var' (prim_unsafeCoerce (EVar var') typ)
| pn == conName pc = sub (conExpr mc) where
~[st] = slotTypes dataTable n typ
var = tvr { tvrIdent = vid, tvrType = typ }
(vid:_) = newIds (freeVars typ)
Just mc = getConstructor n dataTable
Just pc = getConstructor (conInhabits mc) dataTable
sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ]
constructionExpression wdt n e | Just fa <- followAlias wdt e = constructionExpression wdt n fa
constructionExpression _ n e = error $ "constructionExpression: error in " ++ show n ++ ": " ++ show e
deconstructionExpression ::
UniqueProducer m
=> DataTable
-> Name
-> E
-> [TVr]
-> E
-> m (Alt E)
deconstructionExpression dataTable name typ@(ELit LitCons { litName = pn, litArgs = xs }) vs e | pn == conName pc = ans where
Just mc = getConstructor name dataTable
Just pc = getConstructor (conInhabits mc) dataTable
sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ]
ans = case conVirtual mc of
Just _ -> return $ let ELit LitCons { litArgs = [ELit (LitInt n t)] } = conExpr mc in Alt (LitInt n t) e
Nothing -> do
let f vs (SlotExistential t:ss) rs ls = f vs ss (t:rs) ls
f (v:vs) (SlotNormal _:ss) rs ls = f vs ss (v:rs) ls
f (v:vs) (SlotUnpacked e n es:ss) rs ls = do
let g t = do
s <- newUniq
return $ tVr (anonymous s) t
as <- mapM g (map sub es)
f vs ss (reverse as ++ rs) ((v,ELit litCons { litName = n, litArgs = map EVar as, litType = sub e }):ls)
f [] [] rs ls = return $ Alt (litCons { litName = name, litArgs = reverse rs, litType = typ }) (eLetRec ls e)
f _ _ _ _ = error "DataConstructors.deconstructuonExpression.f"
f vs (conOrigSlots mc) [] []
deconstructionExpression wdt n ty vs e | Just fa <- followAlias wdt ty = deconstructionExpression wdt n fa vs e
deconstructionExpression _ n e _ _ = error $ "deconstructionExpression: error in " ++ show n ++ ": " ++ show e
slotTypes ::
DataTable
-> Name
-> E
-> [E]
slotTypes wdt n (ELit LitCons { litName = pn, litArgs = xs, litType = _ })
| pn == conName pc = [sub x | x <- conSlots mc ]
where
Identity mc = getConstructor n wdt
Identity pc = getConstructor (conInhabits mc) wdt
sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ]
slotTypes wdt n kind
| sortKindLike kind, (e,ts) <- fromPi kind = take (length (conSlots mc) length ts) (conSlots mc)
where Identity mc = getConstructor n wdt
slotTypes wdt n e | Just fa <- followAlias wdt e = slotTypes wdt n fa
slotTypes _ n e = error $ "slotTypes: error in " ++ show n ++ ": " ++ show e
slotTypesHs ::
DataTable
-> Name
-> E
-> [E]
slotTypesHs wdt n (ELit LitCons { litName = pn, litArgs = xs, litType = _ })
| pn == conName pc = [sub x | x <- getHsSlots $ conOrigSlots mc ]
where
Identity mc = getConstructor n wdt
Identity pc = getConstructor (conInhabits mc) wdt
sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ]
slotTypesHs wdt n kind
| sortKindLike kind, (e,ts) <- fromPi kind = take (length (conSlots mc) length ts) (conSlots mc)
where Identity mc = getConstructor n wdt
slotTypesHs wdt n e | Just fa <- followAlias wdt e = slotTypes wdt n fa
slotTypesHs _ n e = error $ "slotTypesHs: error in " ++ show n ++ ": " ++ show e
showDataTable (DataTable mp) = vcat xs where
c con = vcat [t,e,cs,vt,ih,ch,mc] where
t = text "::" <+> ePretty conType
e = text "=" <+> ePretty conExpr
cs = text "slots:" <+> tupled (map ePretty (conSlots con))
vt = text "virtual:" <+> tshow conVirtual
ih = text "inhabits:" <+> tshow conInhabits
ch = text "children:" <+> tshow conChildren
mc = text "CTYPE:" <+> tshow conCTYPE
Constructor { .. } = con
xs = [text x <+> hang 0 (c y) | (x,y) <- ds ]
ds = sortBy (\(x,_) (y,_) -> compare x y) [(show x,y) | (x,y) <- Map.toList mp]
samplePrimitiveDataTable :: DataTable
samplePrimitiveDataTable = DataTable $ Map.fromList [ (x,c) | x <- xs, c <- getConstructor x mempty] where
nt v = map (flip unboxedNameTuple (v::Int)) [DataConstructor, TypeConstructor]
xs = nt 0 ++ nt 3 ++ [nameConjured modAbsurd eStar,nameConjured modBox hs, nameConjured modAbsurd hs', nameConjured modBox hs',rt_bits16,rt_bits_ptr_]
hs = EPi (tVr emptyId eHash) eStar
hs' = tFunc eStar (tFunc (tFunc eStar eHash) eStar)
getSiblings :: DataTable -> Name -> Maybe [Name]
getSiblings dt n
| Just c <- getConstructor n dt, Just Constructor { conChildren = DataNormal cs } <- getConstructor (conInhabits c) dt = Just cs
| otherwise = Nothing
numberSiblings :: DataTable -> Name -> Maybe Int
numberSiblings dt n
| Just c <- getConstructor n dt, Just Constructor { conChildren = cc } <- getConstructor (conInhabits c) dt = case cc of
DataNormal ds -> Just $ length ds
DataEnum n -> Just n
_ -> Nothing
| otherwise = Nothing
onlyChild :: DataTable -> Name -> Bool
onlyChild dt n = isJust ans where
ans = do
c <- getConstructor n dt
case conChildren c of
DataNormal [_] -> return ()
_ -> do
c <- getConstructor (conInhabits c) dt
case conChildren c of
DataNormal [_] -> return ()
_ -> fail "not cpr"
pprintTypeOfCons :: (Monad m,DocLike a) => DataTable -> Name -> m a
pprintTypeOfCons dataTable name = do
c <- getConstructor name dataTable
return $ pprintTypeAsHs (conType c)
pprintTypeAsHs :: DocLike a => E -> a
pprintTypeAsHs e = unparse $ runVarName (f e) where
f e | e == eStar = return $ atom $ text "*"
| e == eHash = return $ atom $ text "#"
f (EPi (TVr { tvrIdent = eid, tvrType = t1 }) t2) | eid == emptyId = do
t1 <- f t1
t2 <- f t2
return $ t1 `arr` t2
f (ELit LitCons { litName = n, litArgs = as }) | (a:as') <- reverse as = f $ EAp (ELit litCons { litName = n, litArgs = reverse as' }) a
f (ELit LitCons { litName = n, litArgs = [] }) = return $ atom $ text $ show n
f (EAp a b) = do
a <- f a
b <- f b
return $ a `app` b
f (EVar v) = do
vo <- newLookupName ['a' .. ] () (tvrIdent v)
return $ atom $ char vo
f v | (e,ts@(_:_)) <- fromPi v = do
ts' <- mapM (newLookupName ['a'..] () . tvrIdent) ts
r <- f e
return $ fixitize (N,3) $ pop (text "forall" <+> hsep (map char ts') <+> text ". ") (atomize r)
f e = error $ "printTypeAsHs: " ++ show e
arr = bop (R,0) (space D.<> text "->" D.<> space)
app = bop (L,100) (text " ")
class Monad m => DataTableMonad m where
getDataTable :: m DataTable
getDataTable = return mempty
instance DataTableMonad Identity
primitiveAliases :: Map.Map Name Name
primitiveAliases = Map.fromList [
(tc_Bits1, rt_bool),
(tc_Bits8, rt_bits8),
(tc_Bits16, rt_bits16),
(tc_Bits32, rt_bits32),
(tc_Bits64, rt_bits64),
(tc_Bits128, rt_bits128),
(tc_BitsPtr, rt_bits_ptr_),
(tc_BitsMax, rt_bits_max_),
(tc_Float32, rt_float32),
(tc_Float64, rt_float64),
(tc_Float80, rt_float80),
(tc_Float128, rt_float128)
]
rawExtTypeMap :: Map.Map Name ExtType
rawExtTypeMap = Map.fromList [
(rt_bool, "bool"),
(rt_bits8, "uint8_t"),
(rt_bits16, "uint16_t"),
(rt_bits32, "uint32_t"),
(rt_bits64, "uint64_t"),
(rt_bits128, "uint128_t"),
(rt_bits_ptr_, "uintptr_t" ),
(rt_bits_max_, "uintmax_t"),
(rt_float32, "float"),
(rt_float64, "double"),
(rt_float80, "long double"),
(rt_float128, "__float128")
]
$(derive makeBinary ''AliasType)
$(derive makeBinary ''DataFamily)
$(derive makeBinary ''Constructor)
$(derive makeBinary ''Slot)