summaryrefslogtreecommitdiff
path: root/tests/examples/failing
diff options
context:
space:
mode:
authormpickering <>2015-11-21 22:36:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-11-21 22:36:00 (GMT)
commit617719c6c7a6f6cc3f9c21c76401749a05088d42 (patch)
treede1e62466eabbff4fd27a0827b502412ca09f4ae /tests/examples/failing
parent306934b50ead38aad01a867c1364576f50d7be18 (diff)
version 0.5.0.00.5.0.0
Diffstat (limited to 'tests/examples/failing')
-rw-r--r--tests/examples/failing/Deprecation.hs16
-rw-r--r--tests/examples/failing/Deprecation.hs.bad16
-rw-r--r--tests/examples/failing/InfixOperator.hs26
-rw-r--r--tests/examples/failing/InfixOperator.hs.bad25
-rw-r--r--tests/examples/failing/MultiLineWarningPragma.hs18
-rw-r--r--tests/examples/failing/MultiLineWarningPragma.hs.bad17
-rw-r--r--tests/examples/failing/UnicodeRules.hs16
-rw-r--r--tests/examples/failing/UnicodeRules.hs.bad16
-rw-r--r--tests/examples/failing/UnicodeSyntax.hs236
-rw-r--r--tests/examples/failing/UnicodeSyntax.hs.bad236
10 files changed, 622 insertions, 0 deletions
diff --git a/tests/examples/failing/Deprecation.hs b/tests/examples/failing/Deprecation.hs
new file mode 100644
index 0000000..63c555e
--- /dev/null
+++ b/tests/examples/failing/Deprecation.hs
@@ -0,0 +1,16 @@
+
+module Deprecation
+{-# Deprecated ["This is a module \"deprecation\"",
+ "multi-line",
+ "with unicode: Frère" ] #-}
+ ( foo )
+ where
+
+{-# DEPRECATEd foo
+ ["This is a multi-line",
+ "deprecation message",
+ "for foo"] #-}
+foo :: Int
+foo = 4
+
+{-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}
diff --git a/tests/examples/failing/Deprecation.hs.bad b/tests/examples/failing/Deprecation.hs.bad
new file mode 100644
index 0000000..28fa7df
--- /dev/null
+++ b/tests/examples/failing/Deprecation.hs.bad
@@ -0,0 +1,16 @@
+
+module Deprecation
+{-# Deprecated ["This is a module \"deprecation\"",
+ "multi-line",
+ "with unicode: Fr\232re" ] #-}
+ ( foo )
+ where
+
+{-# DEPRECATEd foo
+ ["This is a multi-line",
+ "deprecation message",
+ "for foo"] #-}
+foo :: Int
+foo = 4
+
+{-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}
diff --git a/tests/examples/failing/InfixOperator.hs b/tests/examples/failing/InfixOperator.hs
new file mode 100644
index 0000000..160aace
--- /dev/null
+++ b/tests/examples/failing/InfixOperator.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}
+
+#define BACKSLASH 92
+#define CLOSE_CURLY 125
+#define CLOSE_SQUARE 93
+#define COMMA 44
+#define DOUBLE_QUOTE 34
+#define OPEN_CURLY 123
+#define OPEN_SQUARE 91
+#define C_0 48
+#define C_9 57
+#define C_A 65
+#define C_F 70
+#define C_a 97
+#define C_f 102
+#define C_n 110
+#define C_t 116
+
+json_ :: Parser Value -> Parser Value -> Parser Value
+json_ obj ary = do
+ w <- skipSpace *> A.satisfy (\w -> w == OPEN_CURLY || w == OPEN_SQUARE)
+ if w == OPEN_CURLY
+ then obj
+ else ary
+{-# INLINE json_ #-}
+
diff --git a/tests/examples/failing/InfixOperator.hs.bad b/tests/examples/failing/InfixOperator.hs.bad
new file mode 100644
index 0000000..81c0c61
--- /dev/null
+++ b/tests/examples/failing/InfixOperator.hs.bad
@@ -0,0 +1,25 @@
+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}
+
+#define BACKSLASH 92
+#define CLOSE_CURLY 125
+#define CLOSE_SQUARE 93
+#define COMMA 44
+#define DOUBLE_QUOTE 34
+#define OPEN_CURLY 123
+#define OPEN_SQUARE 91
+#define C_0 48
+#define C_9 57
+#define C_A 65
+#define C_F 70
+#define C_a 97
+#define C_f 102
+#define C_n 110
+#define C_t 116
+
+json_ :: Parser Value -> Parser Value -> Parser Value
+json_ obj ary = do
+ w <- skipSpace *> A.satisfy (\w -> w == 123OPEN_CURLY w ==||) == OPEN_SQUARE)
+ if w == 123OPEN_CURLY
+ then obj
+ else ary
+{-# INLINE json_ #-}
diff --git a/tests/examples/failing/MultiLineWarningPragma.hs b/tests/examples/failing/MultiLineWarningPragma.hs
new file mode 100644
index 0000000..970f9ea
--- /dev/null
+++ b/tests/examples/failing/MultiLineWarningPragma.hs
@@ -0,0 +1,18 @@
+
+{-# WARNING Logic
+ , mkSolver
+ , mkSimpleSolver
+ , mkSolverForLogic
+ , solverSetParams
+ , solverPush
+ , solverPop
+ , solverReset
+ , solverGetNumScopes
+ , solverAssertCnstr
+ , solverAssertAndTrack
+ , solverCheck
+ , solverCheckAndGetModel
+ , solverGetReasonUnknown
+ "New Z3 API support is still incomplete and fragile: \
+ \you may experience segmentation faults!"
+ #-}
diff --git a/tests/examples/failing/MultiLineWarningPragma.hs.bad b/tests/examples/failing/MultiLineWarningPragma.hs.bad
new file mode 100644
index 0000000..01904f4
--- /dev/null
+++ b/tests/examples/failing/MultiLineWarningPragma.hs.bad
@@ -0,0 +1,17 @@
+
+{-# WARNING Logic
+ , mkSolver
+ , mkSimpleSolver
+ , mkSolverForLogic
+ , solverSetParams
+ , solverPush
+ , solverPop
+ , solverReset
+ , solverGetNumScopes
+ , solverAssertCnstr
+ , solverAssertAndTrack
+ , solverCheck
+ , solverCheckAndGetModel
+ , solverGetReasonUnknown
+ "New Z3 API support is still incomplete and fragile: you may experience segmentation faults!"
+ #-}
diff --git a/tests/examples/failing/UnicodeRules.hs b/tests/examples/failing/UnicodeRules.hs
new file mode 100644
index 0000000..6add832
--- /dev/null
+++ b/tests/examples/failing/UnicodeRules.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE
+ BangPatterns
+ , FlexibleContexts
+ , FlexibleInstances
+ , ScopedTypeVariables
+ , UnboxedTuples
+ , UndecidableInstances
+ , UnicodeSyntax
+ #-}
+
+strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool
+{-# RULES "head → strictHead" [1]
+ ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d).
+ head v = strictHead v #-}
+{-# INLINE strictHead #-}
+strictHead (Bitstream _ v) = head (SV.head v)
diff --git a/tests/examples/failing/UnicodeRules.hs.bad b/tests/examples/failing/UnicodeRules.hs.bad
new file mode 100644
index 0000000..883d40d
--- /dev/null
+++ b/tests/examples/failing/UnicodeRules.hs.bad
@@ -0,0 +1,16 @@
+{-# LANGUAGE
+ BangPatterns
+ , FlexibleContexts
+ , FlexibleInstances
+ , ScopedTypeVariables
+ , UnboxedTuples
+ , UndecidableInstances
+ , UnicodeSyntax
+ #-}
+
+strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool
+{-# RULES "head \8594 strictHead" [1]
+ ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d).
+ head v = strictHead v #-}
+{-# INLINE strictHead #-}
+strictHead (Bitstream _ v) = head (SV.head v)
diff --git a/tests/examples/failing/UnicodeSyntax.hs b/tests/examples/failing/UnicodeSyntax.hs
new file mode 100644
index 0000000..c661b8c
--- /dev/null
+++ b/tests/examples/failing/UnicodeSyntax.hs
@@ -0,0 +1,236 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnicodeSyntax #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE Arrows #-}
+
+module Tutorial where
+
+-- import Abt.Class
+-- import Abt.Types
+-- import Abt.Concrete.LocallyNameless
+
+import Control.Applicative
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Except
+-- import Data.Vinyl
+import Prelude hiding (pi)
+
+-- | We'll start off with a monad in which to manipulate ABTs; we'll need some
+-- state for fresh variable generation.
+--
+newtype M α
+ = M
+ { _M ∷ State Int α
+ } deriving (Functor, Applicative, Monad)
+
+-- | We'll run an ABT computation by starting the variable counter at @0@.
+--
+runM ∷ M α → α
+runM (M m) = evalState m 0
+
+-- | Check out the source to see fresh variable generation.
+--
+instance MonadVar Var M where
+ fresh = M $ do
+ n ← get
+ let n' = n + 1
+ put n'
+ return $ Var Nothing n'
+
+ named a = do
+ v ← fresh
+ return $ v { _varName = Just a }
+
+-- | Next, we'll define the operators for a tiny lambda calculus as a datatype
+-- indexed by arities.
+--
+data Lang ns where
+ LAM ∷ Lang '[S Z]
+ APP ∷ Lang '[Z, Z]
+ PI ∷ Lang '[Z, S Z]
+ UNIT ∷ Lang '[]
+ AX ∷ Lang '[]
+
+instance Show1 Lang where
+ show1 = \case
+ LAM → "lam"
+ APP → "ap"
+ PI → "pi"
+ UNIT → "unit"
+ AX → "<>"
+
+instance HEq1 Lang where
+ heq1 LAM LAM = Just Refl
+ heq1 APP APP = Just Refl
+ heq1 PI PI = Just Refl
+ heq1 UNIT UNIT = Just Refl
+ heq1 AX AX = Just Refl
+ heq1 _ _ = Nothing
+
+lam ∷ Tm Lang (S Z) → Tm0 Lang
+lam e = LAM $$ e :& RNil
+
+app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang
+app m n = APP $$ m :& n :& RNil
+
+ax ∷ Tm0 Lang
+ax = AX $$ RNil
+
+unit ∷ Tm0 Lang
+unit = UNIT $$ RNil
+
+pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang
+pi α xβ = PI $$ α :& xβ :& RNil
+
+-- | A monad transformer for small step operational semantics.
+--
+newtype StepT m α
+ = StepT
+ { runStepT ∷ MaybeT m α
+ } deriving (Monad, Functor, Applicative, Alternative)
+
+-- | To indicate that a term is in normal form.
+--
+stepsExhausted
+ ∷ Applicative m
+ ⇒ StepT m α
+stepsExhausted = StepT . MaybeT $ pure Nothing
+
+instance MonadVar Var m ⇒ MonadVar Var (StepT m) where
+ fresh = StepT . MaybeT $ Just <$> fresh
+ named str = StepT . MaybeT $ Just <$> named str
+
+-- | A single evaluation step.
+--
+step
+ ∷ Tm0 Lang
+ → StepT M (Tm0 Lang)
+step tm =
+ out tm >>= \case
+ APP :$ m :& n :& RNil →
+ out m >>= \case
+ LAM :$ xe :& RNil → xe // n
+ _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n
+ PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ
+ _ → stepsExhausted
+
+-- | The reflexive-transitive closure of a small-step operational semantics.
+--
+star
+ ∷ Monad m
+ ⇒ (α → StepT m α)
+ → (α → m α)
+star f a =
+ runMaybeT (runStepT $ f a) >>=
+ return a `maybe` star f
+
+-- | Evaluate a term to normal form
+--
+eval ∷ Tm0 Lang → Tm0 Lang
+eval = runM . star step
+
+newtype JudgeT m α
+ = JudgeT
+ { runJudgeT ∷ ExceptT String m α
+ } deriving (Monad, Functor, Applicative, Alternative)
+
+instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where
+ fresh = JudgeT . ExceptT $ Right <$> fresh
+ named str = JudgeT . ExceptT $ Right <$> named str
+
+type Ctx = [(Var, Tm0 Lang)]
+
+raise ∷ Monad m ⇒ String → JudgeT m α
+raise = JudgeT . ExceptT . return . Left
+
+checkTy
+ ∷ Ctx
+ → Tm0 Lang
+ → Tm0 Lang
+ → JudgeT M ()
+checkTy g tm ty = do
+ let ntm = eval tm
+ nty = eval ty
+ (,) <$> out ntm <*> out nty >>= \case
+ (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do
+ z ← fresh
+ ez ← xe // var z
+ βz ← yβ // var z
+ checkTy ((z,α):g) ez βz
+ (AX :$ RNil, UNIT :$ RNil) → return ()
+ _ → do
+ ty' ← inferTy g tm
+ if ty' === nty
+ then return ()
+ else raise "Type error"
+
+inferTy
+ ∷ Ctx
+ → Tm0 Lang
+ → JudgeT M (Tm0 Lang)
+inferTy g tm = do
+ out (eval tm) >>= \case
+ V v | Just (eval → ty) ← lookup v g → return ty
+ | otherwise → raise "Ill-scoped variable"
+ APP :$ m :& n :& RNil → do
+ inferTy g m >>= out >>= \case
+ PI :$ α :& xβ :& RNil → do
+ checkTy g n α
+ eval <$> xβ // n
+ _ → raise "Expected pi type for lambda abstraction"
+ _ → raise "Only infer neutral terms"
+
+-- | @λx.x@
+--
+identityTm ∷ M (Tm0 Lang)
+identityTm = do
+ x ← fresh
+ return $ lam (x \\ var x)
+
+-- | @(λx.x)(λx.x)@
+--
+appTm ∷ M (Tm0 Lang)
+appTm = do
+ tm ← identityTm
+ return $ app tm tm
+
+-- | A demonstration of evaluating (and pretty-printing). Output:
+--
+-- @
+-- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4]
+-- @
+--
+main ∷ IO ()
+main = do
+ -- Try out the type checker
+ either fail print . runM . runExceptT . runJudgeT $ do
+ x ← fresh
+ checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit))
+
+ print . runM $ do
+ mm ← appTm
+ mmStr ← toString mm
+ mmStr' ← toString $ eval mm
+ return $ mmStr ++ " ~>* " ++ mmStr'
+
+doMap ∷ FilePath → IOSArrow XmlTree TiledMap
+doMap mapPath = proc m → do
+ mapWidth ← getAttrR "width" ⤙ m
+ returnA -< baz
+
+-- ^ An opaque ESD handle for recording data from the soundcard via ESD.
+data Recorder fr ch (r ∷ ★ → ★)
+ = Recorder {
+ reRate ∷ !Int
+ , reHandle ∷ !Handle
+ , reCloseH ∷ !(FinalizerHandle r)
+ }
+
diff --git a/tests/examples/failing/UnicodeSyntax.hs.bad b/tests/examples/failing/UnicodeSyntax.hs.bad
new file mode 100644
index 0000000..af3ce2e
--- /dev/null
+++ b/tests/examples/failing/UnicodeSyntax.hs.bad
@@ -0,0 +1,236 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnicodeSyntax #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE Arrows #-}
+
+module Tutorial where
+
+-- import Abt.Class
+-- import Abt.Types
+-- import Abt.Concrete.LocallyNameless
+
+import Control.Applicative
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Except
+-- import Data.Vinyl
+import Prelude hiding (pi)
+
+-- | We'll start off with a monad in which to manipulate ABTs; we'll need some
+-- state for fresh variable generation.
+--
+newtype M α
+ = M
+ { _M ∷ State Int α
+ } deriving (Functor, Applicative, Monad)
+
+-- | We'll run an ABT computation by starting the variable counter at @0@.
+--
+runM ∷ M α → α
+runM (M m) = evalState m 0
+
+-- | Check out the source to see fresh variable generation.
+--
+instance MonadVar Var M where
+ fresh = M $ do
+ n ← get
+ let n' = n + 1
+ put n'
+ return $ Var Nothing n'
+
+ named a = do
+ v ← fresh
+ return $ v { _varName = Just a }
+
+-- | Next, we'll define the operators for a tiny lambda calculus as a datatype
+-- indexed by arities.
+--
+data Lang ns where
+ LAM ∷ Lang '[S Z]
+ APP ∷ Lang '[Z, Z]
+ PI ∷ Lang '[Z, S Z]
+ UNIT ∷ Lang '[]
+ AX ∷ Lang '[]
+
+instance Show1 Lang where
+ show1 = \case
+ LAM → "lam"
+ APP → "ap"
+ PI → "pi"
+ UNIT → "unit"
+ AX → "<>"
+
+instance HEq1 Lang where
+ heq1 LAM LAM = Just Refl
+ heq1 APP APP = Just Refl
+ heq1 PI PI = Just Refl
+ heq1 UNIT UNIT = Just Refl
+ heq1 AX AX = Just Refl
+ heq1 _ _ = Nothing
+
+lam ∷ Tm Lang (S Z) → Tm0 Lang
+lam e = LAM $$ e :& RNil
+
+app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang
+app m n = APP $$ m :& n :& RNil
+
+ax ∷ Tm0 Lang
+ax = AX $$ RNil
+
+unit ∷ Tm0 Lang
+unit = UNIT $$ RNil
+
+pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang
+pi α xβ = PI $$ α :& xβ :& RNil
+
+-- | A monad transformer for small step operational semantics.
+--
+newtype StepT m α
+ = StepT
+ { runStepT ∷ MaybeT m α
+ } deriving (Monad, Functor, Applicative, Alternative)
+
+-- | To indicate that a term is in normal form.
+--
+stepsExhausted
+ ∷ Applicative m
+ ⇒ StepT m α
+stepsExhausted = StepT . MaybeT $ pure Nothing
+
+instance MonadVar Var m ⇒ MonadVar Var (StepT m) where
+ fresh = StepT . MaybeT $ Just <$> fresh
+ named str = StepT . MaybeT $ Just <$> named str
+
+-- | A single evaluation step.
+--
+step
+ ∷ Tm0 Lang
+ → StepT M (Tm0 Lang)
+step tm =
+ out tm >>= \case
+ APP :$ m :& n :& RNil →
+ out m >>= \case
+ LAM :$ xe :& RNil → xe // n
+ _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n
+ PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ
+ _ → stepsExhausted
+
+-- | The reflexive-transitive closure of a small-step operational semantics.
+--
+star
+ ∷ Monad m
+ ⇒ (α → StepT m α)
+ → (α → m α)
+star f a =
+ runMaybeT (runStepT $ f a) >>=
+ return a `maybe` star f
+
+-- | Evaluate a term to normal form
+--
+eval ∷ Tm0 Lang → Tm0 Lang
+eval = runM . star step
+
+newtype JudgeT m α
+ = JudgeT
+ { runJudgeT ∷ ExceptT String m α
+ } deriving (Monad, Functor, Applicative, Alternative)
+
+instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where
+ fresh = JudgeT . ExceptT $ Right <$> fresh
+ named str = JudgeT . ExceptT $ Right <$> named str
+
+type Ctx = [(Var, Tm0 Lang)]
+
+raise ∷ Monad m ⇒ String → JudgeT m α
+raise = JudgeT . ExceptT . return . Left
+
+checkTy
+ ∷ Ctx
+ → Tm0 Lang
+ → Tm0 Lang
+ → JudgeT M ()
+checkTy g tm ty = do
+ let ntm = eval tm
+ nty = eval ty
+ (,) <$> out ntm <*> out nty >>= \case
+ (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do
+ z ← fresh
+ ez ← xe // var z
+ βz ← yβ // var z
+ checkTy ((z,α):g) ez βz
+ (AX :$ RNil, UNIT :$ RNil) → return ()
+ _ → do
+ ty' ← inferTy g tm
+ if ty' === nty
+ then return ()
+ else raise "Type error"
+
+inferTy
+ ∷ Ctx
+ → Tm0 Lang
+ → JudgeT M (Tm0 Lang)
+inferTy g tm = do
+ out (eval tm) >>= \case
+ V v | Just (eval → ty) ← lookup v g → return ty
+ | otherwise → raise "Ill-scoped variable"
+ APP :$ m :& n :& RNil → do
+ inferTy g m >>= out >>= \case
+ PI :$ α :& xβ :& RNil → do
+ checkTy g n α
+ eval <$> xβ // n
+ _ → raise "Expected pi type for lambda abstraction"
+ _ → raise "Only infer neutral terms"
+
+-- | @λx.x@
+--
+identityTm ∷ M (Tm0 Lang)
+identityTm = do
+ x ← fresh
+ return $ lam (x \\ var x)
+
+-- | @(λx.x)(λx.x)@
+--
+appTm ∷ M (Tm0 Lang)
+appTm = do
+ tm ← identityTm
+ return $ app tm tm
+
+-- | A demonstration of evaluating (and pretty-printing). Output:
+--
+-- @
+-- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4]
+-- @
+--
+main ∷ IO ()
+main = do
+ -- Try out the type checker
+ either fail print . runM . runExceptT . runJudgeT $ do
+ x ← fresh
+ checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit))
+
+ print . runM $ do
+ mm ← appTm
+ mmStr ← toString mm
+ mmStr' ← toString $ eval mm
+ return $ mmStr ++ " ~>* " ++ mmStr'
+
+doMap ∷ FilePath → IOSArrow XmlTree TiledMap
+doMap mapPath = proc m → do
+ mapWidth ← getAttrR "width" ⤙ m
+ returnA -< baz
+
+-- ^ An opaque ESD handle for recording data from the soundcard via ESD.
+data Recorder fr ch (r ∷ * → *)
+ = Recorder {
+ reRate ∷ !Int
+ , reHandle ∷ !Handle
+ , reCloseH ∷ !(FinalizerHandle r)
+ }
+