on master help sign in
Merge branch 'feature/deppairparsing' of github.com:ahmadsalim/Idris-dev into feature/deppairparsing
commitdcacfeab6c6e8803676919f4de823bb8f5f4a761 authorAhmad Salim Al-Sibahi <asal@itu.dk> dateWed 30 Sep 2015, 10:40 (11 years ago) parent8e8fd65bf0fe16
6 files changed+62−35
CHANGELOG+4 src/Idris/AbsSyntaxTree.hs+27−7 src/Idris/ParseExpr.hs+27−12 test/proof003/expected−12 test/proof003/run+1−1 test/proof003/test015.idr+3−3
CHANGELOG+4
@@ -16,6 +16,10 @@ Language updates
1616 valid unbound implicit is now *always* an unbound implicit. This is much
1717 more resilient to changes in inputs, but does require that function names
1818 be explicitly qualified when in argument position.
19+* Dependent pairs now can be specified using a telescope-style syntax, without
20+ requirement of nesting, e.g. it is possible to now write the following:
21+ (a : Type ** n : Nat ** Vect n a)
22+
1923
2024Library updates
2125---------------
src/Idris/AbsSyntaxTree.hs+27−7
@@ -1820,20 +1820,35 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd
18201820 TypeOrTerm -> id
18211821 IsType -> annName pairTy
18221822 IsTerm -> annName pairCon
1823− prettySe d p bnd (PDPair _ _ pun l t r) =
1824− depth d $
1825− annotated lparen <>
1826− left <+>
1827− annotated (text "**") <+>
1828− prettySe (decD d) startPrec (addBinding bnd) r <>
1829− annotated rparen
1823+ prettySe d p bnd dpair@(PDPair _ _ pun l t r)
1824+ | Just elts <- dPairElts dpair
1825+ = depth d . enclose (annotated lparen) (annotated rparen) .
1826+ align . group . vsep . punctuate (space <> annotated (text "**")) $
1827+ ppElts elts bnd
1828+ | otherwise
1829+ = depth d $
1830+ annotated lparen <>
1831+ left <+>
1832+ annotated (text "**") <+>
1833+ prettySe (decD d) startPrec (addBinding bnd) r <>
1834+ annotated rparen
18301835 where annotated = case pun of
18311836 IsType -> annName sigmaTy
18321837 IsTerm -> annName sigmaCon
18331838 TypeOrTerm -> id
1839+
18341840 (left, addBinding) = case (l, pun) of
18351841 (PRef _ _ n, IsType) -> (bindingOf n False <+> text ":" <+> prettySe (decD d) startPrec bnd t, ((n, False) :))
18361842 _ -> (prettySe (decD d) startPrec bnd l, id)
1843+
1844+ ppElts [] bs = []
1845+ ppElts [(_, v)] bs = [prettySe (decD d) startPrec bs v]
1846+ ppElts ((PRef _ _ n, t):rs) bs
1847+ | IsType <- pun
1848+ = (bindingOf n False <+> colon <+>
1849+ prettySe (decD d) startPrec bs t) : ppElts rs ((n, False):bs)
1850+ ppElts ((l, t):rs) bs
1851+ = (prettySe (decD d) startPrec bs l) : ppElts rs bs
18371852 prettySe d p bnd (PAlternative ns a as) =
18381853 lparen <> text "|" <> prettyAs <> text "|" <> rparen
18391854 where
@@ -1951,6 +1966,11 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd
19511966 | otherwise = Just [x, y]
19521967 pairElts _ = Nothing
19531968
1969+ dPairElts :: PTerm -> Maybe [(PTerm, PTerm)]
1970+ dPairElts (PDPair _ _ _ l t r) | Just elts <- dPairElts r = Just ((l, t):elts)
1971+ | otherwise = Just [(l, t), (Placeholder, r)]
1972+ dPairElts _ = Nothing
1973+
19541974 natns = "Prelude.Nat."
19551975
19561976 snat :: PPOption -> Maybe Int -> Int -> PTerm -> Maybe Integer
src/Idris/ParseExpr.hs+27−12
@@ -402,7 +402,7 @@ simpleExpr syn =
402402 <|> do reserved "elim_for"; fc <- getFC; t <- fst <$> fnName; return (PRef fc [] (SN $ ElimN t))
403403 <|> proofExpr syn
404404 <|> tacticsExpr syn
405− <|> try (do reserved "Type"; symbol "*"; return $ PUniverse AllTypes)
405+ <|> try (do reserved "Type*"; return $ PUniverse AllTypes)
406406 <|> do reserved "AnyType"; return $ PUniverse AllTypes
407407 <|> PType <$> reservedFC "Type"
408408 <|> do reserved "UniqueType"; return $ PUniverse UniqueType
@@ -462,14 +462,19 @@ bracketed' open syn =
462462 do (FC f start (l, c)) <- getFC
463463 lchar ')'
464464 return $ PTrue (spanFC open (FC f start (l, c+1))) TypeOrTerm
465− <|> try (do (ln, lnfc) <- name
466− colonFC <- lcharFC ':'
467− lty <- expr syn
468− starsFC <- reservedOpFC "**"
465+ <|> try (do (ln, lnfc, colonFC, lty, starsFC):bnds <- some $ do
466+ (ln, lnfc, colonFC) <- try $ do
467+ (ln, lnfc) <- name
468+ colonFC <- lcharFC ':'
469+ return (ln, lnfc, colonFC)
470+ lty <- expr' syn
471+ starsFC <- reservedOpFC "**"
472+ return (ln, lnfc, colonFC, lty, starsFC)
469473 fc <- getFC
470474 r <- expr syn
471475 close <- lcharFC ')'
472− return (PDPair fc [open, colonFC, starsFC, close] TypeOrTerm (PRef lnfc [] ln) lty r))
476+ return (PDPair fc ([open, colonFC, starsFC, close] ++ (=<<) (\(_,_,cfc,_,sfc) -> [cfc, sfc]) bnds)
477+ TypeOrTerm (PRef lnfc [] ln) lty (mergePDPairs starsFC bnds r)))
473478 <|> try (do fc <- getFC; o <- operator; e <- expr syn; lchar ')'
474479 -- No prefix operators! (bit of a hack here...)
475480 if (o == "-" || o == "!")
@@ -480,7 +485,7 @@ bracketed' open syn =
480485 <|> try (do l <- simpleExpr syn
481486 op <- option Nothing (do o <- operator
482487 lchar ')'
483− return (Just o))
488+ return (Just o))
484489 fc0 <- getFC
485490 case op of
486491 Nothing -> bracketedExpr syn open l
@@ -489,25 +494,35 @@ bracketed' open syn =
489494 pexp (PRef fc0 [] (sMN 1000 "ARG"))]))
490495 <|> do l <- expr syn
491496 bracketedExpr syn open l
492−
497+ where mergePDPairs :: FC -> [(Name, FC, FC, PTerm, FC)] -> PTerm -> PTerm
498+ mergePDPairs starsFC' [] r = r
499+ mergePDPairs starsFC' ((ln, lnfc, colonFC, lty, starsFC):bnds) r =
500+ PDPair starsFC' [] TypeOrTerm (PRef lnfc [] ln) lty (mergePDPairs starsFC bnds r)
501+
493502-- | Parse the contents of parentheses, after an expression has been parsed.
494503bracketedExpr :: SyntaxInfo -> FC -> PTerm -> IdrisParser PTerm
495504bracketedExpr syn openParenFC e =
496505 do lchar ')'; return e
497− <|> do exprs <- many (do comma <- lcharFC ','
506+ <|> do exprs <- some (do comma <- lcharFC ','
498507 r <- expr syn
499508 return (r, comma))
500509 closeParenFC <- lcharFC ')'
501510 let hilite = [openParenFC, closeParenFC] ++ map snd exprs
502511 return $ PPair openParenFC hilite TypeOrTerm e (mergePairs exprs)
503− <|> do starsFC <- reservedOpFC "**"
504− r <- expr syn
512+ <|> do exprs <- some $ do
513+ starsFC <- reservedOpFC "**"
514+ r <- expr syn
515+ return (r, starsFC)
505516 closeParenFC <- lcharFC ')'
506− return (PDPair starsFC [openParenFC, starsFC, closeParenFC] TypeOrTerm e Placeholder r)
517+ let hilite = [openParenFC, closeParenFC] ++ map snd exprs
518+ return (PDPair openParenFC hilite TypeOrTerm e Placeholder (mergePDPairs exprs))
507519 <?> "end of bracketed expression"
508520 where mergePairs :: [(PTerm, FC)] -> PTerm
509521 mergePairs [(t, fc)] = t
510522 mergePairs ((t, fc):rs) = PPair fc [] TypeOrTerm t (mergePairs rs)
523+ mergePDPairs :: [(PTerm, FC)] -> PTerm
524+ mergePDPairs [(t, fc)] = t
525+ mergePDPairs ((t, fc):rs) = PDPair fc [] TypeOrTerm t Placeholder (mergePDPairs rs)
511526
512527-- bit of a hack here. If the integer doesn't fit in an Int, treat it as a
513528-- big integer, otherwise try fromInteger and the constants as alternatives.
test/proof003/expected−12
@@ -1,15 +1,3 @@
1−Parity.idr:15:18-23:
2−This style of tactic proof is deprecated. See %runElab for the replacement.
3−Parity.idr:22:18-23:
4−This style of tactic proof is deprecated. See %runElab for the replacement.
5−test015.idr:88:15-20:
6−This style of tactic proof is deprecated. See %runElab for the replacement.
7−test015.idr:97:16-21:
8−This style of tactic proof is deprecated. See %runElab for the replacement.
9−test015.idr:108:20-25:
10−This style of tactic proof is deprecated. See %runElab for the replacement.
11−test015.idr:136:20-25:
12−This style of tactic proof is deprecated. See %runElab for the replacement.
13100101010
14201011001
153010000011
test/proof003/run+1−1
@@ -1,4 +1,4 @@
11#!/usr/bin/env bash
2−idris $@ test015.idr --nocolour --consolewidth 80 -o test015
2+idris $@ test015.idr --nocolour --consolewidth 80 --no-tactic-deprecation-warnings -o test015
33./test015
44rm -f test015 Parity.ibc test015.ibc
test/proof003/test015.idr+3−3
@@ -44,11 +44,11 @@ natToBin (S w) (S k) with (parity k)
4444testBin : Maybe (Binary 8 42)
4545testBin = natToBin _ _
4646
47−pattern syntax bitpair [x] [y] = (_ ** (_ ** (x, y, _)))
48−term syntax bitpair [x] [y] = (_ ** (_ ** (x, y, Refl)))
47+pattern syntax bitpair [x] [y] = (_ ** _ ** (x, y, _))
48+term syntax bitpair [x] [y] = (_ ** _ ** (x, y, Refl))
4949
5050addBit : Bit x -> Bit y -> Bit c ->
51− (bX ** (bY ** (Bit bX, Bit bY, c + x + y = bY + 2 * bX)))
51+ (bX ** bY ** (Bit bX, Bit bY, c + x + y = bY + 2 * bX))
5252addBit b0 b0 b0 = bitpair b0 b0
5353addBit b0 b0 b1 = bitpair b0 b1
5454addBit b0 b1 b0 = bitpair b0 b1