-
Notifications
You must be signed in to change notification settings - Fork 2
/
Normal.hs
379 lines (291 loc) · 14.2 KB
/
Normal.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
{-# LANGUAGE GADTs, KindSignatures, OverloadedStrings, EmptyDataDecls, StandaloneDeriving, TypeSynonymInstances, TypeFamilies, MultiParamTypeClasses, ViewPatterns, RankNTypes #-}
module Normal where
import Prelude hiding (length,elem,foldl)
import Basics
import Display
import Data.Foldable
import Control.Arrow (first, second)
import Data.Sequence hiding (zip,replicate,reverse)
import Options
import qualified Data.List as L
import Permutation
data No
data Ne
data Va
type NF = Term No
type Neutral = Term Ne
type Variable = Term Va
type NF' = (NF, NF) -- value, type.
data Role = Index | Thing deriving (Eq, Show)
showRole Index = "?"
showRole Thing = "!"
data Term n :: * where
Neu :: Neutral -> NF
Var :: Variable -> Neutral
Star :: Sort -> NF
Pi :: Binder -> Ident -> Cube NF -> NF -> NF
Lam :: Binder -> Ident -> Cube NF -> NF -> NF
App :: Binder -> Neutral -> Cube NF -> Neutral -- The sort is that of the argument.
Sigma :: Binder -> Ident -> NF -> NF -> NF
Pair :: Binder -> Ident -> NF -> NF -> NF -- Pair does not bind any variable.
Proj :: Binder -> -- ^ Sort of the argument (only needed for
-- the 1st projection: 2nd projection does
-- not change relevance)
Neutral -> Bool -> -- ^ True for 1st projection; False for 2nd.
Ident -> Neutral
-- OfParam :: Ident -> NF -> Neutral
-- Destr :: Int -> Variable -> Variable -- argument: depth where destruction occurs.
Swap :: Permutation -> Variable -> Variable
Param :: Role {-TODO: Maybe the swap should be merged into the role -} -> Variable -> Variable
V :: BitVector -> Int -> Variable -- shift, deBruijn
Hole :: Irr String -> Variable
type Subst = [Cube NF]
deriving instance Eq (Term n)
deriving instance Show (Term n)
var :: Int -> NF
var x = Neu $ var' x
var'' = V nil
var' x = Var $ V nil x
-- | Hereditary substitution
subst0 :: Cube NF -> NF -> NF
subst0 u = subst (u:map (unit . var) [0..])
hole = Neu . Var . Hole . Irr
subst :: Subst -> Term n -> NF
subst f t = case t of
Neu x -> s x
Var x -> s x
Star x -> Star x
Lam o i ty bo -> Lam o i (fmap s ty) (s' bo)
(Pair o i x y) -> Pair o i (s x) (s y)
Pi o i a b -> Pi o i (fmap s a) (s' b)
Sigma o i a b -> Sigma o i (s a) (s' b)
(App o a b) -> app o (s a) (fmap s b)
(Proj o x k f) -> proj o (s x) k f
-- OfParam i x -> Neu (OfParam i (s x))
-- Destr d x -> destroy d (s x)
Hole (Irr x) -> hole x
V bv x -> let fx = f!!x in
case cubeElems fx of
[Neu (Var (V bv' y))] -> Neu $ Var $ V (bv' <> bv) y
_ | dim (f !! x) /= bvDim bv -> hole $ "error: variable access dim " ++ show (bvDim bv) ++ " expected " ++ show (dim (f!!x))
_ -> (f !! x) !? bv
Param r x -> param r (s x)
Swap q x -> swap q (s x)
where s,s' :: forall n. Term n -> NF
s' = subst (unit (var 0) : map (cmap wk) f)
s = subst f
both f (x,y) = (f x, f y)
-----------------------------
-- Hereditary operations
app :: Binder -> NF -> Cube NF -> NF
app Pred x u | dim u == 0 = x
app _ (Lam _ i _ bo) u = subst0 u bo
app o (Neu n) u = Neu (App o n u)
-- TODO: merge App Pred's
proj :: Binder -> NF -> Bool -> Ident -> NF
proj _ (Pair _ _ x y) True f = x
proj _ (Pair _ _ x y) False f = y
proj o (Neu x) k f = Neu (Proj o x k f)
wkn :: Int -> NF -> NF
wkn = wkdn 0
wkdn :: Int -> Int -> NF -> NF
wkdn d n = subst (map (unit . var) [0..d-1] ++ map (unit . var) [d+n..])
wk = wkn 1
str = strn 1
strn n = subst (replicate n (unit $ hole "str: oops!") ++ map (unit . var) [0..])
wkv :: Int -> Variable -> Variable
wkv n (Param r x) = Param r (wkv n x)
wkv n (Swap q x) = Swap q (wkv n x)
wkv n (V s x) = V s (x + n)
wkv n (Hole x) = Hole x
param :: Role -> NF -> NF
param r = transNF r noAction
-----------------------------------
-- Display
dec xs = [ x - 1 | x <- xs, x > 0]
allFreeVars :: Cube (Term n) -> [Int]
allFreeVars = L.concat . fmap freeVars . cubeElems
freeVars :: Term n -> [Int]
freeVars (Var x) = freeVars x
--freeVars (Destr _ x) = freeVars x
freeVars (Neu x) = freeVars x
freeVars (Pi _ _ a b) = allFreeVars a <> (dec $ freeVars b)
freeVars (Sigma _ _ a b) = freeVars a <> (dec $ freeVars b)
freeVars (V _ x) = [x]
freeVars (App _ a b) = freeVars a <> allFreeVars b
freeVars (Lam _ _ ty b) = allFreeVars ty <> (dec $ freeVars b)
freeVars (Star _) = mempty
freeVars (Hole _) = mempty
freeVars (Pair _ _ x y) = freeVars x <> freeVars y
freeVars (Proj _ x _ _) = freeVars x
freeVars (Param _ x) = freeVars x
freeVars (Swap _ x) = freeVars x
-- freeVars (OfParam _ x) = freeVars x
iOccursIn :: Int -> Term n -> Bool
iOccursIn x t = x `elem` (freeVars t)
allocName :: DisplayContext -> Ident -> Ident
allocName g s
| fromIrr s `elem` (fmap fromIrr g) = allocName g (modId (++ "'") s)
| otherwise = s
printIndex :: DisplayContext -> Int -> Doc
printIndex ii k
| k < 0 || k >= length ii = text "<deBrujn index" <+> pretty k <+> text "out of range>"
| otherwise = pretty (ii `index` k)
cPrint :: Int -> DisplayContext -> Term n -> Doc
cPrint p ii (Swap q x) = cPrint p ii x <> "#" <> pretty q
cPrint p ii (Var x) = cPrint p ii x
cPrint p ii (Neu x) = cPrint p ii x
cPrint p ii (Param r x) = cPrint p ii x <> text (showRole r)
-- cPrint p ii (Destr d x) = cPrint p ii x <> "%" <> pretty d
-- cPrint p ii (OfParam i x) = pretty i
-- "⌊" <> cPrint (-1) ii x <> "⌋"
cPrint p ii (Hole (Irr x)) = text x
cPrint p ii (Star i) = pretty i
cPrint p ii (V bv k) = printIndex ii k <> (mconcat $ map subscriptPretty $ map b2i $ bits bv)
cPrint p ii (Proj o x k (Irr f)) = cPrint p ii x <> (if k then "." <> pretty f else "/")
cPrint p ii t@(App _ _ _) = parensIf (p > 3) (cPrint 3 ii fct <+> sep [appl o <> printCube o 4 ii a | (o,a) <- args])
where (fct,args) = nestedApp t
cPrint p ii t@(Pi _ _ _ _) = parensIf (p > 1) (printBinders arrow ii mempty $ nestedPis t)
cPrint p ii t@(Sigma _ _ _ _) = parensIf (p > 1) (printBinders cross ii mempty $ nestedSigmas t)
cPrint p ii (t@(Lam _ _ _ _)) = parensIf (p > 1) (nestedLams ii mempty t)
cPrint p ii (Pair o name x y) = parensIf (p > (-1)) (sep [pretty name <+> text "=" <+> cPrint 0 ii x <> comm o,
cPrint (-1) ii y])
nestedPis :: NF -> ([(Ident,Bool,Cube NF,Binder)], NF)
nestedPis (Pi o i a b) = (first ([(i,0 `iOccursIn` b,a,o)] ++)) (nestedPis b)
nestedPis x = ([],x)
nestedSigmas :: NF -> ([(Ident,Bool,Cube NF,Binder)], NF)
nestedSigmas (Sigma o i a b) = (first ([(i,0 `iOccursIn` b,unit a,o)] ++)) (nestedSigmas b)
nestedSigmas x = ([],x)
printBinders :: (Binder -> Doc) -> DisplayContext -> Seq Doc -> ([(Ident,Bool,Cube NF,Binder)], NF) -> Doc
printBinders sep ii xs (((x,occurs,a,o):pis),b) = printBinders sep (i <| ii) (xs |> (printBind' ii i occurs a o <+> sep o)) (pis,b)
where i = allocName ii x
printBinders _ ii xs ([],b) = sep $ toList $ (xs |> cPrint 1 ii b)
nestedLams :: DisplayContext -> Seq Doc -> Term n -> Doc
nestedLams ii xs (Lam o x ty c) = nestedLams (i <| ii) (xs |> parens (pretty i <+> colon o <+> printCube o 0 ii ty)) c
where i = allocName ii x
nestedLams ii xs t = (text "\\ " <> (sep $ toList $ (xs |> "->")) <+> nest 3 (cPrint 0 ii t))
printCube :: Binder -> Int -> DisplayContext -> Cube (Term n) -> Doc
printCube o p ii d | dim d == 0 = cPrint p ii (d !? nil)
| otherwise = "{" <> sep (punctuate ";" [(if showIndices options then pretty i <> "↦" else mempty ) <>
cPrint 0 ii x | (i,x) <- adjust $ cubeAssocs d]) <> "}"
where adjust = case o of
Pred -> init
Regu -> id
printBind' ii name occurs d o = case not (isDummyId name) || occurs of
True -> parens $ pretty name <+> colon o <+> printCube o 0 ii d
False -> printCube o 2 ii d
nestedApp :: Neutral -> (Neutral,[(Binder, Cube NF)])
nestedApp (App o f a) = (second (++ [(o,a)])) (nestedApp f)
nestedApp t = (t,[])
prettyTerm = cPrint (-100)
instance Pretty (Term n) where
pretty = prettyTerm mempty
type Action = [(NF,NF)] -- TODO: use Seq
paramv :: BitVector -> Role -> Int -> NF
paramv bv Thing x = Neu $ Var $ Param Thing $ V bv x
paramv bv Index x = Neu $ Var $ V bv x
noAction = []
wka = map (both wk)
addAct1 as = (Neu $ Var $ V (zeros 1) 0, Neu $ Var $ V (ones 1) 0) : wka as
addAct2 as = error "accessing crap" : wka as
recVarName = synthId "°"
scopeCheck c k | 0 `iOccursIn` c = error "swapTy: improperly scoped Sigma"
| otherwise = c
swap q = swapNF q 0
swapV :: Permutation -> Variable -> Variable
swapV q x | isIdentity q = x
swapV q (V bv x) = Swap q $ V bv x
swapV q (Swap q' v) = swapV (q `after` q') v
swapV q v@(Param _ _) | isIdentity q' = v
| otherwise = Swap (simplifyPerm n q) v
where n = countParam v
q' = simplifyPerm n q
swapV q (Hole (Irr s)) = Hole $ Irr (s ++ "#")
swapV q x = Swap q x
-- FIXME: what about the role=Index? There should not be a (Param Index) in the syntax.
countParam (Param Thing x) = 1 + countParam x
countParam x = 0
fullVarCube x = full (\i -> Neu $ Var $ V i x)
swapSubst :: Permutation -> NF -> NF
swapSubst q = subst $ (apply (invert q) $ fullVarCube 0 $ permLength q) : map (unit . var) [1..]
swapNe :: Permutation -> Int -> Neutral -> Neutral
swapNe q d (Var v) = Var $ swapV q v
swapNe q d (App o f a) = App o (swapNe q d f) (swapCube q d a)
swapNe q d (Proj o x k f) = Proj o (swapNe q d x) k f
swapCube :: Permutation -> Int -> Cube NF -> Cube NF
swapCube q0 d c = apply q . subAppl q (\p -> swapNF p d) $ c
where q = reducePerm q0 (dim c) -- FIXME: reduction should never be
-- necessary; we have dimension
-- checks.
swapBinder :: Permutation -> Int -> Cube NF -> Cube NF
swapBinder = swapCube
swapNF :: Permutation -> Int -> NF -> NF
swapNF q d (Neu v) = Neu $ swapNe q d v
swapNF q d (Star x) = Star x
-- swapNF q d (Pair o i a b) = Pair o i (swapBinder q d a) (swapNF q d b)
swapNF q d (Lam o i a b) = Lam o i (swapBinder q d a) (swapSubst q $ swapNF q (d+1) b)
swapNF q d (Pi o i a b) = Pi o i (swapBinder q d a) (swapSubst q $ swapNF q (d+1) b)
-- swapNF q d (Sigma o i a b) = Sigma o i (swapBinder q d a) (swapNF q (d+1) b)
getVar :: Variable -> Int
getVar (Param _ x) = getVar x
getVar (V _ x) = x
getVar (Hole x) = (-1)
getVar (Swap _ x) = getVar x
getDepth :: Variable -> Int
getDepth (Param _ x) = 1 + getDepth x
getDepth (V _ x) = 0
getDepth (Hole x) = 0
getDepth (Swap _ x) = getDepth x
-- | Transform a term to its relational interpretation
transV :: Role -> Action -> Variable -> NF
transV Thing d (Swap q x) = swap (extendPerm q) $ transV Thing d x
transV Index d (Swap q x) = swap q $ transV Index d x
transV r d (V bv x) | x < L.length d = Neu $ Var $ case r of Thing -> V (bv <> ones 1) x; Index -> V (bv <> zeros 1) x
| otherwise = paramv bv r x
-- transV r [] (Param r' x) = Neu $ Var $ Param r $ Param r' x
transV r d (Param r' x)
| getVar x < L.length d = maybeSwap $ param r' $ transV r d x -- the inner variable is known; go through
| otherwise = Neu $ Var $ maybeParam $ Param r' x -- the inner variable is not known ~> stop here and forget about other variables
where maybeSwap = if r == Thing then swap (swap2 (n+2) (n+1) n) else id -- add a swap if we are doing "proper" parametricity
maybeParam = if r == Thing then Param r else id -- keep only "proper" parametricity
n = getDepth x
transV r d (Hole (Irr s)) = hole (s ++ showRole r)
transNe :: Role -> Action -> Neutral -> NF
transNe r d (Var v) = transV r d v
transNe Thing d (App o f a) = app o (transNe Thing d f) (extend d a)
transNe Index d (App o f a) = app o (transNe Index d f) (cmap (transNF Index d) a)
transNe r d (Proj o x k f) = proj o (transNe r d x) k f
isLam :: Term n -> Bool
isLam (Lam _ _ _ _) = True
isLam _ = False
transNF :: Role -> Action -> NF -> NF
transNF r d (Neu v) = transNe r d v
transNF r d p@(Lam Pred i ty bo) = Lam Pred i (updateCube ix p $ extend d ty) (inTrans (addAct1 d) bo (Neu $ Var $ V ix 0))
where ix = ones (dim ty) <> zeros 1
transNF r d (Lam o i ty bo) = Lam o i (extend d ty) (transNF r (addAct1 d) bo)
transNF r d (Pair o i x y) = Pair o i (transNF r d x) (transNF r d y)
transNF Index d (Star x) = Star x
transNF Index d (Pi o i a b) = Pi o i (cmap (transNF Index d) a) (transNF Index d b)
transNF Index d (Sigma o i a b) = Sigma o i ((transNF Index d) a) (transNF Index d b)
transNF r d ty@(Star _) = trans' r d ty
transNF r d ty@(Pi _ _ _ _) = trans' r d ty
transNF r d ty@(Sigma _ _ _ _) = trans' r d ty
extend d a = cubeCons (cmap (transNF Index d) a) (cmap (transNF Thing d) a)
trans' :: Role -> Action -> NF -> NF
trans' Index d ty = error $ "trans': Index: wrong arg: " ++ show ty
trans' Thing d ty = Lam Pred (synthId "z") (unit1 (transNF Index d ty)) (zerInRel d ty)
-- | Build the relation x ∈ ⟦ty⟧. (where 'x' is 0; but not bound in 'ty'.)
zerInRel :: Action -> NF -> NF
zerInRel d ty = inTrans (addAct2 d) (wk ty) (Neu $ Var $ V (zeros 1) 0)
-- | Build a relation z ∈ ⟦ty⟧. z is a term that, after renaming,
-- gives the vector of terms member of the relation. Note that
-- 'trans' is never applied to 'z', therefore 'zR' never occurs in the result.
inTrans :: Action -> NF -> NF -> NF
inTrans d (Neu (App Pred f a)) z = app Pred (transNe Thing d f) (updateCube (ones (dim a) <> zeros 1) z (extend d a))
inTrans d (Star (Sort l δ)) z = (Pi Pred dummyId (unit1 z) (Star $ Sort l (δ+1)))
inTrans d (Pi Pred i a (Star (Sort l δ))) z = Pi Pred i (updateCube (ones (dim a) <> zeros 1) z (extend d a)) (Star $ Sort l (δ+1))
inTrans d (Pi o i a b) z = Pi o i (extend d a) (inTrans (addAct1 d) b (app o (wk z) (unit $ transNF Index (addAct1 d) $ var 0)))
inTrans d (Sigma o i a b) z = Sigma o i (inTrans d a (proj o z True i))
(inTrans ((wk $ proj o z True i,var 0):wka d) b (proj o (wk z) False i))
inTrans d ty z = app Pred (transNF Thing d ty) (unit1 z)
unit1 z = (pair z (hole "⊘"))