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

Added support for list categories.

Browse Source
This commit is contained in:
bringert
2005-05-25 09:41:59 +00:00
parent b3f5a2d7a1
commit e2dc03a9ca
10 changed files with 1947 additions and 1102 deletions
Download Patch File Download Diff File Expand all files Collapse all files

27
src/GF/Source/AbsGF.hs
View File

@@ -79,10 +79,10 @@ data Included =
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data Def = data Def =
DDecl [Ident] Exp DDecl [Name] Exp
| DDef [Ident] Exp | DDef [Name] Exp
| DPatt Ident [Patt] Exp | DPatt Name [Patt] Exp
| DFull [Ident] Exp Exp | DFull [Name] Exp Exp
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data TopDef = data TopDef =
@@ -109,7 +109,9 @@ data TopDef =
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data CatDef = data CatDef =
CatDef Ident [DDecl] SimpleCatDef Ident [DDecl]
| ListCatDef Ident [DDecl]
| ListSizeCatDef Ident [DDecl] Integer
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data FunDef = data FunDef =
@@ -136,13 +138,18 @@ data ParConstr =
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data PrintDef = data PrintDef =
PrintDef [Ident] Exp PrintDef [Name] Exp
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data FlagDef = data FlagDef =
FlagDef Ident Ident FlagDef Ident Ident
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data Name =
IdentName Ident
| ListName Ident
deriving (Eq,Ord,Show)
data LocDef = data LocDef =
LDDecl [Ident] Exp LDDecl [Ident] Exp
| LDDef [Ident] Exp | LDDef [Ident] Exp
@@ -159,6 +166,7 @@ data Exp =
| EMeta | EMeta
| EEmpty | EEmpty
| EData | EData
| EList Ident Exps
| EStrings String | EStrings String
| ERecord [LocDef] | ERecord [LocDef]
| ETuple [TupleComp] | ETuple [TupleComp]
@@ -169,8 +177,8 @@ data Exp =
| EQCons Ident Ident | EQCons Ident Ident
| EApp Exp Exp | EApp Exp Exp
| ETable [Case] | ETable [Case]
| EVTable Exp [Exp]
| ETTable Exp [Case] | ETTable Exp [Case]
| EVTable Exp [Exp]
| ECase Exp [Case] | ECase Exp [Case]
| EVariants [Exp] | EVariants [Exp]
| EPre Exp [Altern] | EPre Exp [Altern]
@@ -193,6 +201,11 @@ data Exp =
| ELin Ident | ELin Ident
deriving (Eq,Ord,Show) deriving (Eq,Ord,Show)
data Exps =
NilExp
| ConsExp Exp Exps
deriving (Eq,Ord,Show)
data Patt = data Patt =
PW PW
| PV Ident | PV Ident

22
src/GF/Source/GrammarToSource.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/04/21 16:23:25 $ -- > CVS $Date: 2005/05/25 10:41:59 $
-- > CVS $Author: bringert $ -- > CVS $Author: bringert $
-- > CVS $Revision: 1.19 $ -- > CVS $Revision: 1.20 $
-- --
-- From internal source syntax to BNFC-generated (used for printing). -- From internal source syntax to BNFC-generated (used for printing).
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@@ -72,16 +72,16 @@ mkTopDefs ds = ds
trAnyDef :: (Ident,Info) -> [P.TopDef] trAnyDef :: (Ident,Info) -> [P.TopDef]
trAnyDef (i,info) = let i' = tri i in case info of trAnyDef (i,info) = let i' = tri i in case info of
AbsCat (Yes co) pd -> [P.DefCat [P.CatDef i' (map trDecl co)]] ++ case pd of AbsCat (Yes co) pd -> [P.DefCat [P.SimpleCatDef i' (map trDecl co)]] ++ case pd of
Yes fs -> [P.DefData [P.DataDef i' [P.DataQId (tri m) (tri c) | QC m c <- fs]]] Yes fs -> [P.DefData [P.DataDef i' [P.DataQId (tri m) (tri c) | QC m c <- fs]]]
_ -> [] _ -> []
AbsFun (Yes ty) pt -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ case pt of AbsFun (Yes ty) pt -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ case pt of
Yes EData -> [] -- keep this information in data defs only Yes EData -> [] -- keep this information in data defs only
Yes t -> [P.DefDef [P.DDef [i'] (trt t)]] Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
_ -> [] _ -> []
AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]] AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]]
---- don't destroy definitions! ---- don't destroy definitions!
AbsTrans f -> [P.DefTrans [P.DDef [i'] (trt f)]] AbsTrans f -> [P.DefTrans [P.DDef [mkName i'] (trt f)]]
ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]] ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
ResParam pp -> [P.DefPar [case pp of ResParam pp -> [P.DefPar [case pp of
@@ -90,7 +90,7 @@ trAnyDef (i,info) = let i' = tri i in case info of
_ -> P.ParDefAbs i']] _ -> P.ParDefAbs i']]
CncCat (Yes ty) Nope _ -> CncCat (Yes ty) Nope _ ->
[P.DefLincat [P.PrintDef [i'] (trt ty)]] [P.DefLincat [P.PrintDef [mkName i'] (trt ty)]]
CncCat pty ptr ppr -> CncCat pty ptr ppr ->
[P.DefLindef [trDef i' pty ptr]] [P.DefLindef [trDef i' pty ptr]]
---- P.DefPrintCat [P.PrintDef i' (trt pr)]] ---- P.DefPrintCat [P.PrintDef i' (trt pr)]]
@@ -101,10 +101,10 @@ trAnyDef (i,info) = let i' = tri i in case info of
trDef :: Ident -> Perh Type -> Perh Term -> P.Def trDef :: Ident -> Perh Type -> Perh Term -> P.Def
trDef i pty ptr = case (pty,ptr) of trDef i pty ptr = case (pty,ptr) of
(Nope, Nope) -> P.DDef [i] (P.EMeta) --- (Nope, Nope) -> P.DDef [mkName i] (P.EMeta) ---
(_, Nope) -> P.DDecl [i] (trPerh pty) (_, Nope) -> P.DDecl [mkName i] (trPerh pty)
(Nope, _ ) -> P.DDef [i] (trPerh ptr) (Nope, _ ) -> P.DDef [mkName i] (trPerh ptr)
(_, _ ) -> P.DFull [i] (trPerh pty) (trPerh ptr) (_, _ ) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr)
trPerh p = case p of trPerh p = case p of
Yes t -> trt t Yes t -> trt t
@@ -221,3 +221,5 @@ trLabelIdent i = identC $ case i of
LIdent s -> s LIdent s -> s
LVar i -> "v" ++ show i --- should not happen LVar i -> "v" ++ show i --- should not happen
mkName :: Ident -> P.Name
mkName = P.IdentName

138
src/GF/Source/LexGF.hs
View File

File diff suppressed because one or more lines are too long

34
src/GF/Source/LexGF.x
View File

@@ -1,9 +1,10 @@
-- -*- haskell -*- -- -*- haskell -*-
-- This Alex file was machine-generated by the BNF converter -- This Alex file was machine-generated by the BNF converter
{ {
module LexGF where module GF.Source.LexGF where -- H
import ErrM import GF.Data.ErrM -- H
import GF.Data.SharedString -- H
} }
@@ -15,34 +16,37 @@ $i = [$l $d _ '] -- identifier character
$u = [\0-\255] -- universal: any character $u = [\0-\255] -- universal: any character
@rsyms = -- reserved words consisting of special symbols @rsyms = -- reserved words consisting of special symbols
\; | \= | \{ | \} | \( | \) | \: | \- \> | \* \* | \, | \[ | \] | \. | \| | \? | \< | \> | \@ | \! | \* | \\ | \= \> | \+ \+ | \+ | \_ | \$ | \/ | \- \; | \= | \{ | \} | \( | \) | \: | \- \> | \* \* | \, | \[ | \] | \. | \| | \% | \? | \< | \> | \@ | \! | \* | \\ | \= \> | \+ \+ | \+ | \_ | \$ | \/ | \-
:- :-
"--" [.]* ; -- Toss single line comments "--" [.]* ; -- Toss single line comments
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; "{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
$white+ ; $white+ ;
@rsyms { tok (\p s -> PT p (TS s)) } @rsyms { tok (\p s -> PT p (TS $ share s)) }
\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent T_LString s)) } \' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent TV s)) } $l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ unescapeInitTail s)) } \" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
$d+ { tok (\p s -> PT p (TI s)) } $d+ { tok (\p s -> PT p (TI $ share s)) }
{ {
tok f p s = f p s tok f p s = f p s
share :: String -> String
share = shareString
data Tok = data Tok =
TS String -- reserved words TS !String -- reserved words
| TL String -- string literals | TL !String -- string literals
| TI String -- integer literals | TI !String -- integer literals
| TV String -- identifiers | TV !String -- identifiers
| TD String -- double precision float literals | TD !String -- double precision float literals
| TC String -- character literals | TC !String -- character literals
| T_LString String | T_LString !String
deriving (Eq,Show,Ord) deriving (Eq,Show,Ord)

2067
src/GF/Source/ParGF.hs
View File

File diff suppressed because one or more lines are too long

597
src/GF/Source/ParGF.y Normal file
View File

@@ -0,0 +1,597 @@
-- This Happy file was machine-generated by the BNF converter
{
module GF.Source.ParGF where -- H
import GF.Source.AbsGF -- H
import GF.Source.LexGF -- H
import GF.Infra.Ident -- H
import GF.Data.ErrM -- H
}
%name pGrammar Grammar
%name pModDef ModDef
%name pOldGrammar OldGrammar
%name pExp Exp
-- no lexer declaration
%monad { Err } { thenM } { returnM }
%tokentype { Token }
%token
';' { PT _ (TS ";") }
'=' { PT _ (TS "=") }
'{' { PT _ (TS "{") }
'}' { PT _ (TS "}") }
'(' { PT _ (TS "(") }
')' { PT _ (TS ")") }
':' { PT _ (TS ":") }
'->' { PT _ (TS "->") }
'**' { PT _ (TS "**") }
',' { PT _ (TS ",") }
'[' { PT _ (TS "[") }
']' { PT _ (TS "]") }
'.' { PT _ (TS ".") }
'|' { PT _ (TS "|") }
'%' { PT _ (TS "%") }
'?' { PT _ (TS "?") }
'<' { PT _ (TS "<") }
'>' { PT _ (TS ">") }
'@' { PT _ (TS "@") }
'!' { PT _ (TS "!") }
'*' { PT _ (TS "*") }
'\\' { PT _ (TS "\\") }
'=>' { PT _ (TS "=>") }
'++' { PT _ (TS "++") }
'+' { PT _ (TS "+") }
'_' { PT _ (TS "_") }
'$' { PT _ (TS "$") }
'/' { PT _ (TS "/") }
'-' { PT _ (TS "-") }
'Lin' { PT _ (TS "Lin") }
'PType' { PT _ (TS "PType") }
'Str' { PT _ (TS "Str") }
'Strs' { PT _ (TS "Strs") }
'Tok' { PT _ (TS "Tok") }
'Type' { PT _ (TS "Type") }
'abstract' { PT _ (TS "abstract") }
'case' { PT _ (TS "case") }
'cat' { PT _ (TS "cat") }
'concrete' { PT _ (TS "concrete") }
'data' { PT _ (TS "data") }
'def' { PT _ (TS "def") }
'flags' { PT _ (TS "flags") }
'fn' { PT _ (TS "fn") }
'fun' { PT _ (TS "fun") }
'grammar' { PT _ (TS "grammar") }
'in' { PT _ (TS "in") }
'include' { PT _ (TS "include") }
'incomplete' { PT _ (TS "incomplete") }
'instance' { PT _ (TS "instance") }
'interface' { PT _ (TS "interface") }
'let' { PT _ (TS "let") }
'lin' { PT _ (TS "lin") }
'lincat' { PT _ (TS "lincat") }
'lindef' { PT _ (TS "lindef") }
'lintype' { PT _ (TS "lintype") }
'of' { PT _ (TS "of") }
'open' { PT _ (TS "open") }
'oper' { PT _ (TS "oper") }
'out' { PT _ (TS "out") }
'package' { PT _ (TS "package") }
'param' { PT _ (TS "param") }
'pattern' { PT _ (TS "pattern") }
'pre' { PT _ (TS "pre") }
'printname' { PT _ (TS "printname") }
'resource' { PT _ (TS "resource") }
'reuse' { PT _ (TS "reuse") }
'strs' { PT _ (TS "strs") }
'table' { PT _ (TS "table") }
'tokenizer' { PT _ (TS "tokenizer") }
'transfer' { PT _ (TS "transfer") }
'union' { PT _ (TS "union") }
'var' { PT _ (TS "var") }
'variants' { PT _ (TS "variants") }
'where' { PT _ (TS "where") }
'with' { PT _ (TS "with") }
L_ident { PT _ (TV $$) }
L_integ { PT _ (TI $$) }
L_quoted { PT _ (TL $$) }
L_LString { PT _ (T_LString $$) }
L_err { _ }
%%
Ident :: { Ident } : L_ident { identC $1 } -- H
Integer :: { Integer } : L_integ { (read $1) :: Integer }
String :: { String } : L_quoted { $1 }
LString :: { LString} : L_LString { LString ($1)}
Grammar :: { Grammar }
Grammar : ListModDef { Gr (reverse $1) }
ListModDef :: { [ModDef] }
ListModDef : {- empty -} { [] }
| ListModDef ModDef { flip (:) $1 $2 }
ModDef :: { ModDef }
ModDef : ModDef ';' { $1 }
| 'grammar' Ident '=' '{' 'abstract' '=' Ident ';' ListConcSpec '}' { MMain $2 $7 $9 }
| ComplMod ModType '=' ModBody { MModule $1 $2 $4 }
ConcSpec :: { ConcSpec }
ConcSpec : Ident '=' ConcExp { ConcSpec $1 $3 }
ListConcSpec :: { [ConcSpec] }
ListConcSpec : {- empty -} { [] }
| ConcSpec { (:[]) $1 }
| ConcSpec ';' ListConcSpec { (:) $1 $3 }
ConcExp :: { ConcExp }
ConcExp : Ident ListTransfer { ConcExp $1 (reverse $2) }
ListTransfer :: { [Transfer] }
ListTransfer : {- empty -} { [] }
| ListTransfer Transfer { flip (:) $1 $2 }
Transfer :: { Transfer }
Transfer : '(' 'transfer' 'in' Open ')' { TransferIn $4 }
| '(' 'transfer' 'out' Open ')' { TransferOut $4 }
ModType :: { ModType }
ModType : 'abstract' Ident { MTAbstract $2 }
| 'resource' Ident { MTResource $2 }
| 'interface' Ident { MTInterface $2 }
| 'concrete' Ident 'of' Ident { MTConcrete $2 $4 }
| 'instance' Ident 'of' Ident { MTInstance $2 $4 }
| 'transfer' Ident ':' Open '->' Open { MTTransfer $2 $4 $6 }
ModBody :: { ModBody }
ModBody : Extend Opens '{' ListTopDef '}' { MBody $1 $2 (reverse $4) }
| Ident 'with' ListOpen { MWith $1 $3 }
| ListIdent '**' Ident 'with' ListOpen { MWithE $1 $3 $5 }
| 'reuse' Ident { MReuse $2 }
| 'union' ListIncluded { MUnion $2 }
ListTopDef :: { [TopDef] }
ListTopDef : {- empty -} { [] }
| ListTopDef TopDef { flip (:) $1 $2 }
Extend :: { Extend }
Extend : ListIdent '**' { Ext $1 }
| {- empty -} { NoExt }
ListOpen :: { [Open] }
ListOpen : {- empty -} { [] }
| Open { (:[]) $1 }
| Open ',' ListOpen { (:) $1 $3 }
Opens :: { Opens }
Opens : {- empty -} { NoOpens }
| 'open' ListOpen 'in' { OpenIn $2 }
Open :: { Open }
Open : Ident { OName $1 }
| '(' QualOpen Ident ')' { OQualQO $2 $3 }
| '(' QualOpen Ident '=' Ident ')' { OQual $2 $3 $5 }
ComplMod :: { ComplMod }
ComplMod : {- empty -} { CMCompl }
| 'incomplete' { CMIncompl }
QualOpen :: { QualOpen }
QualOpen : {- empty -} { QOCompl }
| 'incomplete' { QOIncompl }
| 'interface' { QOInterface }
ListIncluded :: { [Included] }
ListIncluded : {- empty -} { [] }
| Included { (:[]) $1 }
| Included ',' ListIncluded { (:) $1 $3 }
Included :: { Included }
Included : Ident { IAll $1 }
| Ident '[' ListIdent ']' { ISome $1 $3 }
Def :: { Def }
Def : ListName ':' Exp { DDecl $1 $3 }
| ListName '=' Exp { DDef $1 $3 }
| Name ListPatt '=' Exp { DPatt $1 $2 $4 }
| ListName ':' Exp '=' Exp { DFull $1 $3 $5 }
TopDef :: { TopDef }
TopDef : 'cat' ListCatDef { DefCat $2 }
| 'fun' ListFunDef { DefFun $2 }
| 'data' ListFunDef { DefFunData $2 }
| 'def' ListDef { DefDef $2 }
| 'data' ListDataDef { DefData $2 }
| 'transfer' ListDef { DefTrans $2 }
| 'param' ListParDef { DefPar $2 }
| 'oper' ListDef { DefOper $2 }
| 'lincat' ListPrintDef { DefLincat $2 }
| 'lindef' ListDef { DefLindef $2 }
| 'lin' ListDef { DefLin $2 }
| 'printname' 'cat' ListPrintDef { DefPrintCat $3 }
| 'printname' 'fun' ListPrintDef { DefPrintFun $3 }
| 'flags' ListFlagDef { DefFlag $2 }
| 'printname' ListPrintDef { DefPrintOld $2 }
| 'lintype' ListDef { DefLintype $2 }
| 'pattern' ListDef { DefPattern $2 }
| 'package' Ident '=' '{' ListTopDef '}' ';' { DefPackage $2 (reverse $5) }
| 'var' ListDef { DefVars $2 }
| 'tokenizer' Ident ';' { DefTokenizer $2 }
CatDef :: { CatDef }
CatDef : Ident ListDDecl { SimpleCatDef $1 (reverse $2) }
| '[' Ident ListDDecl ']' { ListCatDef $2 (reverse $3) }
| '[' Ident ListDDecl ']' '{' Integer '}' { ListSizeCatDef $2 (reverse $3) $6 }
FunDef :: { FunDef }
FunDef : ListIdent ':' Exp { FunDef $1 $3 }
DataDef :: { DataDef }
DataDef : Ident '=' ListDataConstr { DataDef $1 $3 }
DataConstr :: { DataConstr }
DataConstr : Ident { DataId $1 }
| Ident '.' Ident { DataQId $1 $3 }
ListDataConstr :: { [DataConstr] }
ListDataConstr : {- empty -} { [] }
| DataConstr { (:[]) $1 }
| DataConstr '|' ListDataConstr { (:) $1 $3 }
ParDef :: { ParDef }
ParDef : Ident '=' ListParConstr { ParDefDir $1 $3 }
| Ident '=' '(' 'in' Ident ')' { ParDefIndir $1 $5 }
| Ident { ParDefAbs $1 }
ParConstr :: { ParConstr }
ParConstr : Ident ListDDecl { ParConstr $1 (reverse $2) }
PrintDef :: { PrintDef }
PrintDef : ListName '=' Exp { PrintDef $1 $3 }
FlagDef :: { FlagDef }
FlagDef : Ident '=' Ident { FlagDef $1 $3 }
ListDef :: { [Def] }
ListDef : Def ';' { (:[]) $1 }
| Def ';' ListDef { (:) $1 $3 }
ListCatDef :: { [CatDef] }
ListCatDef : CatDef ';' { (:[]) $1 }
| CatDef ';' ListCatDef { (:) $1 $3 }
ListFunDef :: { [FunDef] }
ListFunDef : FunDef ';' { (:[]) $1 }
| FunDef ';' ListFunDef { (:) $1 $3 }
ListDataDef :: { [DataDef] }
ListDataDef : DataDef ';' { (:[]) $1 }
| DataDef ';' ListDataDef { (:) $1 $3 }
ListParDef :: { [ParDef] }
ListParDef : ParDef ';' { (:[]) $1 }
| ParDef ';' ListParDef { (:) $1 $3 }
ListPrintDef :: { [PrintDef] }
ListPrintDef : PrintDef ';' { (:[]) $1 }
| PrintDef ';' ListPrintDef { (:) $1 $3 }
ListFlagDef :: { [FlagDef] }
ListFlagDef : FlagDef ';' { (:[]) $1 }
| FlagDef ';' ListFlagDef { (:) $1 $3 }
ListParConstr :: { [ParConstr] }
ListParConstr : {- empty -} { [] }
| ParConstr { (:[]) $1 }
| ParConstr '|' ListParConstr { (:) $1 $3 }
ListIdent :: { [Ident] }
ListIdent : Ident { (:[]) $1 }
| Ident ',' ListIdent { (:) $1 $3 }
Name :: { Name }
Name : Ident { IdentName $1 }
| '[' Ident ']' { ListName $2 }
ListName :: { [Name] }
ListName : Name { (:[]) $1 }
| Name ',' ListName { (:) $1 $3 }
LocDef :: { LocDef }
LocDef : ListIdent ':' Exp { LDDecl $1 $3 }
| ListIdent '=' Exp { LDDef $1 $3 }
| ListIdent ':' Exp '=' Exp { LDFull $1 $3 $5 }
ListLocDef :: { [LocDef] }
ListLocDef : {- empty -} { [] }
| LocDef { (:[]) $1 }
| LocDef ';' ListLocDef { (:) $1 $3 }
Exp4 :: { Exp }
Exp4 : Ident { EIdent $1 }
| '{' Ident '}' { EConstr $2 }
| '%' Ident '%' { ECons $2 }
| Sort { ESort $1 }
| String { EString $1 }
| Integer { EInt $1 }
| '?' { EMeta }
| '[' ']' { EEmpty }
| 'data' { EData }
| '[' Ident Exps ']' { EList $2 $3 }
| '[' String ']' { EStrings $2 }
| '{' ListLocDef '}' { ERecord $2 }
| '<' ListTupleComp '>' { ETuple $2 }
| '(' 'in' Ident ')' { EIndir $3 }
| '<' Exp ':' Exp '>' { ETyped $2 $4 }
| '(' Exp ')' { $2 }
| LString { ELString $1 }
Exp3 :: { Exp }
Exp3 : Exp3 '.' Label { EProj $1 $3 }
| '{' Ident '.' Ident '}' { EQConstr $2 $4 }
| '%' Ident '.' Ident '%' { EQCons $2 $4 }
| Exp4 { $1 }
Exp2 :: { Exp }
Exp2 : Exp2 Exp3 { EApp $1 $2 }
| 'table' '{' ListCase '}' { ETable $3 }
| 'table' Exp4 '{' ListCase '}' { ETTable $2 $4 }
| 'table' Exp4 '[' ListExp ']' { EVTable $2 $4 }
| 'case' Exp 'of' '{' ListCase '}' { ECase $2 $5 }
| 'variants' '{' ListExp '}' { EVariants $3 }
| 'pre' '{' Exp ';' ListAltern '}' { EPre $3 $5 }
| 'strs' '{' ListExp '}' { EStrs $3 }
| Ident '@' Exp4 { EConAt $1 $3 }
| Exp3 { $1 }
| 'Lin' Ident { ELin $2 }
Exp1 :: { Exp }
Exp1 : Exp1 '!' Exp2 { ESelect $1 $3 }
| Exp1 '*' Exp2 { ETupTyp $1 $3 }
| Exp1 '**' Exp2 { EExtend $1 $3 }
| Exp2 { $1 }
Exp :: { Exp }
Exp : '\\' ListBind '->' Exp { EAbstr $2 $4 }
| '\\' '\\' ListBind '=>' Exp { ECTable $3 $5 }
| Decl '->' Exp { EProd $1 $3 }
| Exp1 '=>' Exp { ETType $1 $3 }
| Exp1 '++' Exp { EConcat $1 $3 }
| Exp1 '+' Exp { EGlue $1 $3 }
| 'let' '{' ListLocDef '}' 'in' Exp { ELet $3 $6 }
| 'let' ListLocDef 'in' Exp { ELetb $2 $4 }
| Exp1 'where' '{' ListLocDef '}' { EWhere $1 $4 }
| 'fn' '{' ListEquation '}' { EEqs $3 }
| Exp1 { $1 }
ListExp :: { [Exp] }
ListExp : {- empty -} { [] }
| Exp { (:[]) $1 }
| Exp ';' ListExp { (:) $1 $3 }
Exps :: { Exps }
Exps : {- empty -} { NilExp }
| Exp4 Exps { ConsExp $1 $2 }
Patt1 :: { Patt }
Patt1 : '_' { PW }
| Ident { PV $1 }
| '{' Ident '}' { PCon $2 }
| Ident '.' Ident { PQ $1 $3 }
| Integer { PInt $1 }
| String { PStr $1 }
| '{' ListPattAss '}' { PR $2 }
| '<' ListPattTupleComp '>' { PTup $2 }
| '(' Patt ')' { $2 }
Patt :: { Patt }
Patt : Ident ListPatt { PC $1 $2 }
| Ident '.' Ident ListPatt { PQC $1 $3 $4 }
| Patt1 { $1 }
PattAss :: { PattAss }
PattAss : ListIdent '=' Patt { PA $1 $3 }
Label :: { Label }
Label : Ident { LIdent $1 }
| '$' Integer { LVar $2 }
Sort :: { Sort }
Sort : 'Type' { Sort_Type }
| 'PType' { Sort_PType }
| 'Tok' { Sort_Tok }
| 'Str' { Sort_Str }
| 'Strs' { Sort_Strs }
ListPattAss :: { [PattAss] }
ListPattAss : {- empty -} { [] }
| PattAss { (:[]) $1 }
| PattAss ';' ListPattAss { (:) $1 $3 }
PattAlt :: { PattAlt }
PattAlt : Patt { AltP $1 }
ListPatt :: { [Patt] }
ListPatt : Patt1 { (:[]) $1 }
| Patt1 ListPatt { (:) $1 $2 }
ListPattAlt :: { [PattAlt] }
ListPattAlt : PattAlt { (:[]) $1 }
| PattAlt '|' ListPattAlt { (:) $1 $3 }
Bind :: { Bind }
Bind : Ident { BIdent $1 }
| '_' { BWild }
ListBind :: { [Bind] }
ListBind : {- empty -} { [] }
| Bind { (:[]) $1 }
| Bind ',' ListBind { (:) $1 $3 }
Decl :: { Decl }
Decl : '(' ListBind ':' Exp ')' { DDec $2 $4 }
| Exp2 { DExp $1 }
TupleComp :: { TupleComp }
TupleComp : Exp { TComp $1 }
PattTupleComp :: { PattTupleComp }
PattTupleComp : Patt { PTComp $1 }
ListTupleComp :: { [TupleComp] }
ListTupleComp : {- empty -} { [] }
| TupleComp { (:[]) $1 }
| TupleComp ',' ListTupleComp { (:) $1 $3 }
ListPattTupleComp :: { [PattTupleComp] }
ListPattTupleComp : {- empty -} { [] }
| PattTupleComp { (:[]) $1 }
| PattTupleComp ',' ListPattTupleComp { (:) $1 $3 }
Case :: { Case }
Case : ListPattAlt '=>' Exp { Case $1 $3 }
ListCase :: { [Case] }
ListCase : Case { (:[]) $1 }
| Case ';' ListCase { (:) $1 $3 }
Equation :: { Equation }
Equation : ListPatt '->' Exp { Equ $1 $3 }
ListEquation :: { [Equation] }
ListEquation : {- empty -} { [] }
| Equation { (:[]) $1 }
| Equation ';' ListEquation { (:) $1 $3 }
Altern :: { Altern }
Altern : Exp '/' Exp { Alt $1 $3 }
ListAltern :: { [Altern] }
ListAltern : {- empty -} { [] }
| Altern { (:[]) $1 }
| Altern ';' ListAltern { (:) $1 $3 }
DDecl :: { DDecl }
DDecl : '(' ListBind ':' Exp ')' { DDDec $2 $4 }
| Exp4 { DDExp $1 }
ListDDecl :: { [DDecl] }
ListDDecl : {- empty -} { [] }
| ListDDecl DDecl { flip (:) $1 $2 }
OldGrammar :: { OldGrammar }
OldGrammar : Include ListTopDef { OldGr $1 (reverse $2) }
Include :: { Include }
Include : {- empty -} { NoIncl }
| 'include' ListFileName { Incl $2 }
FileName :: { FileName }
FileName : String { FString $1 }
| Ident { FIdent $1 }
| '/' FileName { FSlash $2 }
| '.' FileName { FDot $2 }
| '-' FileName { FMinus $2 }
| Ident FileName { FAddId $1 $2 }
ListFileName :: { [FileName] }
ListFileName : FileName ';' { (:[]) $1 }
| FileName ';' ListFileName { (:) $1 $3 }
{
returnM :: a -> Err a
returnM = return
thenM :: Err a -> (a -> Err b) -> Err b
thenM = (>>=)
happyError :: [Token] -> Err a
happyError ts =
Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts)))
myLexer = tokens
}

34
src/GF/Source/PrintGF.hs
View File

@@ -198,10 +198,10 @@ instance Print Included where
instance Print Def where instance Print Def where
prt i e = case e of prt i e = case e of
DDecl ids exp -> prPrec i 0 (concatD [prt 0 ids , doc (showString ":") , prt 0 exp]) DDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp])
DDef ids exp -> prPrec i 0 (concatD [prt 0 ids , doc (showString "=") , prt 0 exp]) DDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp])
DPatt id patts exp -> prPrec i 0 (concatD [prt 0 id , prt 0 patts , doc (showString "=") , prt 0 exp]) DPatt name patts exp -> prPrec i 0 (concatD [prt 0 name , prt 0 patts , doc (showString "=") , prt 0 exp])
DFull ids exp0 exp -> prPrec i 0 (concatD [prt 0 ids , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp]) DFull names exp0 exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp])
prtList es = case es of prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ";")]) [x] -> (concatD [prt 0 x , doc (showString ";")])
@@ -236,7 +236,9 @@ instance Print TopDef where
instance Print CatDef where instance Print CatDef where
prt i e = case e of prt i e = case e of
CatDef id ddecls -> prPrec i 0 (concatD [prt 0 id , prt 0 ddecls]) SimpleCatDef id ddecls -> prPrec i 0 (concatD [prt 0 id , prt 0 ddecls])
ListCatDef id ddecls -> prPrec i 0 (concatD [doc (showString "[") , prt 0 id , prt 0 ddecls , doc (showString "]")])
ListSizeCatDef id ddecls n -> prPrec i 0 (concatD [doc (showString "[") , prt 0 id , prt 0 ddecls , doc (showString "]") , doc (showString "{") , prt 0 n , doc (showString "}")])
prtList es = case es of prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ";")]) [x] -> (concatD [prt 0 x , doc (showString ";")])
@@ -289,7 +291,7 @@ instance Print ParConstr where
instance Print PrintDef where instance Print PrintDef where
prt i e = case e of prt i e = case e of
PrintDef ids exp -> prPrec i 0 (concatD [prt 0 ids , doc (showString "=") , prt 0 exp]) PrintDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp])
prtList es = case es of prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ";")]) [x] -> (concatD [prt 0 x , doc (showString ";")])
@@ -303,6 +305,15 @@ instance Print FlagDef where
[x] -> (concatD [prt 0 x , doc (showString ";")]) [x] -> (concatD [prt 0 x , doc (showString ";")])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Name where
prt i e = case e of
IdentName id -> prPrec i 0 (concatD [prt 0 id])
ListName id -> prPrec i 0 (concatD [doc (showString "[") , prt 0 id , doc (showString "]")])
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print LocDef where instance Print LocDef where
prt i e = case e of prt i e = case e of
LDDecl ids exp -> prPrec i 0 (concatD [prt 0 ids , doc (showString ":") , prt 0 exp]) LDDecl ids exp -> prPrec i 0 (concatD [prt 0 ids , doc (showString ":") , prt 0 exp])
@@ -318,13 +329,14 @@ instance Print Exp where
prt i e = case e of prt i e = case e of
EIdent id -> prPrec i 4 (concatD [prt 0 id]) EIdent id -> prPrec i 4 (concatD [prt 0 id])
EConstr id -> prPrec i 4 (concatD [doc (showString "{0") , prt 0 id , doc (showString "}0")]) -- H EConstr id -> prPrec i 4 (concatD [doc (showString "{0") , prt 0 id , doc (showString "}0")]) -- H
ECons id -> prPrec i 4 (concatD [doc (showString "[") , prt 0 id , doc (showString "]")]) ECons id -> prPrec i 4 (concatD [doc (showString "%") , prt 0 id , doc (showString "%")])
ESort sort -> prPrec i 4 (concatD [prt 0 sort]) ESort sort -> prPrec i 4 (concatD [prt 0 sort])
EString str -> prPrec i 4 (concatD [prt 0 str]) EString str -> prPrec i 4 (concatD [prt 0 str])
EInt n -> prPrec i 4 (concatD [prt 0 n]) EInt n -> prPrec i 4 (concatD [prt 0 n])
EMeta -> prPrec i 4 (concatD [doc (showString "?")]) EMeta -> prPrec i 4 (concatD [doc (showString "?")])
EEmpty -> prPrec i 4 (concatD [doc (showString "[") , doc (showString "]")]) EEmpty -> prPrec i 4 (concatD [doc (showString "[") , doc (showString "]")])
EData -> prPrec i 4 (concatD [doc (showString "data")]) EData -> prPrec i 4 (concatD [doc (showString "data")])
EList id exps -> prPrec i 4 (concatD [doc (showString "[") , prt 0 id , prt 0 exps , doc (showString "]")])
EStrings str -> prPrec i 4 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")]) EStrings str -> prPrec i 4 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
ERecord locdefs -> prPrec i 4 (concatD [doc (showString "{") , prt 0 locdefs , doc (showString "}")]) ERecord locdefs -> prPrec i 4 (concatD [doc (showString "{") , prt 0 locdefs , doc (showString "}")])
ETuple tuplecomps -> prPrec i 4 (concatD [doc (showString "<") , prt 0 tuplecomps , doc (showString ">")]) ETuple tuplecomps -> prPrec i 4 (concatD [doc (showString "<") , prt 0 tuplecomps , doc (showString ">")])
@@ -332,7 +344,7 @@ instance Print Exp where
ETyped exp0 exp -> prPrec i 4 (concatD [doc (showString "<") , prt 0 exp0 , doc (showString ":") , prt 0 exp , doc (showString ">")]) ETyped exp0 exp -> prPrec i 4 (concatD [doc (showString "<") , prt 0 exp0 , doc (showString ":") , prt 0 exp , doc (showString ">")])
EProj exp label -> prPrec i 3 (concatD [prt 3 exp , doc (showString ".") , prt 0 label]) EProj exp label -> prPrec i 3 (concatD [prt 3 exp , doc (showString ".") , prt 0 label])
EQConstr id0 id -> prPrec i 3 (concatD [doc (showString "{0") , prt 0 id0 , doc (showString ".") , prt 0 id , doc (showString "}0")]) -- H EQConstr id0 id -> prPrec i 3 (concatD [doc (showString "{0") , prt 0 id0 , doc (showString ".") , prt 0 id , doc (showString "}0")]) -- H
EQCons id0 id -> prPrec i 3 (concatD [doc (showString "[") , prt 0 id0 , doc (showString ".") , prt 0 id , doc (showString "]")]) EQCons id0 id -> prPrec i 3 (concatD [doc (showString "%") , prt 0 id0 , doc (showString ".") , prt 0 id , doc (showString "%")])
EApp exp0 exp -> prPrec i 2 (concatD [prt 2 exp0 , prt 3 exp]) EApp exp0 exp -> prPrec i 2 (concatD [prt 2 exp0 , prt 3 exp])
ETable cases -> prPrec i 2 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")]) ETable cases -> prPrec i 2 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")])
ETTable exp cases -> prPrec i 2 (concatD [doc (showString "table") , prt 4 exp , doc (showString "{") , prt 0 cases , doc (showString "}")]) ETTable exp cases -> prPrec i 2 (concatD [doc (showString "table") , prt 4 exp , doc (showString "{") , prt 0 cases , doc (showString "}")])
@@ -363,6 +375,12 @@ instance Print Exp where
[x] -> (concatD [prt 0 x]) [x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Exps where
prt i e = case e of
NilExp -> prPrec i 0 (concatD [])
ConsExp exp exps -> prPrec i 0 (concatD [prt 4 exp , prt 0 exps])
instance Print Patt where instance Print Patt where
prt i e = case e of prt i e = case e of
PW -> prPrec i 1 (concatD [doc (showString "_")]) PW -> prPrec i 1 (concatD [doc (showString "_")])

37
src/GF/Source/SkelGF.hs
View File

@@ -1,10 +1,11 @@
module GF.Source.SkelGF where module GF.Source.SkelGF where
-- Haskell module generated by the BNF converter -- Haskell module generated by the BNF converter
import GF.Source.AbsGF import GF.Source.AbsGF
import GF.Infra.Ident
import GF.Data.ErrM import GF.Data.ErrM
type Result = Err String type Result = Err String
failure :: Show a => a -> Result failure :: Show a => a -> Result
@@ -12,7 +13,7 @@ failure x = Bad $ "Undefined case: " ++ show x
transIdent :: Ident -> Result transIdent :: Ident -> Result
transIdent x = case x of transIdent x = case x of
Ident str -> failure x IC str -> failure x
transLString :: LString -> Result transLString :: LString -> Result
@@ -61,6 +62,7 @@ transModBody :: ModBody -> Result
transModBody x = case x of transModBody x = case x of
MBody extend opens topdefs -> failure x MBody extend opens topdefs -> failure x
MWith id opens -> failure x MWith id opens -> failure x
MWithE ids id opens -> failure x
MReuse id -> failure x MReuse id -> failure x
MUnion includeds -> failure x MUnion includeds -> failure x
@@ -74,7 +76,7 @@ transExtend x = case x of
transOpens :: Opens -> Result transOpens :: Opens -> Result
transOpens x = case x of transOpens x = case x of
NoOpens -> failure x NoOpens -> failure x
Opens opens -> failure x OpenIn opens -> failure x
transOpen :: Open -> Result transOpen :: Open -> Result
@@ -105,10 +107,10 @@ transIncluded x = case x of
transDef :: Def -> Result transDef :: Def -> Result
transDef x = case x of transDef x = case x of
DDecl ids exp -> failure x DDecl names exp -> failure x
DDef ids exp -> failure x DDef names exp -> failure x
DPatt id patts exp -> failure x DPatt name patts exp -> failure x
DFull ids exp0 exp -> failure x DFull names exp0 exp -> failure x
transTopDef :: TopDef -> Result transTopDef :: TopDef -> Result
@@ -137,7 +139,9 @@ transTopDef x = case x of
transCatDef :: CatDef -> Result transCatDef :: CatDef -> Result
transCatDef x = case x of transCatDef x = case x of
CatDef id ddecls -> failure x SimpleCatDef id ddecls -> failure x
ListCatDef id ddecls -> failure x
ListSizeCatDef id ddecls n -> failure x
transFunDef :: FunDef -> Result transFunDef :: FunDef -> Result
@@ -158,7 +162,7 @@ transDataConstr x = case x of
transParDef :: ParDef -> Result transParDef :: ParDef -> Result
transParDef x = case x of transParDef x = case x of
ParDef id parconstrs -> failure x ParDefDir id parconstrs -> failure x
ParDefIndir id0 id -> failure x ParDefIndir id0 id -> failure x
ParDefAbs id -> failure x ParDefAbs id -> failure x
@@ -170,7 +174,7 @@ transParConstr x = case x of
transPrintDef :: PrintDef -> Result transPrintDef :: PrintDef -> Result
transPrintDef x = case x of transPrintDef x = case x of
PrintDef ids exp -> failure x PrintDef names exp -> failure x
transFlagDef :: FlagDef -> Result transFlagDef :: FlagDef -> Result
@@ -178,6 +182,12 @@ transFlagDef x = case x of
FlagDef id0 id -> failure x FlagDef id0 id -> failure x
transName :: Name -> Result
transName x = case x of
IdentName id -> failure x
ListName id -> failure x
transLocDef :: LocDef -> Result transLocDef :: LocDef -> Result
transLocDef x = case x of transLocDef x = case x of
LDDecl ids exp -> failure x LDDecl ids exp -> failure x
@@ -196,6 +206,7 @@ transExp x = case x of
EMeta -> failure x EMeta -> failure x
EEmpty -> failure x EEmpty -> failure x
EData -> failure x EData -> failure x
EList id exps -> failure x
EStrings str -> failure x EStrings str -> failure x
ERecord locdefs -> failure x ERecord locdefs -> failure x
ETuple tuplecomps -> failure x ETuple tuplecomps -> failure x
@@ -230,6 +241,12 @@ transExp x = case x of
ELin id -> failure x ELin id -> failure x
transExps :: Exps -> Result
transExps x = case x of
NilExp -> failure x
ConsExp exp exps -> failure x
transPatt :: Patt -> Result transPatt :: Patt -> Result
transPatt x = case x of transPatt x = case x of
PW -> failure x PW -> failure x

65
src/GF/Source/SourceToGrammar.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/04/21 16:23:29 $ -- > CVS $Date: 2005/05/25 10:42:00 $
-- > CVS $Author: bringert $ -- > CVS $Author: bringert $
-- > CVS $Revision: 1.22 $ -- > CVS $Revision: 1.23 $
-- --
-- based on the skeleton Haskell module generated by the BNF converter -- based on the skeleton Haskell module generated by the BNF converter
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@@ -36,6 +36,7 @@ import GF.Infra.Option
import Control.Monad import Control.Monad
import Data.Char import Data.Char
import Data.List (genericReplicate)
-- based on the skeleton Haskell module generated by the BNF converter -- based on the skeleton Haskell module generated by the BNF converter
@@ -48,6 +49,11 @@ transIdent :: Ident -> Err Ident
transIdent x = case x of transIdent x = case x of
x -> return x x -> return x
transName :: Name -> Err Ident
transName n = case n of
IdentName i -> transIdent i
ListName i -> transIdent (mkListId i)
transGrammar :: Grammar -> Err G.SourceGrammar transGrammar :: Grammar -> Err G.SourceGrammar
transGrammar x = case x of transGrammar x = case x of
Gr moddefs -> do Gr moddefs -> do
@@ -192,9 +198,7 @@ transIncluded x = case x of
transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option]) transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
transAbsDef x = case x of transAbsDef x = case x of
DefCat catdefs -> do DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
catdefs' <- mapM transCatDef catdefs
returnl [(cat, G.AbsCat (yes cont) nope) | (cat,cont) <- catdefs']
DefFun fundefs -> do DefFun fundefs -> do
fundefs' <- mapM transFunDef fundefs fundefs' <- mapM transFunDef fundefs
returnl [(fun, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs] returnl [(fun, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs]
@@ -229,10 +233,27 @@ transFlagDef :: FlagDef -> Err GO.Option
transFlagDef x = case x of transFlagDef x = case x of
FlagDef f x -> return $ GO.Opt (prIdent f,[prIdent x]) FlagDef f x -> return $ GO.Opt (prIdent f,[prIdent x])
transCatDef :: CatDef -> Err (Ident, G.Context) -- | Cat definitions can also return some fun defs
-- if it is a list category definition
transCatDef :: CatDef -> Err [(Ident, G.Info)]
transCatDef x = case x of transCatDef x = case x of
CatDef id ddecls -> liftM2 (,) (transIdent id) SimpleCatDef id ddecls -> liftM (:[]) $ cat id ddecls
(mapM transDDecl ddecls >>= return . concat) ListCatDef id ddecls -> listCat id ddecls 0
ListSizeCatDef id ddecls size -> listCat id ddecls size
where cat id ddecls = do
i <- transIdent id
cont <- liftM concat $ mapM transDDecl ddecls
return (i, G.AbsCat (yes cont) nope)
listCat id ddecls size = do
let li = mkListId id
catd <- cat li ddecls
let cd = M.mkDecl (G.Vr id)
lc = G.Vr li
niltyp = M.mkProdSimple (genericReplicate size cd) lc
nilfund = (mkBaseId id, G.AbsFun (yes niltyp) nope)
constyp = M.mkProdSimple [cd, M.mkDecl lc] lc
consfund = (mkConsId id, G.AbsFun (yes constyp) nope)
return [catd,nilfund,consfund]
transFunDef :: FunDef -> Err ([Ident], G.Type) transFunDef :: FunDef -> Err ([Ident], G.Type)
transFunDef x = case x of transFunDef x = case x of
@@ -302,27 +323,27 @@ transCncDef x = case x of
transPrintDef :: PrintDef -> Err [(Ident,G.Term)] transPrintDef :: PrintDef -> Err [(Ident,G.Term)]
transPrintDef x = case x of transPrintDef x = case x of
PrintDef id exp -> do PrintDef ids exp -> do
(ids,e) <- liftM2 (,) (mapM transIdent id) (transExp exp) (ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp)
return $ [(i,e) | i <- ids] return $ [(i,e) | i <- ids]
getDefsGen :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))] getDefsGen :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))]
getDefsGen d = case d of getDefsGen d = case d of
DDecl ids t -> do DDecl ids t -> do
ids' <- mapM transIdent ids ids' <- mapM transName ids
t' <- transExp t t' <- transExp t
return [(i,(yes t', nope)) | i <- ids'] return [(i,(yes t', nope)) | i <- ids']
DDef ids e -> do DDef ids e -> do
ids' <- mapM transIdent ids ids' <- mapM transName ids
e' <- transExp e e' <- transExp e
return [(i,(nope, yes e')) | i <- ids'] return [(i,(nope, yes e')) | i <- ids']
DFull ids t e -> do DFull ids t e -> do
ids' <- mapM transIdent ids ids' <- mapM transName ids
t' <- transExp t t' <- transExp t
e' <- transExp e e' <- transExp e
return [(i,(yes t', yes e')) | i <- ids'] return [(i,(yes t', yes e')) | i <- ids']
DPatt id patts e -> do DPatt id patts e -> do
id' <- transIdent id id' <- transName id
ps' <- mapM transPatt patts ps' <- mapM transPatt patts
e' <- transExp e e' <- transExp e
return [(id',(nope, yes (G.Eqs [(ps',e')])))] return [(id',(nope, yes (G.Eqs [(ps',e')])))]
@@ -331,7 +352,7 @@ getDefsGen d = case d of
getDefs :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))] getDefs :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))]
getDefs d = case d of getDefs d = case d of
DPatt id patts e -> do DPatt id patts e -> do
id' <- transIdent id id' <- transName id
xs <- mapM tryMakeVar patts xs <- mapM tryMakeVar patts
e' <- transExp e e' <- transExp e
return [(id',(nope, yes (M.mkAbs xs e')))] return [(id',(nope, yes (M.mkAbs xs e')))]
@@ -358,6 +379,8 @@ transExp x = case x of
EInt n -> return $ G.EInt $ fromInteger n EInt n -> return $ G.EInt $ fromInteger n
EMeta -> return $ M.meta $ M.int2meta 0 EMeta -> return $ M.meta $ M.int2meta 0
EEmpty -> return G.Empty EEmpty -> return G.Empty
-- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n)
EList i es -> transExp $ foldl EApp (EIdent (mkListId i)) (exps2list es)
EStrings [] -> return G.Empty EStrings [] -> return G.Empty
EStrings str -> return $ foldr1 G.C $ map G.K $ words str EStrings str -> return $ foldr1 G.C $ map G.K $ words str
ERecord defs -> erecord2term defs ERecord defs -> erecord2term defs
@@ -416,6 +439,10 @@ transExp x = case x of
_ -> Bad $ "translation not yet defined for" +++ printTree x ---- _ -> Bad $ "translation not yet defined for" +++ printTree x ----
exps2list :: Exps -> [Exp]
exps2list NilExp = []
exps2list (ConsExp e es) = e : exps2list es
--- this is complicated: should we change Exp or G.Term ? --- this is complicated: should we change Exp or G.Term ?
erecord2term :: [LocDef] -> Err G.Term erecord2term :: [LocDef] -> Err G.Term
@@ -615,3 +642,11 @@ termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where
abss xs t = case t of abss xs t = case t of
G.Abs x b -> abss (x:xs) b G.Abs x b -> abss (x:xs) b
_ -> (reverse xs,t) _ -> (reverse xs,t)
mkListId,mkConsId,mkBaseId :: Ident -> Ident
mkListId = prefixId "List"
mkConsId = prefixId "Cons"
mkBaseId = prefixId "Base"
prefixId :: String -> Ident -> Ident
prefixId pref id = IC (pref ++ prIdent id)

28
src/GF/Source/TestGF.hs
View File

@@ -1,6 +1,5 @@
-- automatically generated by BNF Converter -- automatically generated by BNF Converter
module GF.Source.TestGF where module Main where
import System.IO ( stdin, hGetContents ) import System.IO ( stdin, hGetContents )
@@ -13,6 +12,8 @@ import GF.Source.PrintGF
import GF.Source.AbsGF import GF.Source.AbsGF
import GF.Data.ErrM import GF.Data.ErrM
type ParseFun a = [Token] -> Err a type ParseFun a = [Token] -> Err a
@@ -29,18 +30,29 @@ runFile v p f = putStrLn f >> readFile f >>= run v p
run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO () run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
run v p s = let ts = myLLexer s in case p ts of run v p s = let ts = myLLexer s in case p ts of
Bad s -> do putStrLn "\nParse Failed...\n" Bad s -> do putStrLn "\nParse Failed...\n"
putStrV v "Tokens:" putStrV v "Tokens:"
putStrV v $ show ts putStrV v $ show ts
putStrLn s putStrLn s
Ok tree -> do putStrLn "\nParse Successful!" Ok tree -> do putStrLn "\nParse Successful!"
putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree showTree v tree
putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
showTree :: (Show a, Print a) => Int -> a -> IO ()
showTree v tree
= do
putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
main :: IO () main :: IO ()
main = do args <- getArgs main = do args <- getArgs
case args of case args of
[] -> hGetContents stdin >>= run 2 pGrammar [] -> hGetContents stdin >>= run 2 pGrammar
"-s":fs -> mapM_ (runFile 0 pGrammar) fs "-s":fs -> mapM_ (runFile 0 pGrammar) fs
fs -> mapM_ (runFile 2 pGrammar) fs fs -> mapM_ (runFile 2 pGrammar) fs