GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-24 02:12:50 -06:00
Code Issues Packages Projects Releases Wiki 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) PFloat n -> (EFloat n : ps, i, g, k)
PP m c xs -> (mkApp (Q m c) xss : ps, j, 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 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") _ -> 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 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.PInt i -> ( scope,C.PLit (C.LInt (fromIntegral i)))
A.PFloat f -> ( scope,C.PLit (C.LFlt f)) A.PFloat f -> ( scope,C.PLit (C.LFlt f))
A.PString s -> ( scope,C.PLit (C.LStr s)) 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]) 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 (PChars x) = putWord8 16 >> put x
put (PMacro x) = putWord8 17 >> put x put (PMacro x) = putWord8 17 >> put x
put (PM x y) = putWord8 18 >> put (x,y) put (PM x y) = putWord8 18 >> put (x,y)
put (PTilde x) = putWord8 19 >> put x
get = do tag <- getWord8 get = do tag <- getWord8
case tag of case tag of
0 -> get >>= \(x,y) -> return (PC x y) 0 -> get >>= \(x,y) -> return (PC x y)
@@ -229,6 +230,7 @@ instance Binary Patt where
16 -> get >>= \x -> return (PChars x) 16 -> get >>= \x -> return (PChars x)
17 -> get >>= \x -> return (PMacro x) 17 -> get >>= \x -> return (PMacro x)
18 -> get >>= \(x,y) -> return (PM x y) 18 -> get >>= \(x,y) -> return (PM x y)
19 -> get >>= \x -> return (PTilde x)
_ -> decodingError _ -> decodingError
instance Binary TInfo where 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 | PAs Ident Patt -- ^ as-pattern: x@p
| PImplArg Patt -- ^ placeholder for pattern for implicit argument @{p}@ | PImplArg Patt -- ^ placeholder for pattern for implicit argument @{p}@
| PTilde Term -- ^ inaccessible pattern
-- regular expression patterns -- regular expression patterns
| PNeg Patt -- ^ negated pattern: -p | 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 $u = [\0-\255] -- universal: any character
@rsyms = -- symbols and non-identifier-like reserved words @rsyms = -- symbols and non-identifier-like reserved words
\; | \= | \{ | \} | \( | \) | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/ \; | \= | \{ | \} | \( | \) | \~ | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/
:- :-
"--" [.]* ; -- Toss single line comments "--" [.]* ; -- Toss single line comments
@@ -49,6 +49,7 @@ data Token
| T_int_label | T_int_label
| T_oparen | T_oparen
| T_cparen | T_cparen
| T_tilde
| T_star | T_star
| T_starstar | T_starstar
| T_plus | T_plus
@@ -132,6 +133,7 @@ resWords = Map.fromList
, b "$" T_int_label , b "$" T_int_label
, b "(" T_oparen , b "(" T_oparen
, b ")" T_cparen , b ")" T_cparen
, b "~" T_tilde
, b "*" T_star , b "*" T_star
, b "**" T_starstar , b "**" T_starstar
, b "+" T_plus , b "+" T_plus

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

@@ -35,6 +35,7 @@ import GF.Compile.Update (buildAnyTree)
'$' { T_int_label } '$' { T_int_label }
'(' { T_oparen } '(' { T_oparen }
')' { T_cparen } ')' { T_cparen }
'~' { T_tilde }
'*' { T_star } '*' { T_star }
'**' { T_starstar } '**' { T_starstar }
'+' { T_plus } '+' { T_plus }
@@ -487,6 +488,7 @@ Patt2
| '[' String ']' { PChars $2 } | '[' String ']' { PChars $2 }
| '#' Ident { PMacro $2 } | '#' Ident { PMacro $2 }
| '#' Ident '.' Ident { PM $2 $4 } | '#' Ident '.' Ident { PM $2 $4 }
| '~' Exp6 { PTilde $2 }
| '_' { PW } | '_' { PW }
| Ident { PV $1 } | Ident { PV $1 }
| Ident '.' Ident { PP $1 $3 [] } | Ident '.' Ident { PP $1 $3 [] }

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 (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 (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 (PImplArg p) = braces (ppPatt q 0 p)
ppPatt q d (PTilde t) = char '~' <> ppTerm q 6 t
ppValue :: TermPrintQual -> Int -> Val -> Doc ppValue :: TermPrintQual -> Int -> Val -> Doc
ppValue q d (VGen i x) = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging 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 $$ Just (ty,_,Just eqs) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
if null eqs if null eqs
then empty 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]) 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) Just (ty,_,Nothing ) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
Nothing -> case Map.lookup id (cats (abstract pgf)) of 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 PWild = putWord8 2
put (PLit l) = putWord8 3 >> put l put (PLit l) = putWord8 3 >> put l
put (PImplArg p) = putWord8 4 >> put p put (PImplArg p) = putWord8 4 >> put p
put (PTilde p) = putWord8 5 >> put p
get = do tag <- getWord8 get = do tag <- getWord8
case tag of case tag of
0 -> liftM2 PApp get get 0 -> liftM2 PApp get get
@@ -135,6 +136,7 @@ instance Binary Patt where
2 -> return PWild 2 -> return PWild
3 -> liftM PLit get 3 -> liftM PLit get
4 -> liftM PImplArg get 4 -> liftM PImplArg get
5 -> liftM PTilde get
_ -> decodingError _ -> decodingError
instance Binary Equation where 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(..), module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..),
readExpr, showExpr, pExpr, pBinds, ppExpr, ppPatt, readExpr, showExpr, pExpr, pBinds, ppExpr, ppPatt, pattScope,
mkApp, unApp, mkApp, unApp,
mkStr, unStr, mkStr, unStr,
@@ -68,6 +68,7 @@ data Patt =
| PVar CId -- ^ variable | PVar CId -- ^ variable
| PWild -- ^ wildcard | PWild -- ^ wildcard
| PImplArg Patt -- ^ implicit argument in pattern | PImplArg Patt -- ^ implicit argument in pattern
| PTilde Expr
deriving Show deriving Show
-- | The equation is used to define lambda function as a sequence -- | 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 (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) ppExpr d scope (EImplArg e) = PP.braces (ppExpr 0 scope e)
ppPatt :: Int -> [CId] -> Patt -> ([CId],PP.Doc) ppPatt :: Int -> [CId] -> Patt -> PP.Doc
ppPatt d scope (PApp f ps) = let (scope',ds) = mapAccumL (ppPatt 2) scope ps ppPatt d scope (PApp f ps) = let ds = List.map (ppPatt 2 scope) ps
in (scope',ppParens (not (List.null ps) && d > 1) (ppCId f PP.<+> PP.hsep ds)) in ppParens (not (List.null ps) && d > 1) (ppCId f PP.<+> PP.hsep ds)
ppPatt d scope (PLit l) = (scope,ppLit l) ppPatt d scope (PLit l) = ppLit l
ppPatt d scope (PVar f) = (f:scope,ppCId f) ppPatt d scope (PVar f) = ppCId f
ppPatt d scope PWild = (scope,PP.char '_') ppPatt d scope PWild = PP.char '_'
ppPatt d scope (PImplArg p) = let (scope',d) = ppPatt 0 scope p ppPatt d scope (PImplArg p) = PP.braces (ppPatt 0 scope p)
in (scope',PP.braces d) 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 Explicit x = ppCId x
ppBind Implicit x = PP.braces (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 (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 (PLit l1 ) (VLit l2 ) env | l1 == l2 = tryMatches eqs ps as res env
tryMatch (PImplArg p ) (VImplArg v ) env = tryMatch p v 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 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 $$ ppFun f (t,_,Just eqs) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t $$
if null eqs if null eqs
then empty 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] 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 ppFun f (t,_,Nothing) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t