Merge pull request #33 from input-output-hk/coot/records-and-threadid

Added record name to ctx & ThreadId instance

Author: coot

.github/workflows/ci.yml

@@ -36,3 +36,22 @@ jobs:
       - run: cabal test $CONFIG
       - run: cabal haddock $CONFIG
       - run: cabal sdist
+
+  check-changelogs:
+    name: Check changelogs
+    runs-on: ubuntu-latest
+    defaults:
+      run:
+        shell: bash
+
+    steps:
+    - name: Install dependencies
+      run: sudo apt install -y fd-find
+
+    - uses: actions/checkout@v3
+
+    - name: git fetch
+      run: git fetch origin master:master
+
+    - name: Check changelogs
+      run: ./scripts/check-changelogs.sh

CHANGELOG.md

@@ -1,5 +1,9 @@
 # Revision history for nothunks
 
+## next version
+
+* `NoThunks ThreadId` instance
+
 ## 0.1.4 -- 2023-03-27
 
 * Made cabal flags manual.

scripts/check-changelogs.sh

@@ -0,0 +1,21 @@
+#!/usr/bin/env bash
+
+FD="$(which fdfind 2>/dev/null || which fd 2>/dev/null)"
+
+set -eo pipefail
+
+function check_project () {
+  project=$1
+  n=$()
+  if [[ -n $(git diff --name-only origin/master..HEAD -- $project) ]];then
+    if [[ -z $(git diff --name-only origin/master..HEAD -- $project/CHANGELOG.md) ]]; then
+      echo "$project was modified but its CHANGELOG was not updated"
+      exit 1
+    fi
+  fi
+}
+
+for cbl in $($FD -e 'cabal'); do
+  check_project $(dirname $cbl)
+done
+

src/NoThunks/Class.hs

@@ -43,6 +43,7 @@ import GHC.Exts.Heap
 import GHC.Generics
 import GHC.Records
 import GHC.TypeLits
+import GHC.Conc.Sync (ThreadId (..))
 
 -- For instances
 
@@ -427,10 +428,12 @@ instance GWNoThunks a V1 where
 -------------------------------------------------------------------------------}
 
 -- | If @fieldName@ is allowed to contain thunks, skip it.
-instance GWRecordField f (Elem fieldName a)
+instance ( GWRecordField f (Elem fieldName a)
+         , KnownSymbol fieldName
+         )
       => GWNoThunks a (S1 ('MetaSel ('Just fieldName) su ss ds) f) where
   gwNoThunks _ ctxt (M1 fp) =
-      gwRecordField (Proxy @(Elem fieldName a)) ctxt fp
+      gwRecordField (Proxy @(Elem fieldName a)) (symbolVal @fieldName Proxy : ctxt) fp
 
 class GWRecordField f (b :: Bool) where
   gwRecordField :: proxy b -> Context -> f x -> IO (Maybe ThunkInfo)
@@ -640,6 +643,8 @@ instance NoThunks a => NoThunks (NonEmpty a)
 
 instance (NoThunks a, NoThunks b) => NoThunks (Either a b)
 
+deriving via InspectHeap ThreadId instance NoThunks ThreadId
+
 {-------------------------------------------------------------------------------
   Spine-strict container types
 

test/Test/NoThunks/Class.hs

@@ -333,13 +333,13 @@ instance FromModel (AllowThunksIn '["field1"] Record) where
 
   modelIsNF ctxt = \case
       RecordThunk _     -> NotWHNF ctxt'
-      RecordDefined a b -> constrNF [modelIsNF ctxt' a, modelIsNF ctxt' b]
+      RecordDefined a b -> constrNF [modelIsNF ("field1" : ctxt') a, modelIsNF ("field2" : ctxt') b]
     where
       ctxt' = "Record" : ctxt
 
   modelUnexpected ctxt = \case
       RecordThunk   _   -> Just ctxt'
-      RecordDefined _ y -> modelUnexpected ctxt' y
+      RecordDefined _ y -> modelUnexpected ("field2" : ctxt') y
     where
       ctxt' = "Record" : ctxt