msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

syntax for inaccessible patterns in GF

Browse Source
This commit is contained in:
krasimir
2010-03-18 19:34:30 +00:00
parent dc0a84951f
commit 0c2944fa7f
11 changed files with 38 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
src/compiler/GF/Compile/Abstract/TC.hs
View File

@@ -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

1
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -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])

2
src/compiler/GF/Grammar/Binary.hs
View File

@@ -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

1
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -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

4
src/compiler/GF/Grammar/Lexer.x
View File

@@ -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

6
src/compiler/GF/Grammar/Parser.y
View File

@@ -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

1
src/compiler/GF/Grammar/Printer.hs
View File

@@ -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

3
src/runtime/haskell/PGF.hs
View File

@@ -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

2
src/runtime/haskell/PGF/Binary.hs
View File

@@ -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

28
src/runtime/haskell/PGF/Expr.hs
View File

@@ -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

3
src/runtime/haskell/PGF/Printer.hs
View File

@@ -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