use new parser which supports the syntax in GF.Grammar.Grammar directly

1 files changed, 719 insertions, 0 deletions

diff --git a/src/GF/Grammar/Parser.y b/src/GF/Grammar/Parser.y
new file mode 100644
index 000000000..6be4e0ced
--- /dev/null
+++ b/src/GF/Grammar/Parser.y
@@ -0,0 +1,719 @@
+{
+{-# OPTIONS -fno-warn-overlapping-patterns #-}
+module GF.Grammar.Parser
+         ( P, runP
+         , pModDef
+         , pModHeader
+         , pExp
+         ) where
+
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Infra.Option
+import GF.Data.Operations
+import GF.Grammar.Predef
+import GF.Grammar.Grammar
+import GF.Grammar.Macros
+import GF.Grammar.Lexer
+import qualified Data.ByteString.Char8 as BS
+import GF.Compile.Update (buildAnyTree)
+}
+
+%name pModDef ModDef
+%partial pModHeader ModHeader
+%name pExp Exp
+
+-- no lexer declaration
+%monad { P } { >>= } { return }
+%lexer { lexer } { T_EOF }
+%tokentype { Token }
+
+
+%token 
+ '!'          { T_exclmark  }
+ '#'          { T_patt      }
+ '$'          { T_int_label }
+ '('          { T_oparen    }
+ ')'          { T_cparen    }
+ '*'          { T_star      }
+ '**'         { T_starstar  }
+ '+'          { T_plus      }
+ '++'         { T_plusplus  }
+ ','          { T_comma     }
+ '-'          { T_minus     }
+ '->'         { T_rarrow    }
+ '.'          { T_dot       }
+ '/'          { T_alt       }
+ ':'          { T_colon     }
+ ';'          { T_semicolon }
+ '<'          { T_less      }
+ '='          { T_equal     }
+ '=>'         { T_big_rarrow}
+ '>'          { T_great     }
+ '?'          { T_questmark }
+ '@'          { T_at        }
+ '['          { T_obrack    }
+ ']'          { T_cbrack    }
+ '{'          { T_ocurly    }
+ '}'          { T_ccurly    }
+ '\\'         { T_lam       }
+ '\\\\'       { T_lamlam    }
+ '_'          { T_underscore}
+ '|'          { T_bar       }
+ 'PType'      { T_PType     }
+ 'Str'        { T_Str       }
+ 'Strs'       { T_Strs      }
+ 'Tok'        { T_Tok       }
+ 'Type'       { T_Type      }
+ 'abstract'   { T_abstract  }
+ 'case'       { T_case      }
+ 'cat'        { T_cat       }
+ 'concrete'   { T_concrete  }
+ 'data'       { T_data      }
+ 'def'        { T_def       }
+ 'flags'      { T_flags     }
+ 'fn'         { T_fn        }
+ 'fun'        { T_fun       }
+ 'in'         { T_in        }
+ 'incomplete' { T_incomplete}
+ 'instance'   { T_instance  }
+ 'interface'  { T_interface }
+ 'let'        { T_let       }
+ 'lin'        { T_lin       }
+ 'lincat'     { T_lincat    }
+ 'lindef'     { T_lindef    }
+ 'of'         { T_of        }
+ 'open'       { T_open      }
+ 'oper'       { T_oper      }
+ 'param'      { T_param     }
+ 'pattern'    { T_pattern   }
+ 'pre'        { T_pre       }
+ 'printname'  { T_printname }
+ 'resource'   { T_resource  }
+ 'strs'       { T_strs      }
+ 'table'      { T_table     }
+ 'transfer'   { T_transfer  }
+ 'variants'   { T_variants  }
+ 'where'      { T_where     }
+ 'with'       { T_with      }
+
+Integer       { (T_Integer $$) }
+Double        { (T_Double  $$) }
+String        { (T_String  $$) }
+LString       { (T_LString $$) }
+Ident         { (T_Ident   $$) }
+
+
+%%
+
+ModDef :: { SourceModule }
+ModDef
+  : ComplMod ModType '=' ModBody {%
+                                   do let mstat = $1
+                                          (mtype,id) = $2
+                                          (extends,with,content) = $4
+                                          (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
+                                      mapM_ (checkInfoType mtype) jments
+                                      defs <- case buildAnyTree id [(i,d) | (i,_,d) <- jments] of
+                                                Ok x    -> return x
+                                                Bad msg -> fail msg
+                                      let poss  = buildTree [(i,(fname,mkSrcSpan p)) | (i,p,_) <- jments]
+                                          fname = prIdent id ++ ".gf"
+                                          
+                                          mkSrcSpan :: (Posn, Posn) -> (Int,Int)
+					  mkSrcSpan (Pn l1 _, Pn l2 _) = (l1,l2)
+
+                                      return (id, ModInfo mtype mstat opts extends with opens [] defs poss)  }
+
+ModHeader :: { SourceModule }
+ModHeader
+  : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
+                                               (mtype,id) = $2 ;
+                                               (extends,with,opens) = $4 }
+                                         in (id, ModInfo mtype mstat noOptions extends with opens [] emptyBinTree emptyBinTree) }
+
+ComplMod :: { ModuleStatus }
+ComplMod 
+  : {- empty -}  { MSComplete   } 
+  | 'incomplete' { MSIncomplete }
+
+ModType :: { (ModuleType Ident,Ident) }
+ModType
+  : 'abstract'  Ident                    { (MTAbstract,      $2) } 
+  | 'resource'  Ident                    { (MTResource,      $2) }
+  | 'interface' Ident                    { (MTInterface,     $2) }
+  | 'concrete'  Ident 'of' Ident         { (MTConcrete $4,   $2) }
+  | 'instance'  Ident 'of' Ident         { (MTInstance $4,   $2) }
+  | 'transfer'  Ident ':' Open '->' Open { (MTTransfer $4 $6,$2) }
+
+ModHeaderBody :: { ( [(Ident,MInclude Ident)]
+                   , Maybe (Ident,MInclude Ident,[(Ident,Ident)])
+                   , [OpenSpec Ident]
+                   ) }
+ModHeaderBody
+  : ListIncluded '**' Included 'with' ListInst '**' ModOpen { ($1, Just (fst $3,snd $3,$5), $7) }
+  | ListIncluded '**' Included 'with' ListInst              { ($1, Just (fst $3,snd $3,$5), []) }
+  | ListIncluded                               '**' ModOpen { ($1, Nothing,                 $3) }
+  | ListIncluded                                            { ($1, Nothing,                 []) }
+  |                   Included 'with' ListInst '**' ModOpen { ([], Just (fst $1,snd $1,$3), $5) }
+  |                   Included 'with' ListInst              { ([], Just (fst $1,snd $1,$3), []) }
+  |                                                 ModOpen { ([], Nothing,                 $1) }
+
+ModOpen :: { [OpenSpec Ident] }
+ModOpen
+  :                 { [] }
+  | 'open' ListOpen { $2 }
+
+ModBody :: { ( [(Ident,MInclude Ident)]
+             , Maybe (Ident,MInclude Ident,[(Ident,Ident)])
+             , Maybe ([OpenSpec Ident],[(Ident,SrcSpan,Info)],Options)
+             ) }
+ModBody
+  : ListIncluded '**' Included 'with' ListInst '**' ModContent  { ($1, Just (fst $3,snd $3,$5), Just $7) }
+  | ListIncluded '**' Included 'with' ListInst                  { ($1, Just (fst $3,snd $3,$5), Nothing) }
+  | ListIncluded                               '**' ModContent  { ($1, Nothing,                 Just $3) }
+  | ListIncluded                                                { ($1, Nothing,                 Nothing) }
+  |                   Included 'with' ListInst '**' ModContent  { ([], Just (fst $1,snd $1,$3), Just $5) }
+  |                   Included 'with' ListInst                  { ([], Just (fst $1,snd $1,$3), Nothing) }
+  |                                                 ModContent  { ([], Nothing,                 Just $1) }
+  | ModBody ';'                                                 { $1                                     }
+
+ModContent :: { ([OpenSpec Ident],[(Ident,SrcSpan,Info)],Options) }
+ModContent
+  :                      '{' ListTopDef '}' { ([],[d | Left ds <- $2, d <- ds],concatOptions [o | Right o <- $2]) }
+  | 'open' ListOpen 'in' '{' ListTopDef '}' { ($2,[d | Left ds <- $5, d <- ds],concatOptions [o | Right o <- $5]) }
+
+ListTopDef :: { [Either [(Ident,SrcSpan,Info)] Options] }
+ListTopDef
+  : {- empty -}       { []      } 
+  | TopDef ListTopDef { $1 : $2 }
+
+ListOpen :: { [OpenSpec Ident] }
+ListOpen
+  : Open              { [$1]    }
+  | Open ',' ListOpen { $1 : $3 }
+
+Open :: { OpenSpec Ident }
+Open
+  : Ident                   { OSimple $1    }
+  | '(' Ident '=' Ident ')' { OQualif $2 $4 }
+
+ListInst :: { [(Ident,Ident)] }
+ListInst
+  : Inst              { [$1]    }
+  | Inst ',' ListInst { $1 : $3 }
+
+Inst :: { (Ident,Ident) }
+Inst
+  : '(' Ident '=' Ident ')' { ($2,$4) }
+
+ListIncluded :: { [(Ident,MInclude Ident)] }
+ListIncluded
+  : Included                  { [$1]    }
+  | Included ',' ListIncluded { $1 : $3 }
+
+Included :: { (Ident,MInclude Ident) }
+Included 
+  : Ident                       { ($1,MIAll      ) } 
+  | Ident     '[' ListIdent ']' { ($1,MIOnly   $3) }
+  | Ident '-' '[' ListIdent ']' { ($1,MIExcept $4) }
+
+TopDef :: { Either [(Ident,SrcSpan,Info)] Options }
+TopDef
+  : 'cat'             ListCatDef      { Left  $2 }
+  | 'fun'             ListFunDef      { Left  $2 }
+  | 'def'             ListDefDef      { Left  $2 }
+  | 'data'            ListDataDef     { Left  $2 }
+  | 'param'           ListParamDef    { Left  $2 }
+  | 'oper'            ListOperDef     { Left  $2 }
+  | 'lincat'          ListTermDef     { Left  [(f, pos, CncCat (Just e) Nothing    Nothing   ) | (f,pos,e) <- $2] }
+  | 'lindef'          ListTermDef     { Left  [(f, pos, CncCat Nothing    (Just e) Nothing   ) | (f,pos,e) <- $2] }
+  | 'lin'             ListLinDef      { Left  $2 }
+  | 'printname' 'cat' ListTermDef     { Left  [(f, pos, CncCat Nothing    Nothing (Just e)) | (f,pos,e) <- $3] }
+  | 'printname' 'fun' ListTermDef     { Left  [(f, pos, CncFun Nothing Nothing (Just e)) | (f,pos,e) <- $3] }
+  | 'flags'           ListFlagDef     { Right $2 }
+
+CatDef :: { [(Ident,SrcSpan,Info)] }
+CatDef
+  : Posn Ident ListDDecl                         Posn { [($2, ($1,$4), AbsCat (Just $3) Nothing)]        }
+  | Posn '[' Ident ListDDecl ']'                 Posn { listCatDef $3 ($1,$6) $4 0                 }
+  | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef $3 ($1,$9) $4 (fromIntegral $7) }
+
+FunDef :: { [(Ident,SrcSpan,Info)] }
+FunDef
+  : Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) Nothing) | fun <- $2] } 
+
+DefDef :: { [(Ident,SrcSpan,Info)] }
+DefDef
+  : Posn ListName '=' Exp         Posn { [(f, ($1,$5),AbsFun Nothing (Just $4)) | f <- $2] }
+  | Posn Name ListPatt '=' Exp    Posn { [($2,($1,$6),AbsFun Nothing (Just (Eqs [($3,$5)])))] }
+
+DataDef :: { [(Ident,SrcSpan,Info)] }
+DataDef
+  : Posn Ident '=' ListDataConstr Posn { ($2,   ($1,$5), AbsCat Nothing     (Just (map Cn $4))) :
+                                         [(fun, ($1,$5), AbsFun Nothing     (Just EData)) | fun <- $4] }
+  | Posn ListIdent ':' Exp Posn        { [(cat, ($1,$5), AbsCat Nothing     (Just (map Cn $2))) | Ok (_,cat) <- [valCat $4]] ++
+                                         [(fun, ($1,$5), AbsFun (Just $4) (Just EData)) | fun <- $2] }                                         
+
+ParamDef :: { [(Ident,SrcSpan,Info)] }
+ParamDef
+  : Posn Ident '=' ListParConstr Posn {  ($2, ($1,$5), ResParam (Just ($4,Nothing))) :
+                                        [(f,  ($1,$5), ResValue (Just (mkProdSimple co (Cn $2),Nothing))) | (f,co) <- $4] }
+  | Posn Ident                   Posn { [($2, ($1,$3), ResParam Nothing)] }
+
+OperDef :: { [(Ident,SrcSpan,Info)] }
+OperDef
+  : Posn ListName ':' Exp         Posn { [(i, ($1,$5), info) | i <- $2,   info <- mkOverload (Just $4) Nothing  ] } 
+  | Posn ListName '=' Exp         Posn { [(i, ($1,$5), info) | i <- $2,   info <- mkOverload Nothing   (Just $4)] }
+  | Posn Name ListArg '=' Exp     Posn { [(i, ($1,$6), info) | i <- [$2], info <- mkOverload Nothing   (Just (mkAbs $3 $5))] }
+  | Posn ListName ':' Exp '=' Exp Posn { [(i, ($1,$7), info) | i <- $2,   info <- mkOverload (Just $4) (Just $6)] }
+
+LinDef :: { [(Ident,SrcSpan,Info)] }
+LinDef
+  : Posn ListName '=' Exp         Posn { [(f,  ($1,$5), CncFun Nothing (Just $4) Nothing) | f <- $2] }
+  | Posn Name ListArg '=' Exp     Posn { [($2, ($1,$6), CncFun Nothing (Just (mkAbs $3 $5)) Nothing)] }
+
+TermDef :: { [(Ident,SrcSpan,Term)] }
+TermDef
+  : Posn ListName '=' Exp Posn { [(i,($1,$5),$4) | i <- $2] } 
+
+FlagDef :: { Options }
+FlagDef
+  : Posn Ident '=' Ident Posn  {% case parseModuleOptions ["--" ++ prIdent $2 ++ "=" ++ prIdent $4] of
+                                    Ok  x   -> return x
+                                    Bad msg -> failLoc $1 msg                                           } 
+
+ListDataConstr :: { [Ident] }
+ListDataConstr
+  : Ident                    { [$1]    }
+  | Ident '|' ListDataConstr { $1 : $3 }
+
+ParConstr :: { Param }
+ParConstr
+  : Ident ListDDecl { ($1,$2) } 
+
+ListLinDef :: { [(Ident,SrcSpan,Info)] }
+ListLinDef
+  : LinDef ';'            { $1       } 
+  | LinDef ';' ListLinDef { $1 ++ $3 }
+
+ListDefDef :: { [(Ident,SrcSpan,Info)] }
+ListDefDef
+  : DefDef ';'            { $1       } 
+  | DefDef ';' ListDefDef { $1 ++ $3 }
+
+ListOperDef :: { [(Ident,SrcSpan,Info)] }
+ListOperDef
+  : OperDef ';'             { $1       } 
+  | OperDef ';' ListOperDef { $1 ++ $3 }
+
+ListCatDef :: { [(Ident,SrcSpan,Info)] }
+ListCatDef
+  : CatDef ';'            { $1       } 
+  | CatDef ';' ListCatDef { $1 ++ $3 }
+
+ListFunDef :: { [(Ident,SrcSpan,Info)] }
+ListFunDef
+  : FunDef ';'            { $1       }
+  | FunDef ';' ListFunDef { $1 ++ $3 }
+
+ListDataDef :: { [(Ident,SrcSpan,Info)] }
+ListDataDef
+  : DataDef ';'             { $1       } 
+  | DataDef ';' ListDataDef { $1 ++ $3 }
+
+ListParamDef :: { [(Ident,SrcSpan,Info)] }
+ListParamDef
+  : ParamDef ';'              { $1       } 
+  | ParamDef ';' ListParamDef { $1 ++ $3 }
+
+ListTermDef :: { [(Ident,SrcSpan,Term)] }
+ListTermDef
+  : TermDef ';'             { $1       } 
+  | TermDef ';' ListTermDef { $1 ++ $3 }
+
+ListFlagDef :: { Options }
+ListFlagDef
+  : FlagDef ';'               { $1               } 
+  | FlagDef ';' ListFlagDef   { addOptions $1 $3 }
+
+ListParConstr :: { [Param] }
+ListParConstr
+  : ParConstr                   { [$1]    }
+  | ParConstr '|' ListParConstr { $1 : $3 }
+
+ListIdent :: { [Ident] }
+ListIdent
+  : Ident               { [$1]    } 
+  | Ident ',' ListIdent { $1 : $3 }
+
+Name :: { Ident }
+Name
+  : Ident         { $1          } 
+  | '[' Ident ']' { mkListId $2 }
+
+ListName :: { [Ident] }
+ListName
+  : Name              { [$1]    }
+  | Name ',' ListName { $1 : $3 }
+
+LocDef :: { [(Ident, Maybe Type, Maybe Term)] }
+LocDef
+  : ListIdent ':' Exp         { [(lab,Just $3,Nothing) | lab <- $1] } 
+  | ListIdent '=' Exp         { [(lab,Nothing,Just $3) | lab <- $1] }
+  | ListIdent ':' Exp '=' Exp { [(lab,Just $3,Just $5) | lab <- $1] }
+
+ListLocDef :: { [(Ident, Maybe Type, Maybe Term)] }
+ListLocDef
+  : {- empty -}           { []       } 
+  | LocDef                { $1       }
+  | LocDef ';' ListLocDef { $1 ++ $3 }
+
+Exp :: { Term }
+Exp
+  : Exp1 '|' Exp                      { FV [$1,$3] } 
+  | '\\'   ListBind '->' Exp          { mkAbs $2 $4 }
+  | '\\\\' ListBind '=>' Exp          { mkCTable $2 $4 }
+  | Decl '->' Exp                     { mkProdSimple $1 $3 }
+  | Exp3 '=>' Exp                     { Table $1 $3 }
+  | 'let' '{' ListLocDef '}' 'in' Exp {%
+                                        do defs <- mapM tryLoc $3
+                                           return $ mkLet defs $6 }
+  | 'let' ListLocDef 'in' Exp         {%
+                                        do defs <- mapM tryLoc $2
+                                           return $ mkLet defs $4 }
+  | Exp3 'where' '{' ListLocDef '}'   {%
+                                        do defs <- mapM tryLoc $4
+                                           return $ mkLet defs $1 }
+  | 'fn' '{' ListEquation '}'         { Eqs $3 }
+  | 'in' Exp5 String                  { Example $2 $3 }
+  | Exp1                              { $1 }
+
+Exp1 :: { Term }
+Exp1
+  : Exp2 '++' Exp1 { C $1 $3 } 
+  | Exp2           { $1      }
+
+Exp2 :: { Term }
+Exp2
+  : Exp3 '+' Exp2 { Glue $1 $3 } 
+  | Exp3          { $1         }
+
+Exp3 :: { Term }
+Exp3
+  : Exp3 '!' Exp4                    { S $1 $3       } 
+  | 'table' '{' ListCase '}'         { T TRaw $3     }
+  | 'table' Exp6 '{' ListCase '}'    { T (TTyped $2) $4 }
+  | 'table' Exp6 '[' ListExp ']'     { V $2 $4       }
+  | Exp3 '*'  Exp4                   { case $1 of
+                                         RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),$3)])
+                                         t          -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$3)]  }
+  | Exp3 '**' Exp4                   { ExtR $1 $3    }
+  | Exp4                             { $1            }
+
+Exp4 :: { Term }
+Exp4
+  : Exp4 Exp5                        { App $1 $2     } 
+  | 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of
+                                             Typed _ t -> TTyped t
+                                             _         -> TRaw
+                                       in S (T annot $5) $2         }
+  | 'variants' '{' ListExp '}'       { FV $3         }
+  | 'pre' '{' Exp ';' ListAltern '}' { Alts ($3, $5) }
+  | 'strs' '{' ListExp '}'           { Strs $3       }
+  | '#' Patt2                        { EPatt $2      }
+  | 'pattern' Exp5                   { EPattType $2  }
+  | Exp5                             { $1            }
+
+Exp5 :: { Term }
+Exp5
+  : Exp5 '.' Label            { P  $1 $3 } 
+  | Exp6                      { $1       }
+
+Exp6 :: { Term }
+Exp6 
+  : Ident                 { Vr $1 } 
+  | Sort                  { Sort $1 }
+  | String                { K $1 }
+  | Integer               { EInt $1 }
+  | Double                { EFloat $1 }
+  | '?'                   { Meta (int2meta 0) }
+  | '[' ']'               { Empty }
+  | 'data'                { EData }
+  | '[' Ident Exps ']'    { foldl App (Vr (mkListId $2)) $3 }
+  | '[' String ']'        { case $2 of
+                              []   -> Empty
+                              str  -> foldr1 C (map K (words str)) }
+  | '{' ListLocDef '}'    {% mkR $2 }
+  | '<' ListTupleComp '>' { R (tuple2record $2) }
+  | '<' Exp ':' Exp '>'   { Typed $2 $4      }
+  | LString               { K $1 }
+  | '(' Exp ')'           { $2 }
+
+ListExp :: { [Term] }
+ListExp
+  : {- empty -}     { []      } 
+  | Exp             { [$1]    }
+  | Exp ';' ListExp { $1 : $3 }
+
+Exps :: { [Term] }
+Exps
+  : {- empty -}     { []      } 
+  | Exp6 Exps       { $1 : $2 }
+
+Patt :: { Patt }
+Patt
+  : Patt '|' Patt1            { PAlt $1 $3 } 
+  | Patt '+' Patt1            { PSeq $1 $3 }
+  | Patt1                     { $1         }
+
+Patt1 :: { Patt }
+Patt1
+  : Ident ListPatt            { PC $1 $2 } 
+  | Ident '.' Ident ListPatt  { PP $1 $3 $4 }
+  | Patt2 '*'                 { PRep $1 }
+  | Ident '@' Patt2           { PAs $1 $3 }
+  | '-' Patt2                 { PNeg $2 }
+  | Patt2                     { $1 }
+
+Patt2 :: { Patt }
+Patt2
+  : '?'                       { PChar } 
+  | '[' String ']'            { PChars $2 }
+  | '#' Ident                 { PMacro $2 }
+  | '#' Ident '.' Ident       { PM $2 $4 }
+  | '_'                       { wildPatt }
+  | Ident                     { PV $1 }
+  | '{' Ident '}'             { PC $2 [] }
+  | Ident '.' Ident           { PP $1 $3 [] }
+  | Integer                   { PInt $1 }
+  | Double                    { PFloat  $1 }
+  | String                    { PString $1 }
+  | '{' ListPattAss '}'       { PR $2 }
+  | '<' ListPattTupleComp '>' { (PR . tuple2recordPatt) $2 }
+  | '(' Patt ')'              { $2 }
+
+Arg :: { Ident }
+Arg 
+  : '_'                       { identW }
+  | Ident                     { $1     }
+
+PattAss :: { [(Label,Patt)] }
+PattAss
+  : ListIdent '=' Patt { [(LIdent (ident2bs i),$3) | i <- $1] } 
+
+Label :: { Label }
+Label
+  : Ident       { LIdent (ident2bs $1)   } 
+  | '$' Integer { LVar (fromIntegral $2) }
+
+Sort :: { Ident }
+Sort
+  : 'Type'  { cType  } 
+  | 'PType' { cPType }
+  | 'Tok'   { cTok   }
+  | 'Str'   { cStr   }
+  | 'Strs'  { cStrs  }
+
+ListPattAss :: { [(Label,Patt)] }
+ListPattAss
+  : {- empty -}             { []       }
+  | PattAss                 { $1       }
+  | PattAss ';' ListPattAss { $1 ++ $3 }
+
+ListPatt :: { [Patt] }
+ListPatt
+  : Patt2          { [$1]    } 
+  | Patt2 ListPatt { $1 : $2 }
+
+ListArg :: { [Ident] }
+ListArg
+  : Arg         { [$1]    } 
+  | Arg ListArg { $1 : $2 }
+
+Bind :: { Ident }
+Bind
+  : Ident  { $1     } 
+  | '_'    { identW }
+
+ListBind :: { [Ident] }
+ListBind
+  : Bind              { [$1]    }
+  | Bind ',' ListBind { $1 : $3 }
+
+Decl :: { [Decl] }
+Decl
+  : '(' ListBind ':' Exp ')' { [(x,$4) | x <- $2] } 
+  | Exp4                     { [mkDecl $1]        }
+
+ListTupleComp :: { [Term] }
+ListTupleComp
+  : {- empty -}           { []      } 
+  | Exp                   { [$1]    }
+  | Exp ',' ListTupleComp { $1 : $3 }
+
+ListPattTupleComp :: { [Patt] }
+ListPattTupleComp
+  : {- empty -}                { []      } 
+  | Patt                       { [$1]    }
+  | Patt ',' ListPattTupleComp { $1 : $3 }
+
+Case :: { Case }
+Case
+  : Patt '=>' Exp { ($1,$3) } 
+
+ListCase :: { [Case] }
+ListCase
+  : Case              { [$1]    } 
+  | Case ';' ListCase { $1 : $3 }
+
+Equation :: { Equation }
+Equation
+  : ListPatt '->' Exp         { ($1,$3) } 
+
+ListEquation :: { [Equation] }
+ListEquation
+  : Equation                  { (:[]) $1  }
+  | Equation ';' ListEquation { (:) $1 $3 }
+
+Altern :: { (Term,Term) }
+Altern
+  : Exp '/' Exp { ($1,$3) } 
+
+ListAltern :: { [(Term,Term)] }
+ListAltern
+  : Altern                { [$1]    }
+  | Altern ';' ListAltern { $1 : $3 }
+
+DDecl :: { [Decl] }
+DDecl
+  : '(' ListBind ':' Exp ')' { [(x,$4) | x <- $2] } 
+  | Exp6                     { [mkDecl $1]        }
+
+ListDDecl :: { [Decl] }
+ListDDecl
+  : {- empty -}     { []       } 
+  | DDecl ListDDecl { $1 ++ $2 }
+
+Posn :: { Posn }
+Posn
+  : {- empty -}     {% getPosn } 
+
+
+{
+
+happyError :: P a
+happyError = fail "parse error"
+
+mkListId,mkConsId,mkBaseId  :: Ident -> Ident
+mkListId = prefixId (BS.pack "List")
+mkConsId = prefixId (BS.pack "Cons")
+mkBaseId = prefixId (BS.pack "Base")
+
+prefixId :: BS.ByteString -> Ident -> Ident
+prefixId pref id = identC (BS.append pref (ident2bs id))
+
+listCatDef id pos cont size = [catd,nilfund,consfund]
+  where
+    listId = mkListId id
+    baseId = mkBaseId id
+    consId = mkConsId id
+
+    catd     = (listId, pos,   AbsCat (Just cont')   (Just [Cn baseId,Cn consId]))
+    nilfund  = (baseId, pos, AbsFun (Just niltyp)  (Just EData))
+    consfund = (consId, pos, AbsFun (Just constyp) (Just EData))
+
+    cont' = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont]
+    xs = map (Vr . fst) cont'
+    cd = mkDecl (mkApp (Vr id) xs)
+    lc = mkApp (Vr listId) xs
+
+    niltyp  = mkProdSimple (cont' ++ replicate size cd) lc
+    constyp = mkProdSimple (cont' ++ [cd, mkDecl lc]) lc
+
+    mkId x i = if isWildIdent x then (varX i) else x
+
+tryLoc (c,mty,Just e) = return (c,(mty,e))
+tryLoc (c,_  ,_     ) = fail ("local definition of" +++ prIdent c +++ "without value")
+
+mkR []       = return $ RecType [] --- empty record always interpreted as record type
+mkR fs@(f:_) =
+  case f of
+    (lab,Just ty,Nothing) -> mapM tryRT fs >>= return . RecType
+    _                     -> mapM tryR  fs >>= return . R
+  where
+    tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty)
+    tryRT (lab,_      ,_      ) = fail $ "illegal record type field" +++ prIdent lab --- manifest fields ?!
+
+    tryR (lab,mty,Just t) = return (ident2label lab,(mty,t))
+    tryR (lab,_  ,_     ) = fail $ "illegal record field" +++ prIdent lab
+
+mkOverload pdt pdf@(Just df) =
+  case appForm df of
+    (keyw, ts@(_:_)) | isOverloading keyw -> 
+       case last ts of
+         R fs -> [ResOverload [m | Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs]]
+         _    -> [ResOper pdt pdf]
+    _         -> [ResOper pdt pdf]
+
+     -- to enable separare type signature --- not type-checked
+mkOverload pdt@(Just df) pdf =
+  case appForm df of
+    (keyw, ts@(_:_)) | isOverloading keyw ->
+       case last ts of
+         RecType _ -> [] 
+         _         -> [ResOper pdt pdf]
+    _              -> [ResOper pdt pdf]
+mkOverload pdt pdf = [ResOper pdt pdf]
+
+isOverloading t =
+  case t of
+    Vr keyw | prIdent keyw == "overload" -> True      -- overload is a "soft keyword"
+    _                                    -> False
+
+
+type SrcSpan = (Posn,Posn)
+
+
+checkInfoType MTAbstract       (id,pos,info) =
+  case info of
+    AbsCat _ _   -> return ()
+    AbsFun _ _   -> return ()
+    _            -> failLoc (fst pos) "illegal definition in abstract module" 
+checkInfoType MTResource       (id,pos,info) =
+  case info of
+    ResParam _   -> return ()
+    ResValue _   -> return ()
+    ResOper  _ _ -> return ()
+    ResOverload _ _ -> return ()
+    _            -> failLoc (fst pos) "illegal definition in resource module" 
+checkInfoType MTInterface      (id,pos,info) =
+  case info of
+    ResParam _   -> return ()
+    ResValue _   -> return ()
+    ResOper  _ _ -> return ()
+    ResOverload _ _ -> return ()
+    _            -> failLoc (fst pos) "illegal definition in interface module" 
+checkInfoType (MTConcrete _)   (id,pos,info) =
+  case info of
+    CncCat _ _ _ -> return ()
+    CncFun _ _ _ -> return ()
+    ResParam _   -> return ()
+    ResValue _   -> return ()
+    ResOper  _ _ -> return ()
+    ResOverload _ _ -> return ()
+    _            -> failLoc (fst pos) "illegal definition in concrete module" 
+checkInfoType (MTInstance _)   (id,pos,info) =
+  case info of
+    ResParam _   -> return ()
+    ResValue _   -> return ()
+    ResOper  _ _ -> return ()
+    _            -> failLoc (fst pos) "illegal definition in instance module" 
+checkInfoType (MTTransfer _ _) (id,pos,info) =
+  case info of
+    AbsCat _ _   -> return ()
+    AbsFun _ _   -> return ()
+    _            -> failLoc (fst pos) "illegal definition in transfer module" 
+
+}
+