Skip to content

Commit

Permalink
* Add dependency on lens and generic-lens
Browse files Browse the repository at this point in the history
* Hide some debugging code that used sr-log
  • Loading branch information
ddssff committed Dec 3, 2024
1 parent 234021b commit aefb8b9
Show file tree
Hide file tree
Showing 2 changed files with 12 additions and 8 deletions.
6 changes: 4 additions & 2 deletions safecopy.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -45,10 +45,12 @@ Library
cereal >= 0.5.3 && < 0.6,
-- cereal 0.5.3 introduced instance Monoid Put
bytestring < 0.13,
generic-data >= 0.3.0.0,
containers >= 0.3 && < 0.8,
old-time < 1.2,
generic-data >= 0.3.0.0,
generic-lens,
lens,
mtl,
old-time < 1.2,
pretty,
syb,
template-haskell >= 2.11.0.0 && < 2.23,
Expand Down
14 changes: 8 additions & 6 deletions src/Data/SafeCopy/Derive.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoOverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

Expand Down Expand Up @@ -30,17 +31,16 @@ import Control.Monad
import Control.Monad.RWS as MTL (ask, execRWST, lift, local, RWST, tell)
-- import Data.Data (Data)
import Data.Generics (Data, everywhere, mkT)
import Data.List (intercalate, nub)
import Data.List ({-intercalate,-} nub)
import Data.Maybe (fromMaybe)
#ifdef __HADDOCK__
import Data.Word (Word8) -- Haddock
#endif
import Debug.Trace
-- import Debug.Trace
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Language.Haskell.TH.PprLib (Doc, to_HPJ_Doc)
import Language.Haskell.TH.Syntax
import SeeReason.SrcLoc
import qualified Text.PrettyPrint as HPJ

-- | Derive an instance of 'SafeCopy'.
Expand Down Expand Up @@ -288,7 +288,7 @@ doType typ = -- traceLocM ("doType " <> ren typ) $
local (over #_freeVars (fmap unKind tyvars <>)) $ doType typ'
AppT t1 t2 -> local (over #_params (t2 :)) $ doType t1
TupleT n -> doTypeName (tupleTypeName n)
_ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ ++ " (" <> compactStack getStack <> ")"
_ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ -- ++ " (" <> compactStack getStack <> ")"

doTypeName :: Name -> RWST (R a) W S Q ()
doTypeName tyName = -- traceLocM ("doTypeName " <> ren tyName) $
Expand All @@ -313,7 +313,7 @@ doInfo tyName info = -- traceLocM ("doInfo " <> ren tyName <> " (" <> ren info <

FamilyI _ insts -> do
mapM_ (doInst tyName info . instCompat) insts
_ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) ++ " (" <> compactStack getStack <> ")"
_ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) -- ++ " (" <> compactStack getStack <> ")"

withBindings :: [TyVarBndr] -> RWST (R a) W S Q () -> RWST (R a) W S Q ()

Check failure on line 318 in src/Data/SafeCopy/Derive.hs

View workflow job for this annotation

GitHub Actions / Stack 9.0 ubuntu-latest

• Expecting one more argument to ‘TyVarBndr’

Check failure on line 318 in src/Data/SafeCopy/Derive.hs

View workflow job for this annotation

GitHub Actions / Stack 9.4 ubuntu-latest

• Expecting one more argument to ‘TyVarBndr’

Check failure on line 318 in src/Data/SafeCopy/Derive.hs

View workflow job for this annotation

GitHub Actions / Stack 9.2 ubuntu-latest

• Expecting one more argument to ‘TyVarBndr’

Check failure on line 318 in src/Data/SafeCopy/Derive.hs

View workflow job for this annotation

GitHub Actions / Stack 9.8 ubuntu-latest

• Expecting one more argument to ‘TyVarBndr’

Check failure on line 318 in src/Data/SafeCopy/Derive.hs

View workflow job for this annotation

GitHub Actions / Stack 9.6 ubuntu-latest

• Expecting one more argument to ‘TyVarBndr’

Check failure on line 318 in src/Data/SafeCopy/Derive.hs

View workflow job for this annotation

GitHub Actions / Stack 9.8 macos-latest

• Expecting one more argument to ‘TyVarBndr’

Check failure on line 318 in src/Data/SafeCopy/Derive.hs

View workflow job for this annotation

GitHub Actions / Stack 9.8 windows-latest

* Expecting one more argument to `TyVarBndr'
withBindings tyvars action = do
Expand Down Expand Up @@ -569,6 +569,7 @@ typeName _ = "_"

-- * Debugging

#if 0
traceLoc :: HasCallStack => String -> a -> a
traceLoc s a =
trace (s <> " (" <> compactStack (drop 1 getStack) <> ")") a
Expand All @@ -578,11 +579,12 @@ traceLocM s t = do
indent <- view #_indent
params <- view #_params
bindings <- use #_bindings
local (\r@R{..} -> r {_indent = " " <> _indent}) $
local (over #_indent (" " <>)) $
trace (indent <> s <> "\n" <>
indent <> " --> params: [" <> intercalate ", " (fmap vis params) <> "]\n" <>
indent <> " --> bindings: [" <> intercalate ", " (fmap (\(tv, ty) -> "(tv=" <> vis tv <> ", ty=" <> vis ty <> ")") bindings) <> "]\n" <>
indent <> " --> stack: " <> compactStack (drop 1 getStack)) t
#endif

ren :: (Data a, Ppr a) => a -> String
ren = renderTH (ppr . everywhere (mkT briefName))

Check warning on line 590 in src/Data/SafeCopy/Derive.hs

View workflow job for this annotation

GitHub Actions / Stack 8.6 ubuntu-latest

Defined but not used: ‘ren’

Check warning on line 590 in src/Data/SafeCopy/Derive.hs

View workflow job for this annotation

GitHub Actions / Stack 8.6 ubuntu-latest

Defined but not used: ‘ren’
Expand Down

0 comments on commit aefb8b9

Please sign in to comment.