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,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 :: [Type] -> ([[Type]], Maybe Error)
calcGroupOrder types :: [Type]
types = [Type] -> [[Type]] -> ([[Type]], Maybe Error)
calcGroupOrder_rec [Type]
types []
calcGroupOrder_rec :: [Type]
-> [[Type]]
-> ([[Type]], Maybe Error)
calcGroupOrder_rec :: [Type] -> [[Type]] -> ([[Type]], Maybe Error)
calcGroupOrder_rec [] acc :: [[Type]]
acc = ([[Type]] -> [[Type]]
forall a. [a] -> [a]
reverse [[Type]]
acc, Maybe Error
forall a. Maybe a
Nothing)
calcGroupOrder_rec types :: [Type]
types acc :: [[Type]]
acc = do
let (layer :: [Type]
layer, rest :: [Type]
rest) = [Type] -> [Type] -> [Type] -> [Type] -> ([Type], [Type])
calcGroupOrder_iteration [Type]
types [] [] []
layer' :: [Type]
layer' = (Type -> Type -> Bool) -> [Type] -> [Type]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy Type -> Type -> Bool
eqType [Type]
layer
if [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
layer' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then ([[Type]] -> [[Type]]
forall a. [a] -> [a]
reverse [[Type]]
acc, Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ Int -> [Type] -> Error
OrderingFailedTypes ([[Type]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Type]]
acc) [Type]
rest)
else [Type] -> [[Type]] -> ([[Type]], Maybe Error)
calcGroupOrder_rec [Type]
rest ([Type]
layer'[Type] -> [[Type]] -> [[Type]]
forall a. a -> [a] -> [a]
:[[Type]]
acc)
calcGroupOrder_iteration :: [Type]
-> [Type]
-> [Type]
-> [Type]
-> ([Type], [Type])
calcGroupOrder_iteration :: [Type] -> [Type] -> [Type] -> [Type] -> ([Type], [Type])
calcGroupOrder_iteration [] checked :: [Type]
checked accepted :: [Type]
accepted rejected :: [Type]
rejected = ([Type]
accepted, [Type]
rejected)
calcGroupOrder_iteration (t :: Type
t:ts :: [Type]
ts) checked :: [Type]
checked accepted :: [Type]
accepted rejected :: [Type]
rejected = do
let args :: [Type]
args = Type -> [Type]
getDataConArgs Type
t
is_arg_somewhere :: Bool
is_arg_somewhere = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\t :: Type
t -> Type -> [Type] -> Bool
elemType Type
t [Type]
args) [Type]
checked Bool -> Bool -> Bool
|| (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\t :: Type
t -> Type -> [Type] -> Bool
elemType Type
t [Type]
args) [Type]
ts
if Bool
is_arg_somewhere
then [Type] -> [Type] -> [Type] -> [Type] -> ([Type], [Type])
calcGroupOrder_iteration [Type]
ts (Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
checked) [Type]
accepted (Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
rejected)
else [Type] -> [Type] -> [Type] -> [Type] -> ([Type], [Type])
calcGroupOrder_iteration [Type]
ts (Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
checked) (Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
accepted) [Type]
rejected
type TypeScope = (TyVar, Type)
substituteTyCon :: [TypeScope] -> Type -> Type
substituteTyCon :: [TypeScope] -> Type -> Type
substituteTyCon [] tc_app :: Type
tc_app = Type
tc_app
substituteTyCon type_scope :: [TypeScope]
type_scope old :: Type
old@(TyVarTy ty_var :: Var
ty_var)
= case (TypeScope -> Bool) -> [TypeScope] -> Maybe TypeScope
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(av :: Var
av,_) -> Var
av Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
ty_var) [TypeScope]
type_scope of
Just (_, new_type :: Type
new_type) -> Type
new_type
Nothing -> Type
old
substituteTyCon type_scope :: [TypeScope]
type_scope (TyConApp tc :: TyCon
tc args :: [Type]
args)
= TyCon -> [Type] -> Type
TyConApp TyCon
tc ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([TypeScope] -> Type -> Type
substituteTyCon [TypeScope]
type_scope) [Type]
args
substituteTyCon type_scope :: [TypeScope]
type_scope t :: Type
t = Type
t
getDataConArgs :: Type -> [Type]
getDataConArgs :: Type -> [Type]
getDataConArgs t :: Type
t
| Type -> Bool
isAlgType Type
t
, Just (tc :: TyCon
tc, ty_args :: [Type]
ty_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t
, [Var]
ty_vars <- TyCon -> [Var]
tyConTyVars TyCon
tc
= do
let type_scope :: [TypeScope]
type_scope = [Var] -> [Type] -> [TypeScope]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
ty_vars [Type]
ty_args
data_cons :: [Type]
data_cons = (DataCon -> [Type]) -> [DataCon] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataCon -> [Type]
dataConOrigArgTys ([DataCon] -> [Type]) -> [DataCon] -> [Type]
forall a b. (a -> b) -> a -> b
$ (AlgTyConRhs -> [DataCon]
visibleDataCons(AlgTyConRhs -> [DataCon])
-> (TyCon -> AlgTyConRhs) -> TyCon -> [DataCon]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.TyCon -> AlgTyConRhs
algTyConRhs) TyCon
tc
(Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([TypeScope] -> Type -> Type
substituteTyCon [TypeScope]
type_scope) [Type]
data_cons
| Bool
otherwise = []
groupBinds :: [[Type]]
-> [CoreBind]
-> ([[CoreBind]], Maybe Error)
groupBinds :: [[Type]] -> [CoreBind] -> ([[CoreBind]], Maybe Error)
groupBinds type_groups :: [[Type]]
type_groups binds :: [CoreBind]
binds = [[Type]]
-> [CoreBind] -> [[CoreBind]] -> ([[CoreBind]], Maybe Error)
groupBinds_rec [[Type]]
type_groups [CoreBind]
binds []
groupBinds_rec :: [[Type]]
-> [CoreBind]
-> [[CoreBind]]
-> ([[CoreBind]], Maybe Error)
groupBinds_rec :: [[Type]]
-> [CoreBind] -> [[CoreBind]] -> ([[CoreBind]], Maybe Error)
groupBinds_rec [] [] acc :: [[CoreBind]]
acc = ([[CoreBind]] -> [[CoreBind]]
forall a. [a] -> [a]
reverse [[CoreBind]]
acc,Maybe Error
forall a. Maybe a
Nothing)
groupBinds_rec (a :: [Type]
a:as :: [[Type]]
as) [] acc :: [[CoreBind]]
acc = ([[CoreBind]] -> [[CoreBind]]
forall a. [a] -> [a]
reverse [[CoreBind]]
acc,Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ SDoc -> Error
OtherError SDoc
msg)
where msg :: SDoc
msg = String -> SDoc
text "Could not find any bindings."
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "Is the second pass placed after main simplifier phases ?"
groupBinds_rec [] binds :: [CoreBind]
binds acc :: [[CoreBind]]
acc = ([[CoreBind]] -> [[CoreBind]]
forall a. [a] -> [a]
reverse [[CoreBind]]
acc,Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ Int -> [CoreBind] -> Error
OrderingFailedBinds ([[CoreBind]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[CoreBind]]
acc) [CoreBind]
binds)
groupBinds_rec (tg :: [Type]
tg:tgs :: [[Type]]
tgs) binds :: [CoreBind]
binds acc :: [[CoreBind]]
acc = do
let predicate :: CoreBind -> Bool
predicate (NonRec id :: Var
id _) = case Type -> Maybe Type
getGStorableType (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
id of
Just t :: Type
t -> Type
t Type -> [Type] -> Bool
`elemType` [Type]
tg
Nothing -> Bool
False
predicate (Rec _) = Bool
False
let (layer :: [CoreBind]
layer, rest :: [CoreBind]
rest) = (CoreBind -> Bool) -> [CoreBind] -> ([CoreBind], [CoreBind])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition CoreBind -> Bool
predicate [CoreBind]
binds
if [CoreBind] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreBind]
layer Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then ([[CoreBind]] -> [[CoreBind]]
forall a. [a] -> [a]
reverse [[CoreBind]]
acc, Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ Int -> [CoreBind] -> Error
OrderingFailedBinds ([[CoreBind]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[CoreBind]]
acc) [CoreBind]
rest)
else [[Type]]
-> [CoreBind] -> [[CoreBind]] -> ([[CoreBind]], Maybe Error)
groupBinds_rec [[Type]]
tgs [CoreBind]
rest ([CoreBind] -> [CoreBind]
forall a. [a] -> [a]
reverse [CoreBind]
layer[CoreBind] -> [[CoreBind]] -> [[CoreBind]]
forall a. a -> [a] -> [a]
:[[CoreBind]]
acc)