>提供类别实例
>不需要乱搞关于函数arity的类型级推理

>对于所有输入,未定义任何未定义的输入函数.这将PRF集限制为单个不可避免的额外值⊥,而不是包含多个部分递归函数.这意味着while循环或类似的部分递归函数的任何定义都应该是未定义的.

```module Data.PRF (
-- We don't export the PRF constructor
PRF (runPRF),
) where

newtype PRF b c = PRF {runPRF :: b -> c}```

```import Prelude hiding (id, (.), fst, snd, succ)
import Control.Category

instance Category PRF where
id = PRF id
PRF f . PRF g = PRF \$f `seq` g `seq` (f . g)```

seqs要求f和g处于弱头正常形式,然后才能从中计算出任何结果;如果任一函数未定义,那么组合也将是未定义的.

```class Category a => ArrowLike a where
fst   :: a (b, d) b
snd   :: a (d, b) b
(&&&) :: a b c -> a b c' -> a b (c,c')

first :: a b c -> a (b, d) (c, d)
first = (*** id)

second :: a b c -> a (d,b) (d,c)
second = (id ***)

(***) :: a b c -> a b' c' -> a (b,b') (c,c')
f *** g = (f . fst) &&& (g . snd)```

```import qualified Prelude (fst, snd)

instance ArrowLike (->) where
fst = Prelude.fst
snd = Prelude.snd
f &&& g = \b -> (f b, g b)```

```instance ArrowLike PRF where
fst = PRF fst
snd = PRF snd
PRF f &&& PRF g = PRF \$f `seq` g `seq` (f &&& g)```

```class ArrowLike a => PrimRec a where
zero :: a b   Nat
succ :: a Nat Nat
prec :: a e c -> a (c, (Nat,e)) c -> a (Nat, e) c```

Nat是由数据Nat = Z |给出的自然数S Nat.我选择将常量函数零和后继函数视为原始递归的一部分,它们构造的Nat值的唯一解析方法是使用prec进行解构或检查.用const :: c – >替换零是很诱人的. a b c;这将是一个致命的缺陷,因为有人可以用const引入infinity = S infinity来将prec转变为无限循环.

```instance PrimRec (->) where
zero = const Z
succ = S
prec f g = go
where
go (Z, d) = f d
go (S n, d) = g (go (n, d), (n, d))```

```instance PrimRec PRF where
zero = PRF zero
succ = PRF succ
prec (PRF f) (PRF g) = PRF \$f `seq` g `seq` prec f g```

```import Prelude hiding (id, (.), fst, snd, succ)

import Control.Category
import Data.PRF

add :: PrimRec a => a (Nat, Nat) Nat
add = prec id (succ . fst)```

```match :: PrimRec a => a b c -> a (Nat, b) c -> a (Nat, b) c
match fz fs = prec fz (fs . snd)```

```one :: PrimRec a => a b Nat
one = succ . zero

nonZero :: PrimRec a => a Nat Nat
nonZero = match zero one . (id &&& id)

isZero :: PrimRec a => a Nat Nat
isZero = match one zero . (id &&& id)

isOdd :: PrimRec a => a Nat Nat
isOdd = prec zero (isZero . fst) . (id &&& id)```

```while :: PrimRec a => a s Nat -> a s s -> a s s
while test step = goTest
where
goTest = goMatch . (test &&& id)
goMatch = match id (goStep . snd)
goStep = goTest . step```

```infiniteLoop :: PrimRec a => a Nat Nat
infiniteLoop = while isOdd (succ . succ)```

```import System.IO

mseq :: Monad m => a -> m a
mseq a = a `seq` return a

run :: Show b => PRF a b -> a -> IO ()
run f i =
do
putStrLn "Compiling function"
hFlush stdout
f' <- mseq \$runPRF f
putStrLn "Running function"
hFlush stdout
n <- mseq \$f' i
print n```

```run isOdd (S \$S \$S Z)

Compiling function
Running function
S Z```

```run infiniteLoop (Z)

Compiling function```