syntax for inaccessible patterns in GF

11 files changed, 38 insertions, 14 deletions

diff --git a/src/compiler/GF/Compile/Abstract/TC.hs b/src/compiler/GF/Compile/Abstract/TC.hs
index 163301838..bca54b93c 100644
--- a/src/compiler/GF/Compile/Abstract/TC.hs
+++ b/src/compiler/GF/Compile/Abstract/TC.hs
@@ -241,6 +241,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
      PFloat n -> (EFloat n : ps, i, g, k)
      PP m c xs -> (mkApp (Q m c) xss : ps, j, g',k') 
                     where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
+     PTilde t -> (t : ps, i, g, k)
      _ -> error $ render (text "undefined p2t case" <+> ppPatt Unqualified 0 p <+> text "in checkBranch")
 
   upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index ce857d3f9..13bd1a27b 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -145,6 +145,7 @@ mkPatt scope p =
     A.PInt i    -> (  scope,C.PLit (C.LInt (fromIntegral i)))
     A.PFloat f  -> (  scope,C.PLit (C.LFlt f))
     A.PString s -> (  scope,C.PLit (C.LStr s))
+    A.PTilde t  -> (  scope,C.PTilde (mkExp scope t))
 
 
 mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index 8ac7f4dea..1febdcd46 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -209,6 +209,7 @@ instance Binary Patt where
   put (PChars x)   = putWord8 16 >> put x

   put (PMacro x)   = putWord8 17 >> put x

   put (PM x y)     = putWord8 18 >> put (x,y)

+  put (PTilde x)   = putWord8 19 >> put x

   get = do tag <- getWord8

            case tag of

              0  -> get >>= \(x,y)   -> return (PC x y)

@@ -229,6 +230,7 @@ instance Binary Patt where
              16 -> get >>= \x       -> return (PChars x)

              17 -> get >>= \x       -> return (PMacro x)

              18 -> get >>= \(x,y)   -> return (PM x y)

+             19 -> get >>= \x       -> return (PTilde x)

              _  -> decodingError

 

 instance Binary TInfo where

diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index b39e0f160..371e0ac08 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -168,6 +168,7 @@ data Patt =
  | PAs Ident Patt         -- ^ as-pattern: x@p
  
  | PImplArg Patt          -- ^ placeholder for pattern for implicit argument @{p}@
+ | PTilde   Term          -- ^ inaccessible pattern
 
  -- regular expression patterns
  | PNeg Patt              -- ^ negated pattern: -p
diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x
index b776668a3..492c7ce8e 100644
--- a/src/compiler/GF/Grammar/Lexer.x
+++ b/src/compiler/GF/Grammar/Lexer.x
@@ -23,7 +23,7 @@ $i = [$l $d _ ']          -- identifier character
 $u = [\0-\255]          -- universal: any character
 
 @rsyms =    -- symbols and non-identifier-like reserved words
-   \; | \= | \{ | \} | \( | \) | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/
+   \; | \= | \{ | \} | \( | \) | \~ | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/
 
 :-
 "--" [.]* ; -- Toss single line comments
@@ -49,6 +49,7 @@ data Token
  | T_int_label
  | T_oparen
  | T_cparen
+ | T_tilde
  | T_star
  | T_starstar
  | T_plus
@@ -132,6 +133,7 @@ resWords = Map.fromList
  , b "$"  T_int_label
  , b "("  T_oparen
  , b ")"  T_cparen
+ , b "~"  T_tilde
  , b "*"  T_star
  , b "**" T_starstar
  , b "+"  T_plus
diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y
index 2a08caa1b..f1b429339 100644
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -35,6 +35,7 @@ import GF.Compile.Update (buildAnyTree)
  '$'          { T_int_label }
  '('          { T_oparen    }
  ')'          { T_cparen    }
+ '~'          { T_tilde     }
  '*'          { T_star      }
  '**'         { T_starstar  }
  '+'          { T_plus      }
@@ -487,6 +488,7 @@ Patt2
   | '[' String ']'            { PChars $2 }
   | '#' Ident                 { PMacro $2 }
   | '#' Ident '.' Ident       { PM $2 $4 }
+  | '~' Exp6                  { PTilde $2 }
   | '_'                       { PW }
   | Ident                     { PV $1 }
   | Ident '.' Ident           { PP $1 $3 [] }
@@ -526,8 +528,8 @@ ListPatt
   | PattArg ListPatt { $1 : $2 }
 
 PattArg :: { Patt }
-  : Patt2         { $1          }
-  | '{' Patt2 '}' { PImplArg $2 }
+  : Patt2         { $1                }
+  | '{' Patt2 '}' { PImplArg $2       }
 
 Arg :: { [(BindType,Ident)] }
 Arg 
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index b3b6bbf77..12f574b52 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -208,6 +208,7 @@ ppPatt q d (PFloat f)   = double f
 ppPatt q d (PString s)  = str s

 ppPatt q d (PR xs)      = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs]))

 ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)

+ppPatt q d (PTilde t)   = char '~' <> ppTerm q 6 t

 

 ppValue :: TermPrintQual -> Int -> Val -> Doc

 ppValue q d (VGen i x)    = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging

diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index a2a2154bb..9cb23bf50 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -302,7 +302,8 @@ browse pgf id = fmap (\def -> (def,producers,consumers)) definition
                    Just (ty,_,Just eqs) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
                                                           if null eqs
                                                             then empty
-                                                            else text "def" <+> vcat [let (scope,ds) = mapAccumL (ppPatt 9) [] patts
+                                                            else text "def" <+> vcat [let scope = foldl pattScope [] patts
+                                                                                          ds    = map (ppPatt 9 scope) patts
                                                                                       in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
                    Just (ty,_,Nothing ) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
                    Nothing   -> case Map.lookup id (cats (abstract pgf)) of
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index bc46390f4..424eabe71 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -128,6 +128,7 @@ instance Binary Patt where
   put PWild        = putWord8 2

   put (PLit l)     = putWord8 3 >> put l

   put (PImplArg p) = putWord8 4 >> put p

+  put (PTilde p)   = putWord8 5 >> put p

   get = do tag <- getWord8

            case tag of

              0 -> liftM2 PApp get get

@@ -135,6 +136,7 @@ instance Binary Patt where
              2 -> return PWild

              3 -> liftM  PLit get

              4 -> liftM  PImplArg get

+             5 -> liftM  PTilde get

              _ -> decodingError

 

 instance Binary Equation where

diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs
index 7d88eb798..e23f4d672 100644
--- a/src/runtime/haskell/PGF/Expr.hs
+++ b/src/runtime/haskell/PGF/Expr.hs
@@ -1,5 +1,5 @@
 module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..),

-                readExpr, showExpr, pExpr, pBinds, ppExpr, ppPatt,

+                readExpr, showExpr, pExpr, pBinds, ppExpr, ppPatt, pattScope,

 

                 mkApp,    unApp,

                 mkStr,    unStr,

@@ -68,6 +68,7 @@ data Patt =
  | PVar CId                         -- ^ variable

  | PWild                            -- ^ wildcard

  | PImplArg Patt                    -- ^ implicit argument in pattern

+ | PTilde Expr

   deriving Show

 

 -- | The equation is used to define lambda function as a sequence

@@ -223,14 +224,22 @@ ppExpr d scope (EVar i)     = ppCId (scope !! i)
 ppExpr d scope (ETyped e ty)= PP.char '<' PP.<> ppExpr 0 scope e PP.<+> PP.colon PP.<+> ppType 0 scope ty PP.<> PP.char '>'

 ppExpr d scope (EImplArg e) = PP.braces (ppExpr 0 scope e)

 

-ppPatt :: Int -> [CId] -> Patt -> ([CId],PP.Doc)

-ppPatt d scope (PApp f ps) = let (scope',ds) = mapAccumL (ppPatt 2) scope ps

-                             in (scope',ppParens (not (List.null ps) && d > 1) (ppCId f PP.<+> PP.hsep ds))

-ppPatt d scope (PLit l)    = (scope,ppLit l)

-ppPatt d scope (PVar f)    = (f:scope,ppCId f)

-ppPatt d scope PWild       = (scope,PP.char '_')

-ppPatt d scope (PImplArg p) = let (scope',d) = ppPatt 0 scope p

-                              in (scope',PP.braces d)

+ppPatt :: Int -> [CId] -> Patt -> PP.Doc

+ppPatt d scope (PApp f ps)  = let ds = List.map (ppPatt 2 scope) ps

+                              in ppParens (not (List.null ps) && d > 1) (ppCId f PP.<+> PP.hsep ds)

+ppPatt d scope (PLit l)     = ppLit l

+ppPatt d scope (PVar f)     = ppCId f

+ppPatt d scope PWild        = PP.char '_'

+ppPatt d scope (PImplArg p) = PP.braces (ppPatt 0 scope p)

+ppPatt d scope (PTilde e)   = PP.char '~' PP.<> ppExpr 6 scope e

+

+pattScope :: [CId] -> Patt -> [CId]

+pattScope scope (PApp f ps)  = foldl pattScope scope ps

+pattScope scope (PLit l)     = scope

+pattScope scope (PVar f)     = f:scope

+pattScope scope PWild        = scope

+pattScope scope (PImplArg p) = pattScope scope p                               

+pattScope scope (PTilde e)   = scope

 

 ppBind Explicit x = ppCId x

 ppBind Implicit x = PP.braces (ppCId x)

@@ -362,5 +371,6 @@ match sig f eqs as0 =
         tryMatch (PApp f1 ps1) (VApp f2 vs2      ) env | f1 == f2 = tryMatches eqs (ps1++ps) (vs2++as) res env

         tryMatch (PLit l1    ) (VLit l2          ) env | l1 == l2 = tryMatches eqs  ps        as  res env

         tryMatch (PImplArg p ) (VImplArg v       ) env            = tryMatch p v env

+        tryMatch (PTilde _   ) (_                ) env            = tryMatches eqs  ps        as  res env

         tryMatch _             _                   env            = match sig f eqs as0

 

diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
index 353b06f86..23bdc718d 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -35,7 +35,8 @@ ppFun :: CId -> (Type,Int,Maybe [Equation]) -> Doc
 ppFun f (t,_,Just eqs) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t $$
                          if null eqs
                            then empty
-                           else text "def" <+> vcat [let (scope,ds) = mapAccumL (ppPatt 9) [] patts
+                           else text "def" <+> vcat [let scope = foldl pattScope [] patts
+                                                         ds    = map (ppPatt 9 scope) patts
                                                      in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]
 ppFun f (t,_,Nothing)  = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t