rename predicates

exe/app/Class.hs

@@ -3,9 +3,9 @@ module Class where
 import           Graph.Trace
 
 class Show a => Classy a where
-  classy :: Debug => a -> String
+  classy :: Trace => a -> String
 
-  deff :: Debug => a -> String
+  deff :: Trace => a -> String
   deff = show
 
 class Show a => Classier a where

exe/app/Main.hs

@@ -21,7 +21,7 @@ import Class
 import qualified System.Random as Rand
 import           System.IO.Unsafe
 
-main :: DebugDeep => IO ()
+main :: TraceDeep => IO ()
 main = trace bah print unassuming >> buzzard
   where
     unassuming :: Either Bool Int

exe/breaking/Main.hs

@@ -1,96 +0,0 @@
-{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}
-{-# LANGUAGE MultiWayIf #-}
-import           Control.Applicative (empty)
-import           Control.Monad
-import           Control.Monad.ST
-import           Control.Monad.Trans (lift)
-import           Control.Monad.Trans.Maybe
-import           Control.Monad.Trans.State.Strict
-import           Data.Bits
-import qualified Data.ByteString.Char8 as BS8
-import           Data.Foldable (for_)
-import qualified Data.HashMap.Strict as HM
-import qualified Data.Vector.Generic.Mutable as MV
-import qualified Data.Vector.Unboxed.Mutable as UMV
-
-import           Graph.Trace
-
-type ItemName = BS8.ByteString
-type Pair = (ItemName, ItemName)
-type SetIndex = Int
--- A "Set" consists of two groups of items which cannot be bought together.
-type ItemToSet = HM.HashMap ItemName (SetIndex, Bool)
--- The Bool indicates which "side" of the Set an item belongs to
-type Resolver s = UMV.MVector s (SetIndex, Bool)
--- Sets can combined by mapping the SetIndex of the merged Set to the index of
--- another Set using a mutable vector.
--- The Bool is True if the groups in the Set being merged should be flipped.
-
-main :: DebugDeep => IO ()
-main = do
-  n <- readLn
-  items <- replicateM n BS8.getLine
-  m <- readLn
-  pairs <- map ((\[x, y] -> (x, y)) . BS8.words) <$> replicateM m BS8.getLine
-  case runST $ solve items pairs of
-    Nothing -> putStrLn "impossible"
-    Just (jesse, walt) -> do
-      BS8.putStrLn $ BS8.unwords jesse
-      BS8.putStrLn $ BS8.unwords walt
-
-solve :: [ItemName] -> [Pair] -> ST s (Maybe ([ItemName], [ItemName]))
-solve items pairs = do
-  -- kattis uses an old version of vector w/o generate
-  --resolver <- MV.generate 50000 (,False)
-  resolver <- MV.new 50000
-  for_ [0..49999] $ \i -> MV.write resolver i (i, False)
-  mItemToSet <- (`evalStateT` 0) . runMaybeT
-              $ foldM (step resolver) HM.empty pairs
-  forM mItemToSet $ \itemToSet ->
-    foldM (assign resolver itemToSet) ([], []) items
-
-step :: Resolver s -> ItemToSet -> Pair -> MaybeT (StateT SetIndex (ST s)) ItemToSet
-step resolver itemToSet (a, b) =
-  case (HM.lookup a itemToSet, HM.lookup b itemToSet) of
-    (Nothing, Nothing) -> do
-      ix <- lift get
-      lift $ modify' succ
-      pure . HM.insert a (ix, True) $ HM.insert b (ix, False) itemToSet
-    (Just (ix, o), Nothing) ->
-      pure $ HM.insert b (ix, not o) itemToSet
-    (Nothing, Just (ix, o)) ->
-      pure $ HM.insert a (ix, not o) itemToSet
-    (Just (aix, ao), Just (bix, bo)) -> do
-      (aix', ao') <- lift . lift $ resolve resolver aix ao
-      (bix', bo') <- lift . lift $ resolve resolver bix bo
-      -- compress paths
-      let itemToSet' | aix /= aix' || bix /= bix'
-                       = HM.insert a (aix', ao')
-                       $ HM.insert b (bix', bo') itemToSet
-                     | otherwise = itemToSet
-      if | aix' == bix', ao' == bo' -> empty -- fail
-         | aix' == bix' -> pure itemToSet'
-         | otherwise -> do
-             lift . lift $ UMV.write resolver bix' (aix', ao' == bo')
-             pure itemToSet'
-
-assign :: Resolver s
-       -> ItemToSet
-       -> ([ItemName], [ItemName])
-       -> ItemName
-       -> ST s ([ItemName], [ItemName])
-assign resolver itemToSet (jesse, walt) item =
-  case HM.lookup item itemToSet of
-    Nothing -> pure (jesse, item : walt)
-    Just (ix, b) -> do
-      (_, b') <- resolve resolver ix b
-      pure $ if b' then (item : jesse, walt) else (jesse, item : walt)
-
-resolve :: Resolver s -> SetIndex -> Bool -> ST s (SetIndex, Bool)
-resolve resolver ix b = do
-  (ix', b') <- UMV.read resolver ix
-  let b'' = xor b b'
-  if ix' == ix
-     then pure (ix, b'')
-     else resolve resolver ix' b''
-

exe/breaking/input

@@ -1,9 +0,0 @@
-5
-battery_acid
-drain_cleaner
-antifreeze
-cold_medicine
-lantern_fuel
-2
-cold_medicine battery_acid
-antifreeze lantern_fuel

exe/exe.cabal

@@ -34,11 +34,3 @@ executable test-exe
   -- hs-source-dirs:
   default-language:    Haskell2010
 --  ghc-options: -fplugin=Graph.Trace
-
-executable breaking
-  main-is: Main.hs
-  hs-source-dirs: breaking
-  build-depends: base, graph-trace, vector, unordered-containers, bytestring,
-                 mtl, transformers
-  default-language: Haskell2010
-  ghc-options: -fplugin=Graph.Trace

graph-trace/src/Graph/Trace.hs

@@ -61,12 +61,12 @@ renamedResultAction cmdLineOptions tcGblEnv
   debugTypesModule <- findImportedModule "Graph.Trace.Internal.Types"
   debugTraceModule <- findImportedModule "Graph.Trace.Internal.Trace"
 
-  debugMutePredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "DebugMute")
-  debugDeepPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "DebugDeep")
-  debugDeepKeyPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "DebugDeepKey")
-  debugPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "Debug")
-  debugKeyPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "DebugKey")
-  debugInertPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "DebugInert")
+  traceMutePredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceMute")
+  traceDeepPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceDeep")
+  traceDeepKeyPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceDeepKey")
+  tracePredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "Trace")
+  traceKeyPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceKey")
+  traceInertPredName <- Ghc.lookupOrig debugTypesModule (Ghc.mkClsOcc "TraceInert")
   entryName <- Ghc.lookupOrig debugTraceModule (Ghc.mkVarOcc "entry")
   debugContextName <- Ghc.lookupOrig debugTypesModule (Ghc.mkTcOcc "DebugContext")
 

graph-trace/src/Graph/Trace/Internal/Predicates.hs

@@ -74,8 +74,8 @@ addConstraintToSigType debugNames debugAllFlag names sig@(Ghc.HsSig' t) = do
       prop = if debugAllFlag then Shallow else Inert
       predName =
         if debugAllFlag
-           then debugPredName debugNames
-           else debugInertPredName debugNames
+           then tracePredName debugNames
+           else traceInertPredName debugNames
       predTy = Ghc.noLocA'
              $ Ghc.HsTyVar Ghc.emptyEpAnn Ghc.NotPromoted
                  (Ghc.noLocA' predName)
@@ -119,14 +119,14 @@ checkForDebugPred
   -> Maybe (Maybe Ghc.FastString, Propagation)
 checkForDebugPred debugNames
     (Ghc.HsTyVar _ _ (Ghc.L _ name))
-  | name == debugPredName debugNames = Just (Nothing, Shallow)
-  | name == debugDeepPredName debugNames = Just (Nothing, Deep)
-  | name == debugMutePredName debugNames = Just (Nothing, Mute)
-  | name == debugInertPredName debugNames = Just (Nothing, Inert)
+  | name == tracePredName debugNames = Just (Nothing, Shallow)
+  | name == traceDeepPredName debugNames = Just (Nothing, Deep)
+  | name == traceMutePredName debugNames = Just (Nothing, Mute)
+  | name == traceInertPredName debugNames = Just (Nothing, Inert)
 checkForDebugPred debugNames
     (Ghc.HsAppTy _ (Ghc.L _ (Ghc.HsTyVar _ _ (Ghc.L _ name))) (Ghc.L _ (Ghc.HsTyLit _ (Ghc.HsStrTy _ key))))
-  | name == debugKeyPredName debugNames = Just (Just key, Shallow)
-  | name == debugDeepKeyPredName debugNames = Just (Just key, Deep)
+  | name == traceKeyPredName debugNames = Just (Just key, Shallow)
+  | name == traceDeepKeyPredName debugNames = Just (Just key, Deep)
 checkForDebugPred debugNames Ghc.HsForAllTy { Ghc.hst_body = Ghc.L _ ty }
   = checkForDebugPred debugNames ty
 checkForDebugPred debugNames (Ghc.HsParTy _ (Ghc.L _ ty))

graph-trace/src/Graph/Trace/Internal/Types.hs

@@ -12,12 +12,12 @@ module Graph.Trace.Internal.Types
   , DefinitionSite
   , CallSite
   , DebugIP
-  , DebugMute
-  , DebugDeep
-  , DebugDeepKey
-  , Debug
-  , DebugKey
-  , DebugInert
+  , TraceMute
+  , TraceDeep
+  , TraceDeepKey
+  , Trace
+  , TraceKey
+  , TraceInert
   , Event(..)
   , eventToLogStr
   , FunName
@@ -66,12 +66,12 @@ type DefinitionSite = SrcCodeLoc
 type CallSite = SrcCodeLoc
 
 type DebugIP = (?_debug_ip :: Maybe DebugContext, HasCallStack)
-type DebugMute = DebugIP
-type DebugDeep = DebugIP
-type DebugDeepKey (key :: Symbol) = DebugIP
-type Debug = DebugIP
-type DebugKey (key :: Symbol) = DebugIP
-type DebugInert = DebugIP
+type TraceMute = DebugIP
+type TraceDeep = DebugIP
+type TraceDeepKey (key :: Symbol) = DebugIP
+type Trace = DebugIP
+type TraceKey (key :: Symbol) = DebugIP
+type TraceInert = DebugIP
 -- These are String because they need to be lifted into TH expressions
 type FunName = String
 type UserKey = String
@@ -144,12 +144,12 @@ keyStr
 
 data DebugNames =
   DebugNames
-    { debugMutePredName :: Ghc.Name
-    , debugDeepPredName :: Ghc.Name
-    , debugDeepKeyPredName :: Ghc.Name
-    , debugPredName :: Ghc.Name
-    , debugKeyPredName :: Ghc.Name
-    , debugInertPredName :: Ghc.Name
+    { traceMutePredName :: Ghc.Name
+    , traceDeepPredName :: Ghc.Name
+    , traceDeepKeyPredName :: Ghc.Name
+    , tracePredName :: Ghc.Name
+    , traceKeyPredName :: Ghc.Name
+    , traceInertPredName :: Ghc.Name
     , entryName :: Ghc.Name
     , debugContextName :: Ghc.Name
     }