{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, UndecidableInstances, NoMonomorphismRestriction, MultiParamTypeClasses #-}
module CHR.Types
( module CHR.Types.Core
, module CHR.Data.TreeTrie
, CHRKey
, WorkTime
, initWorkTime
, Work'(..)
, Work
, SolveStep'(..)
, SolveTrace'
, emptySolveTrace
, ppSolveTrace
)
where
import qualified CHR.Data.TreeTrie as TT
import CHR.Data.TreeTrie ( TrTrKey )
import CHR.Pretty as Pretty
import CHR.Data.AssocL
import CHR.Types.Core ( IVar
, NmToVarMp, emptyNmToVarMp
, Prio
, CHRPrioEvaluatableVal
, IsConstraint
, IsCHRGuard
, IsCHRConstraint
, IsCHRPrio
, IsCHRBacktrackPrio
, CHRCheckable
, CHRMatchable
, CHRPrioEvaluatable
, CHREmptySubstitution
, CHRMatcher
, CHRMatchableKey
, CHRMatcherFailure
)
import qualified Data.Map as Map
type CHRKey v = TT.Key (TT.TrTrKey v)
type WorkTime = Int
initWorkTime :: WorkTime
initWorkTime = 0
type WorkKey v = CHRKey v
data Work' k c
= Work
{ workKey :: k
, workCnstr :: !c
, workTime :: WorkTime
}
| Work_Residue
{ workCnstr :: !c
}
| Work_Solve
{ workCnstr :: !c
}
| Work_Fail
type Work c = Work' (WorkKey c) c
type instance TT.TrTrKey (Work' k c) = TT.TrTrKey c
instance Show (Work' k c) where
show _ = "SolveWork"
instance (PP k, PP c) => PP (Work' k c) where
pp (Work {workKey=k, workCnstr=c, workTime=t})
= ppParens k >|< "@" >|< t >#< c
pp (Work_Residue c ) = pp c
pp (Work_Solve c ) = pp c
pp (Work_Fail ) = pp "fail"
data SolveStep' c r s
= SolveStep
{ stepChr :: r
, stepSubst :: s
, stepAlt :: Maybe [c]
, stepNewTodo :: [c]
, stepNewDone :: [c]
}
| SolveStats
{ stepStats :: Map.Map String PP_Doc
}
| SolveDbg
{ stepPP :: PP_Doc
}
type SolveTrace' c r s = [SolveStep' c r s]
emptySolveTrace :: SolveTrace' c r s
emptySolveTrace = []
instance Show (SolveStep' c r s) where
show _ = "SolveStep"
instance (PP r, PP c) => PP (SolveStep' c r s) where
pp (SolveStep step _ _ todo done) = "STEP" >#< (step >-< "new todo:" >#< ppBracketsCommas todo >-< "new done:" >#< ppBracketsCommas done)
pp (SolveStats stats ) = "STATS" >#< (ppAssocLV (Map.toList stats))
pp (SolveDbg p ) = "DBG" >#< p
ppSolveTrace :: (PP r, PP c) => SolveTrace' c r s -> PP_Doc
ppSolveTrace tr = ppBracketsCommasBlock [ pp st | st <- tr ]