exference-1.6.0.0: src/Language/Haskell/Exference/Core/Internal/ExferenceNode.hs
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Language.Haskell.Exference.Core.Internal.ExferenceNode
( SearchNode (..)
, TGoal
, Scopes (..)
, Scope (..)
, ScopeId
, VarPBinding
, VarBinding (..)
, VarUsageMap
, varBindingApplySubsts
, varPBindingApplySubsts
, goalApplySubst
, showNodeDevelopment
, scopesApplySubsts
, mkGoals
, addScope
, scopeGetAllBindings
, scopesAddPBinding
, splitBinding
, addNewScopeGoal
, initialScopes
, addGoalProvided -- unused atm
, showSearchNode
-- SearchNode lenses
, HasGoals (..)
, HasConstraintGoals (..)
, HasProvidedScopes (..)
, HasVarUses (..)
, HasFunctions (..)
, HasDeconss (..)
, HasQueryClassEnv (..)
, HasExpression (..)
, HasNextVarId (..)
, HasMaxTVarId (..)
, HasNextNVarId (..)
, HasDepth (..)
#if LINK_NODES
, HasPreviousNode (..)
#endif
, HasLastStepReason (..)
, HasLastStepBinding (..)
)
where
import Language.Haskell.Exference.Core.Types
import Language.Haskell.Exference.Core.TypeUtils
import Language.Haskell.Exference.Core.Expression
import Language.Haskell.Exference.Core.ExferenceStats
import Language.Haskell.Exference.Core.FunctionBinding
import qualified Data.Map.Strict as M
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Vector as V
import Data.Sequence
import Data.Foldable ( toList )
import Data.Functor.Identity ( runIdentity )
import Text.PrettyPrint
import Control.Arrow ( first, second, (***) )
import Control.DeepSeq.Generics
import Control.DeepSeq
import GHC.Generics
import Control.Lens.TH ( makeFields )
import Control.Monad.Trans.MultiRWS
import Control.Monad.Trans.MultiState ( runMultiStateTNil )
import Data.HList.ContainsType
-- import Debug.Hood.Observe
import Data.List ( intercalate )
data VarBinding = VarBinding {-# UNPACK #-} !TVarId HsType
deriving (Generic)
type VarPBinding = (TVarId, HsType, [HsType], [TVarId], [HsConstraint])
-- var, result, params, forallTypes, constraints
instance Show VarBinding where
show (VarBinding vid ty) = showVar vid ++ " :-> " ++ show ty
varBindingApplySubsts :: Substs -> VarBinding -> VarBinding
varBindingApplySubsts substs (VarBinding v t) =
VarBinding v (snd $ applySubsts substs t)
varPBindingApplySubsts :: Substs -> VarPBinding -> VarPBinding
varPBindingApplySubsts ss (v,rt,pt,fvs,cs) =
let
relevantSS = foldr IntMap.delete ss fvs
(newResult, params, newForalls, newCs) = splitArrowResultParams
$ snd
$ applySubsts relevantSS rt
in
( v
, newResult
, map (snd . applySubsts relevantSS) pt ++ params
, newForalls ++ fvs
, cs ++ newCs
)
type ScopeId = Int
data Scope = Scope [VarPBinding] [ScopeId]
-- scope bindings, superscopes
deriving Generic
data Scopes = Scopes ScopeId (IntMap.IntMap Scope)
deriving Generic
-- next id scopes
instance Show Scope where
show (Scope bindings sids) = "Scope " ++ show bindings ++ " " ++ show sids
instance Show Scopes where
show (Scopes _sid intmap) = "Scopes\n" ++ intercalate ("\n") (fmap (" " ++) $ fmap show $ IntMap.toAscList intmap)
initialScopes :: Scopes
initialScopes = Scopes 1 (IntMap.singleton 0 $ Scope [] [])
scopeGetAllBindings :: Int -> Scopes -> [VarPBinding]
scopeGetAllBindings sid ss@(Scopes _ scopeMap) =
case IntMap.lookup sid scopeMap of
Nothing -> []
Just (Scope binds ids) -> binds ++ concatMap (`scopeGetAllBindings` ss) ids
scopesApplySubsts :: Substs -> Scopes -> Scopes
scopesApplySubsts substs (Scopes i scopeMap) = Scopes i $ IntMap.map scopeF scopeMap
where
scopeF (Scope binds ids) = Scope (map bindF binds) ids
bindF = varPBindingApplySubsts substs
{-
scopesAddBinding :: ScopeId -> VarBinding -> Scopes -> Scopes
scopesAddBinding sid binding scopes =
scopesAddPBinding sid (splitBinding binding) scopes
-}
scopesAddPBinding :: ScopeId -> VarPBinding -> Scopes -> Scopes
scopesAddPBinding sid binding (Scopes nid sMap) = Scopes nid newMap
where
newMap = IntMap.adjust addBinding sid sMap
addBinding :: Scope -> Scope
addBinding (Scope vbinds ids) = Scope (binding:vbinds) ids
addScope :: ScopeId -> Scopes -> (ScopeId, Scopes)
addScope parent (Scopes nid sMap) = (nid, Scopes (nid+1) newMap)
where
newMap = IntMap.insert nid newScope sMap
newScope = Scope [] [parent]
type VarUsageMap = IntMap.IntMap Int
type TGoal = (VarBinding, ScopeId)
-- goal, id of innermost scope available
goalApplySubst :: Substs -> TGoal -> TGoal
goalApplySubst ss | IntMap.null ss = id
| otherwise = first (varBindingApplySubsts ss)
-- takes a new goal data, and a new set of provided stuff, and
-- returns some actual goal/newScope pair
addGoalProvided :: ScopeId
-> VarBinding -- goal binding
-> [VarBinding] -- new-given-bindings
-> Scopes
-> (TGoal, Scopes)
addGoalProvided sid goalBind givenBinds (Scopes nid sMap) =
((goalBind, nid),Scopes (nid+1) newMap)
where
newMap = IntMap.insert nid (Scope transformedBinds [sid]) sMap
transformedBinds = map splitBinding givenBinds
addNewScopeGoal :: ScopeId -> VarBinding -> Scopes -> (TGoal, ScopeId, Scopes)
addNewScopeGoal sid goalBind (Scopes nid sMap) =
((goalBind, nid), nid, Scopes (nid+1) newMap)
where
newMap = IntMap.insert nid (Scope [] [sid]) sMap
mkGoals :: ScopeId
-> [VarBinding]
-> [TGoal]
mkGoals sid vbinds = [(b,sid)|b<-vbinds]
data SearchNode = SearchNode
{ _searchNodeGoals :: Seq TGoal
, _searchNodeConstraintGoals :: [HsConstraint]
, _searchNodeProvidedScopes :: Scopes
, _searchNodeVarUses :: VarUsageMap
, _searchNodeFunctions :: V.Vector FunctionBinding
, _searchNodeDeconss :: [DeconstructorBinding]
, _searchNodeQueryClassEnv :: QueryClassEnv
, _searchNodeExpression :: Expression
, _searchNodeNextVarId :: {-# UNPACK #-} !TVarId
, _searchNodeMaxTVarId :: {-# UNPACK #-} !TVarId
, _searchNodeNextNVarId :: {-# UNPACK #-} !TVarId -- id used when resolving rankN-types
, _searchNodeDepth :: {-# UNPACK #-} !Float
#if LINK_NODES
, _searchNodePreviousNode :: Maybe SearchNode
#endif
, _searchNodeLastStepReason :: String
, _searchNodeLastStepBinding :: Maybe String
}
deriving Generic
instance NFData VarBinding where rnf = genericRnf
instance NFData Scope where rnf = genericRnf
instance NFData Scopes where rnf = genericRnf
instance NFData SearchNode where rnf = genericRnf
-- instance Show SearchNode where
-- show (SearchNode sgoals
-- scgoals
-- (Scopes _ scopeMap)
-- _svarUses
-- _sfuncs
-- _sdeconss
-- qClassEnv
-- sexpression
-- snextVarId
-- smaxTVarId
-- snextNVarId
-- sdepth
-- #if LINK_NODES
-- _prev
-- #endif
-- reason
-- _lastStepBinding
-- )
-- = show
-- $ text "SearchNode" <+> (
-- (text "goals ="
-- <+> brackets (vcat $ punctuate (text ", ") $ map tgoal $ toList sgoals)
-- )
-- $$ (text $ "constrGoals= " ++ show scgoals)
-- $$ (text "scopes = "
-- <+> brackets (vcat $ punctuate (text ", ") $ map tScope $ IntMap.toList scopeMap)
-- )
-- $$ (text $ "classEnv = " ++ show qClassEnv)
-- $$ (text $ "expression = " ++ showExpression sexpression)
-- $$ (text $ "reason = " ++ reason)
-- $$ (parens $ (text $ "nextVarId="++show snextVarId)
-- <+> (text $ "maxTVarId="++show smaxTVarId)
-- <+> (text $ "nextNVarId="++show snextNVarId)
-- <+> (text $ "depth="++show sdepth))
-- )
-- where
-- tgoal :: TGoal -> Doc
-- tgoal (vt,scopeId) = tVarType vt
-- <> text (" in " ++ show scopeId)
-- tScope :: (ScopeId, Scope) -> Doc
-- tScope (sid, Scope binds supers) =
-- text (show sid ++ " ")
-- <+> parens (text $ show $ supers)
-- <+> text " " <+> brackets (
-- hcat $ punctuate (text ", ")
-- (map tVarPType binds)
-- )
-- tVarType :: (TVarId, HsType) -> Doc
-- tVarType (i, t) = text $ showVar i ++ " :: " ++ show t
-- tVarPType :: (TVarId, HsType, [HsType], [TVarId], [HsConstraint]) -> Doc
-- tVarPType (i, t, ps, [], []) = tVarType (i, foldr TypeArrow t ps)
-- tVarPType (i, t, ps, fs, cs) = tVarType (i, TypeForall fs cs (foldr TypeArrow t ps))
showSearchNode :: SearchNode -> String
showSearchNode
(SearchNode sgoals
scgoals
(Scopes _ scopeMap)
_svarUses
_sfuncs
_sdeconss
qClassEnv
sexpression
snextVarId
smaxTVarId
snextNVarId
sdepth
#if LINK_NODES
_prev
#endif
reason
_lastStepBinding
) =
let exprStr = showExpression sexpression
in show
$ text "SearchNode" <+> (
(text "goals ="
<+> brackets (vcat $ punctuate (text ", ") $ map tgoal $ toList sgoals)
)
$$ (text $ "constrGoals= " ++ show scgoals)
$$ (text "scopes = "
<+> brackets (vcat $ punctuate (text ", ") $ map tScope $ IntMap.toList scopeMap)
)
$$ (text $ "classEnv = " ++ show qClassEnv)
$$ (text $ "expression = " ++ exprStr)
$$ (text $ "reason = " ++ reason)
$$ (parens $ (text $ "nextVarId="++show snextVarId)
<+> (text $ "maxTVarId="++show smaxTVarId)
<+> (text $ "nextNVarId="++show snextNVarId)
<+> (text $ "depth="++show sdepth))
)
where
tgoal :: TGoal -> Doc
tgoal (vt,scopeId) = tVarType vt
<> text (" in " ++ show scopeId)
tScope :: (ScopeId, Scope) -> Doc
tScope (sid, Scope binds supers) =
text (show sid ++ " ")
<+> parens (text $ show $ supers)
<+> text " " <+> brackets (
hcat $ punctuate (text ", ")
(map tVarPType binds)
)
tVarType :: VarBinding -> Doc
tVarType (VarBinding i t) = text $ showVar i ++ " :: " ++ show t
tVarPType :: (TVarId, HsType, [HsType], [TVarId], [HsConstraint]) -> Doc
tVarPType (i, t, ps, [], []) = tVarType $ VarBinding i (foldr TypeArrow t ps)
tVarPType (i, t, ps, fs, cs) = tVarType $ VarBinding i (TypeForall fs cs (foldr TypeArrow t ps))
showNodeDevelopment :: SearchNode -> String
#if LINK_NODES
showNodeDevelopment s = case _searchNodePreviousNode s of
Nothing -> showSearchNode s
Just p -> showNodeDevelopment p ++ "\n" ++ showSearchNode s
#else
showNodeDevelopment _ = "[showNodeDevelopment: exference-core was not compiled with -fLinkNodes]"
#endif
-- instance Observable SearchNode where
-- observer state = observeOpaque (show state) state
splitBinding :: VarBinding -> VarPBinding
splitBinding (VarBinding v t) = let (rt,pts,fvs,cs) = splitArrowResultParams t in (v,rt,pts,fvs,cs)
makeFields ''SearchNode