module Foreign.Storable.Generic.Plugin.Internal.GroupTypes
(
calcGroupOrder
, substituteTyCon
, getDataConArgs
, groupBinds
)
where
import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)
import Literal (Literal(..))
import Id (isLocalId, isGlobalId,Id)
import Var (Var(..))
import Name (getOccName,mkOccName)
import OccName (OccName(..), occNameString)
import qualified Name as N (varName)
import SrcLoc (noSrcSpan)
import Unique (getUnique)
import HscMain (hscCompileCoreExpr)
import HscTypes (HscEnv,ModGuts(..))
import CoreMonad (CoreM, SimplifierMode(..),CoreToDo(..), getHscEnv)
import BasicTypes (CompilerPhase(..))
import Type (isAlgType, splitTyConApp_maybe)
import TyCon (algTyConRhs, visibleDataCons)
import TyCoRep (Type(..), TyBinder(..))
import TysWiredIn (intDataCon)
import DataCon (dataConWorkId,dataConOrigArgTys)
import MkCore (mkWildValBinder)
import Outputable (cat, ppr, SDoc, showSDocUnsafe)
import Outputable (text, (<+>), ($$), nest)
import CoreMonad (putMsg, putMsgS)
import GHCi.RemoteTypes
import TyCon
import Type hiding (eqType)
import Unsafe.Coerce
import Data.List
import Data.Maybe
import Data.Either
import Debug.Trace
import Control.Monad.IO.Class
import Foreign.Storable.Generic.Plugin.Internal.Error
import Foreign.Storable.Generic.Plugin.Internal.Helpers
import Foreign.Storable.Generic.Plugin.Internal.Predicates
import Foreign.Storable.Generic.Plugin.Internal.Types
calcGroupOrder :: [Type] -> ([[Type]], Maybe Error)
calcGroupOrder types = calcGroupOrder_rec types []
calcGroupOrder_rec :: [Type]
-> [[Type]]
-> ([[Type]], Maybe Error)
calcGroupOrder_rec [] acc = (reverse acc, Nothing)
calcGroupOrder_rec types acc = do
let (layer, rest) = calcGroupOrder_iteration types [] [] []
layer' = nubBy eqType layer
if length layer' == 0
then (reverse acc, Just $ OrderingFailedTypes (length acc) rest)
else calcGroupOrder_rec rest (layer':acc)
calcGroupOrder_iteration :: [Type]
-> [Type]
-> [Type]
-> [Type]
-> ([Type], [Type])
calcGroupOrder_iteration [] checked accepted rejected = (accepted, rejected)
calcGroupOrder_iteration (t:ts) checked accepted rejected = do
let args = getDataConArgs t
is_arg_somewhere = any (\t -> elemType t args) checked || any (\t -> elemType t args) ts
if is_arg_somewhere
then calcGroupOrder_iteration ts (t:checked) accepted (t:rejected)
else calcGroupOrder_iteration ts (t:checked) (t:accepted) rejected
type TypeScope = (TyVar, Type)
substituteTyCon :: [TypeScope] -> Type -> Type
substituteTyCon [] tc_app = tc_app
substituteTyCon type_scope old@(TyVarTy ty_var)
= case find (\(av,_) -> av == ty_var) type_scope of
Just (_, new_type) -> new_type
Nothing -> old
substituteTyCon type_scope (TyConApp tc args)
= TyConApp tc $ map (substituteTyCon type_scope) args
substituteTyCon type_scope t = t
getDataConArgs :: Type -> [Type]
getDataConArgs t
| isAlgType t
, Just (tc, ty_args) <- splitTyConApp_maybe t
, ty_vars <- tyConTyVars tc
= do
let type_scope = zip ty_vars ty_args
data_cons = concatMap dataConOrigArgTys $ (visibleDataCons.algTyConRhs) tc
map (substituteTyCon type_scope) data_cons
| otherwise = []
groupBinds :: [[Type]]
-> [CoreBind]
-> ([[CoreBind]], Maybe Error)
groupBinds type_groups binds = groupBinds_rec type_groups binds []
groupBinds_rec :: [[Type]]
-> [CoreBind]
-> [[CoreBind]]
-> ([[CoreBind]], Maybe Error)
groupBinds_rec [] [] acc = (reverse acc,Nothing)
groupBinds_rec (a:as) [] acc = (reverse acc,Just $ OtherError msg)
where msg = text "Could not find any bindings."
$$ text "Is the second pass placed after main simplifier phases ?"
groupBinds_rec [] binds acc = (reverse acc,Just $ OrderingFailedBinds (length acc) binds)
groupBinds_rec (tg:tgs) binds acc = do
let predicate (NonRec id _) = case getGStorableType $ varType id of
Just t -> t `elemType` tg
Nothing -> False
predicate (Rec _) = False
let (layer, rest) = partition predicate binds
if length layer == 0
then (reverse acc, Just $ OrderingFailedBinds (length acc) rest)
else groupBinds_rec tgs rest (reverse layer:acc)