GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-22 03:09:33 -06:00
Code Issues Packages Projects Releases Wiki Activity

Move transfer into the GF repo.

Browse Source
This commit is contained in:
bringert
2005-11-25 16:36:19 +00:00
parent 66c1c31960
commit 2a59fffd45
42 changed files with 7400 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

275
src/Transfer/Core/Abs.hs Normal file
View File

@@ -0,0 +1,275 @@
{-# OPTIONS_GHC -fglasgow-exts #-}
module Transfer.Core.Abs where
import Control.Monad (ap,MonadPlus,msum,mplus,mzero)
import Data.Monoid
-- Haskell module generated by the BNF converter
data Module_
type Module = Tree Module_
data Decl_
type Decl = Tree Decl_
data ConsDecl_
type ConsDecl = Tree ConsDecl_
data Pattern_
type Pattern = Tree Pattern_
data FieldPattern_
type FieldPattern = Tree FieldPattern_
data PatternVariable_
type PatternVariable = Tree PatternVariable_
data Exp_
type Exp = Tree Exp_
data LetDef_
type LetDef = Tree LetDef_
data Case_
type Case = Tree Case_
data FieldType_
type FieldType = Tree FieldType_
data FieldValue_
type FieldValue = Tree FieldValue_
data CIdent_
type CIdent = Tree CIdent_
data Tree :: * -> * where
Module :: [Decl] -> Tree Module_
DataDecl :: CIdent -> Exp -> [ConsDecl] -> Tree Decl_
TypeDecl :: CIdent -> Exp -> Tree Decl_
ValueDecl :: CIdent -> Exp -> Tree Decl_
ConsDecl :: CIdent -> Exp -> Tree ConsDecl_
PCons :: CIdent -> [Pattern] -> Tree Pattern_
PVar :: PatternVariable -> Tree Pattern_
PRec :: [FieldPattern] -> Tree Pattern_
PType :: Tree Pattern_
PStr :: String -> Tree Pattern_
PInt :: Integer -> Tree Pattern_
FieldPattern :: CIdent -> Pattern -> Tree FieldPattern_
PVVar :: CIdent -> Tree PatternVariable_
PVWild :: Tree PatternVariable_
ELet :: [LetDef] -> Exp -> Tree Exp_
ECase :: Exp -> [Case] -> Tree Exp_
EAbs :: PatternVariable -> Exp -> Tree Exp_
EPi :: PatternVariable -> Exp -> Exp -> Tree Exp_
EApp :: Exp -> Exp -> Tree Exp_
EProj :: Exp -> CIdent -> Tree Exp_
EEmptyRec :: Tree Exp_
ERecType :: [FieldType] -> Tree Exp_
ERec :: [FieldValue] -> Tree Exp_
EVar :: CIdent -> Tree Exp_
EType :: Tree Exp_
EStr :: String -> Tree Exp_
EInt :: Integer -> Tree Exp_
LetDef :: CIdent -> Exp -> Exp -> Tree LetDef_
Case :: Pattern -> Exp -> Tree Case_
FieldType :: CIdent -> Exp -> Tree FieldType_
FieldValue :: CIdent -> Exp -> Tree FieldValue_
CIdent :: String -> Tree CIdent_
composOp :: (forall a. Tree a -> Tree a) -> Tree c -> Tree c
composOp f = head . composOpM (\x -> [f x])
composOpM_ :: Monad m => (forall a. Tree a -> m ()) -> Tree c -> m ()
composOpM_ = composOpFold (return ()) (>>)
composOpMPlus :: MonadPlus m => (forall a. Tree a -> m b) -> Tree c -> m b
composOpMPlus = composOpFold mzero mplus
composOpMonoid :: Monoid m => (forall a. Tree a -> m) -> Tree c -> m
composOpMonoid = composOpFold mempty mappend
composOpM :: Monad m => (forall a. Tree a -> m (Tree a)) -> Tree c -> m (Tree c)
composOpM f t = case t of
Module decls -> return Module `ap` mapM f decls
DataDecl cident exp consdecls -> return DataDecl `ap` f cident `ap` f exp `ap` mapM f consdecls
TypeDecl cident exp -> return TypeDecl `ap` f cident `ap` f exp
ValueDecl cident exp -> return ValueDecl `ap` f cident `ap` f exp
ConsDecl cident exp -> return ConsDecl `ap` f cident `ap` f exp
PCons cident patterns -> return PCons `ap` f cident `ap` mapM f patterns
PVar patternvariable -> return PVar `ap` f patternvariable
PRec fieldpatterns -> return PRec `ap` mapM f fieldpatterns
FieldPattern cident pattern -> return FieldPattern `ap` f cident `ap` f pattern
PVVar cident -> return PVVar `ap` f cident
ELet letdefs exp -> return ELet `ap` mapM f letdefs `ap` f exp
ECase exp cases -> return ECase `ap` f exp `ap` mapM f cases
EAbs patternvariable exp -> return EAbs `ap` f patternvariable `ap` f exp
EPi patternvariable exp0 exp1 -> return EPi `ap` f patternvariable `ap` f exp0 `ap` f exp1
EApp exp0 exp1 -> return EApp `ap` f exp0 `ap` f exp1
EProj exp cident -> return EProj `ap` f exp `ap` f cident
ERecType fieldtypes -> return ERecType `ap` mapM f fieldtypes
ERec fieldvalues -> return ERec `ap` mapM f fieldvalues
EVar cident -> return EVar `ap` f cident
LetDef cident exp0 exp1 -> return LetDef `ap` f cident `ap` f exp0 `ap` f exp1
Case pattern exp -> return Case `ap` f pattern `ap` f exp
FieldType cident exp -> return FieldType `ap` f cident `ap` f exp
FieldValue cident exp -> return FieldValue `ap` f cident `ap` f exp
_ -> return t
composOpFold :: b -> (b -> b -> b) -> (forall a. Tree a -> b) -> Tree c -> b
composOpFold zero combine f t = case t of
Module decls -> foldr combine zero (map f decls)
DataDecl cident exp consdecls -> f cident `combine` f exp `combine` foldr combine zero (map f consdecls)
TypeDecl cident exp -> f cident `combine` f exp
ValueDecl cident exp -> f cident `combine` f exp
ConsDecl cident exp -> f cident `combine` f exp
PCons cident patterns -> f cident `combine` foldr combine zero (map f patterns)
PVar patternvariable -> f patternvariable
PRec fieldpatterns -> foldr combine zero (map f fieldpatterns)
FieldPattern cident pattern -> f cident `combine` f pattern
PVVar cident -> f cident
ELet letdefs exp -> foldr combine zero (map f letdefs) `combine` f exp
ECase exp cases -> f exp `combine` foldr combine zero (map f cases)
EAbs patternvariable exp -> f patternvariable `combine` f exp
EPi patternvariable exp0 exp1 -> f patternvariable `combine` f exp0 `combine` f exp1
EApp exp0 exp1 -> f exp0 `combine` f exp1
EProj exp cident -> f exp `combine` f cident
ERecType fieldtypes -> foldr combine zero (map f fieldtypes)
ERec fieldvalues -> foldr combine zero (map f fieldvalues)
EVar cident -> f cident
LetDef cident exp0 exp1 -> f cident `combine` f exp0 `combine` f exp1
Case pattern exp -> f pattern `combine` f exp
FieldType cident exp -> f cident `combine` f exp
FieldValue cident exp -> f cident `combine` f exp
_ -> zero
instance Show (Tree c) where
showsPrec n t = case t of
Module decls -> opar n . showString "Module" . showChar ' ' . showsPrec 1 decls . cpar n
DataDecl cident exp consdecls -> opar n . showString "DataDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 consdecls . cpar n
TypeDecl cident exp -> opar n . showString "TypeDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
ValueDecl cident exp -> opar n . showString "ValueDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
ConsDecl cident exp -> opar n . showString "ConsDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
PCons cident patterns -> opar n . showString "PCons" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 patterns . cpar n
PVar patternvariable -> opar n . showString "PVar" . showChar ' ' . showsPrec 1 patternvariable . cpar n
PRec fieldpatterns -> opar n . showString "PRec" . showChar ' ' . showsPrec 1 fieldpatterns . cpar n
PType -> showString "PType"
PStr str -> opar n . showString "PStr" . showChar ' ' . showsPrec 1 str . cpar n
PInt n -> opar n . showString "PInt" . showChar ' ' . showsPrec 1 n . cpar n
FieldPattern cident pattern -> opar n . showString "FieldPattern" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 pattern . cpar n
PVVar cident -> opar n . showString "PVVar" . showChar ' ' . showsPrec 1 cident . cpar n
PVWild -> showString "PVWild"
ELet letdefs exp -> opar n . showString "ELet" . showChar ' ' . showsPrec 1 letdefs . showChar ' ' . showsPrec 1 exp . cpar n
ECase exp cases -> opar n . showString "ECase" . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 cases . cpar n
EAbs patternvariable exp -> opar n . showString "EAbs" . showChar ' ' . showsPrec 1 patternvariable . showChar ' ' . showsPrec 1 exp . cpar n
EPi patternvariable exp0 exp1 -> opar n . showString "EPi" . showChar ' ' . showsPrec 1 patternvariable . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
EApp exp0 exp1 -> opar n . showString "EApp" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
EProj exp cident -> opar n . showString "EProj" . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 cident . cpar n
EEmptyRec -> showString "EEmptyRec"
ERecType fieldtypes -> opar n . showString "ERecType" . showChar ' ' . showsPrec 1 fieldtypes . cpar n
ERec fieldvalues -> opar n . showString "ERec" . showChar ' ' . showsPrec 1 fieldvalues . cpar n
EVar cident -> opar n . showString "EVar" . showChar ' ' . showsPrec 1 cident . cpar n
EType -> showString "EType"
EStr str -> opar n . showString "EStr" . showChar ' ' . showsPrec 1 str . cpar n
EInt n -> opar n . showString "EInt" . showChar ' ' . showsPrec 1 n . cpar n
LetDef cident exp0 exp1 -> opar n . showString "LetDef" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
Case pattern exp -> opar n . showString "Case" . showChar ' ' . showsPrec 1 pattern . showChar ' ' . showsPrec 1 exp . cpar n
FieldType cident exp -> opar n . showString "FieldType" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
FieldValue cident exp -> opar n . showString "FieldValue" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
CIdent str -> opar n . showString "CIdent" . showChar ' ' . showsPrec 1 str . cpar n
where opar n = if n > 0 then showChar '(' else id
cpar n = if n > 0 then showChar ')' else id
instance Eq (Tree c) where (==) = johnMajorEq
johnMajorEq :: Tree a -> Tree b -> Bool
johnMajorEq (Module decls) (Module decls_) = decls == decls_
johnMajorEq (DataDecl cident exp consdecls) (DataDecl cident_ exp_ consdecls_) = cident == cident_ && exp == exp_ && consdecls == consdecls_
johnMajorEq (TypeDecl cident exp) (TypeDecl cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (ValueDecl cident exp) (ValueDecl cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (ConsDecl cident exp) (ConsDecl cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (PCons cident patterns) (PCons cident_ patterns_) = cident == cident_ && patterns == patterns_
johnMajorEq (PVar patternvariable) (PVar patternvariable_) = patternvariable == patternvariable_
johnMajorEq (PRec fieldpatterns) (PRec fieldpatterns_) = fieldpatterns == fieldpatterns_
johnMajorEq PType PType = True
johnMajorEq (PStr str) (PStr str_) = str == str_
johnMajorEq (PInt n) (PInt n_) = n == n_
johnMajorEq (FieldPattern cident pattern) (FieldPattern cident_ pattern_) = cident == cident_ && pattern == pattern_
johnMajorEq (PVVar cident) (PVVar cident_) = cident == cident_
johnMajorEq PVWild PVWild = True
johnMajorEq (ELet letdefs exp) (ELet letdefs_ exp_) = letdefs == letdefs_ && exp == exp_
johnMajorEq (ECase exp cases) (ECase exp_ cases_) = exp == exp_ && cases == cases_
johnMajorEq (EAbs patternvariable exp) (EAbs patternvariable_ exp_) = patternvariable == patternvariable_ && exp == exp_
johnMajorEq (EPi patternvariable exp0 exp1) (EPi patternvariable_ exp0_ exp1_) = patternvariable == patternvariable_ && exp0 == exp0_ && exp1 == exp1_
johnMajorEq (EApp exp0 exp1) (EApp exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
johnMajorEq (EProj exp cident) (EProj exp_ cident_) = exp == exp_ && cident == cident_
johnMajorEq EEmptyRec EEmptyRec = True
johnMajorEq (ERecType fieldtypes) (ERecType fieldtypes_) = fieldtypes == fieldtypes_
johnMajorEq (ERec fieldvalues) (ERec fieldvalues_) = fieldvalues == fieldvalues_
johnMajorEq (EVar cident) (EVar cident_) = cident == cident_
johnMajorEq EType EType = True
johnMajorEq (EStr str) (EStr str_) = str == str_
johnMajorEq (EInt n) (EInt n_) = n == n_
johnMajorEq (LetDef cident exp0 exp1) (LetDef cident_ exp0_ exp1_) = cident == cident_ && exp0 == exp0_ && exp1 == exp1_
johnMajorEq (Case pattern exp) (Case pattern_ exp_) = pattern == pattern_ && exp == exp_
johnMajorEq (FieldType cident exp) (FieldType cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (FieldValue cident exp) (FieldValue cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (CIdent str) (CIdent str_) = str == str_
johnMajorEq _ _ = False
instance Ord (Tree c) where
compare x y = compare (index x) (index y) `mappend` compareSame x y
where
index (Module _) = 0
index (DataDecl _ _ _) = 1
index (TypeDecl _ _) = 2
index (ValueDecl _ _) = 3
index (ConsDecl _ _) = 4
index (PCons _ _) = 5
index (PVar _) = 6
index (PRec _) = 7
index (PType ) = 8
index (PStr _) = 9
index (PInt _) = 10
index (FieldPattern _ _) = 11
index (PVVar _) = 12
index (PVWild ) = 13
index (ELet _ _) = 14
index (ECase _ _) = 15
index (EAbs _ _) = 16
index (EPi _ _ _) = 17
index (EApp _ _) = 18
index (EProj _ _) = 19
index (EEmptyRec ) = 20
index (ERecType _) = 21
index (ERec _) = 22
index (EVar _) = 23
index (EType ) = 24
index (EStr _) = 25
index (EInt _) = 26
index (LetDef _ _ _) = 27
index (Case _ _) = 28
index (FieldType _ _) = 29
index (FieldValue _ _) = 30
index (CIdent _) = 31
compareSame (Module decls) (Module decls_) = compare decls decls_
compareSame (DataDecl cident exp consdecls) (DataDecl cident_ exp_ consdecls_) = mappend (compare cident cident_) (mappend (compare exp exp_) (compare consdecls consdecls_))
compareSame (TypeDecl cident exp) (TypeDecl cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
compareSame (ValueDecl cident exp) (ValueDecl cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
compareSame (ConsDecl cident exp) (ConsDecl cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
compareSame (PCons cident patterns) (PCons cident_ patterns_) = mappend (compare cident cident_) (compare patterns patterns_)
compareSame (PVar patternvariable) (PVar patternvariable_) = compare patternvariable patternvariable_
compareSame (PRec fieldpatterns) (PRec fieldpatterns_) = compare fieldpatterns fieldpatterns_
compareSame PType PType = EQ
compareSame (PStr str) (PStr str_) = compare str str_
compareSame (PInt n) (PInt n_) = compare n n_
compareSame (FieldPattern cident pattern) (FieldPattern cident_ pattern_) = mappend (compare cident cident_) (compare pattern pattern_)
compareSame (PVVar cident) (PVVar cident_) = compare cident cident_
compareSame PVWild PVWild = EQ
compareSame (ELet letdefs exp) (ELet letdefs_ exp_) = mappend (compare letdefs letdefs_) (compare exp exp_)
compareSame (ECase exp cases) (ECase exp_ cases_) = mappend (compare exp exp_) (compare cases cases_)
compareSame (EAbs patternvariable exp) (EAbs patternvariable_ exp_) = mappend (compare patternvariable patternvariable_) (compare exp exp_)
compareSame (EPi patternvariable exp0 exp1) (EPi patternvariable_ exp0_ exp1_) = mappend (compare patternvariable patternvariable_) (mappend (compare exp0 exp0_) (compare exp1 exp1_))
compareSame (EApp exp0 exp1) (EApp exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
compareSame (EProj exp cident) (EProj exp_ cident_) = mappend (compare exp exp_) (compare cident cident_)
compareSame EEmptyRec EEmptyRec = EQ
compareSame (ERecType fieldtypes) (ERecType fieldtypes_) = compare fieldtypes fieldtypes_
compareSame (ERec fieldvalues) (ERec fieldvalues_) = compare fieldvalues fieldvalues_
compareSame (EVar cident) (EVar cident_) = compare cident cident_
compareSame EType EType = EQ
compareSame (EStr str) (EStr str_) = compare str str_
compareSame (EInt n) (EInt n_) = compare n n_
compareSame (LetDef cident exp0 exp1) (LetDef cident_ exp0_ exp1_) = mappend (compare cident cident_) (mappend (compare exp0 exp0_) (compare exp1 exp1_))
compareSame (Case pattern exp) (Case pattern_ exp_) = mappend (compare pattern pattern_) (compare exp exp_)
compareSame (FieldType cident exp) (FieldType cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
compareSame (FieldValue cident exp) (FieldValue cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
compareSame (CIdent str) (CIdent str_) = compare str str_
compareSame x y = error "BNFC error:" compareSame

98
src/Transfer/Core/Core.cf Normal file
View File

@@ -0,0 +1,98 @@
-- This is a subset of the front-end language
entrypoints Module, Exp ;
comment "--" ;
comment "{-" "-}" ;
Module. Module ::= [Decl] ;
separator Decl ";" ;
DataDecl. Decl ::= "data" CIdent ":" Exp "where" "{" [ConsDecl] "}" ;
TypeDecl. Decl ::= CIdent ":" Exp ;
ValueDecl. Decl ::= CIdent "=" Exp ;
ConsDecl. ConsDecl ::= CIdent ":" Exp ;
separator ConsDecl ";" ;
separator Pattern "";
-- Constructor patterns.
PCons. Pattern ::= "(" CIdent [Pattern] ")" ;
-- Variable patterns. Note that in the core language,
-- constructor patterns must have parantheses.
PVar. Pattern ::= PatternVariable ;
-- Record patterns.
PRec. Pattern ::= "{" [FieldPattern] "}";
-- Patterns matching the constant Type.
PType. Pattern ::= "Type" ;
-- String literal patterns.
PStr. Pattern ::= String ;
-- Integer literal patterns.
PInt. Pattern ::= Integer ;
FieldPattern. FieldPattern ::= CIdent "=" Pattern ;
separator FieldPattern ";" ;
-- Variable patterns
PVVar. PatternVariable ::= CIdent ;
-- Wild card patterns
PVWild. PatternVariable ::= "_" ;
-- Let expressions.
ELet. Exp ::= "let" "{" [LetDef] "}" "in" Exp ;
LetDef. LetDef ::= CIdent ":" Exp "=" Exp ;
separator LetDef ";" ;
-- Case expressions.
ECase. Exp ::= "case" Exp "of" "{" [Case] "}" ;
-- Lambda abstractions.
EAbs. Exp2 ::= "\\" PatternVariable "->" Exp ;
-- Function types.
EPi. Exp2 ::= "(" PatternVariable ":" Exp ")" "->" Exp ;
-- Function application.
EApp. Exp3 ::= Exp3 Exp4 ;
-- Record field projection.
EProj. Exp4 ::= Exp4 "." CIdent ;
EEmptyRec. Exp5 ::= "{" "}" ;
-- Record types.
ERecType. Exp5 ::= "{" [FieldType] "}" ;
-- Record expressions.
ERec. Exp5 ::= "{" [FieldValue] "}" ;
-- Functions, constructors and local variables.
EVar. Exp5 ::= CIdent ;
-- The constant Type.
EType. Exp5 ::= "Type" ;
-- String literal expressions.
EStr. Exp5 ::= String ;
-- Integer literal expressions.
EInt. Exp5 ::= Integer ;
coercions Exp 5 ;
{-
-- Hack to make lists of function arguments not conflict with
-- application.
[]. [Exp] ::= ;
(:). [Exp] ::= Exp4 [Exp] ;
-}
Case. Case ::= Pattern "->" Exp ;
separator Case ";" ;
FieldType. FieldType ::= CIdent ":" Exp ;
separator nonempty FieldType ";" ;
FieldValue. FieldValue ::= CIdent "=" Exp ;
separator nonempty FieldValue ";" ;
-- Identifiers in core can start with underscore to allow
-- generating unique identifiers easily.
token CIdent ((letter | '_') (letter | digit | '_' | '\'')*) ;

203
src/Transfer/Core/Doc.tex Normal file
View File

@@ -0,0 +1,203 @@
\batchmode
%This Latex file is machine-generated by the BNF-converter
\documentclass[a4paper,11pt]{article}
\author{BNF-converter}
\title{The Language Core}
\setlength{\parindent}{0mm}
\setlength{\parskip}{1mm}
\begin{document}
\maketitle
\newcommand{\emptyP}{\mbox{$\epsilon$}}
\newcommand{\terminal}[1]{\mbox{{\texttt {#1}}}}
\newcommand{\nonterminal}[1]{\mbox{$\langle \mbox{{\sl #1 }} \! \rangle$}}
\newcommand{\arrow}{\mbox{::=}}
\newcommand{\delimit}{\mbox{$|$}}
\newcommand{\reserved}[1]{\mbox{{\texttt {#1}}}}
\newcommand{\literal}[1]{\mbox{{\texttt {#1}}}}
\newcommand{\symb}[1]{\mbox{{\texttt {#1}}}}
This document was automatically generated by the {\em BNF-Converter}. It was generated together with the lexer, the parser, and the abstract syntax module, which guarantees that the document matches with the implementation of the language (provided no hand-hacking has taken place).
\section*{The lexical structure of Core}
\subsection*{Literals}
String literals \nonterminal{String}\ have the form
\terminal{"}$x$\terminal{"}, where $x$ is any sequence of any characters
except \terminal{"}\ unless preceded by \verb6\6.
Integer literals \nonterminal{Int}\ are nonempty sequences of digits.
CIdent literals are recognized by the regular expression
\(({\nonterminal{letter}} \mid \mbox{`\_'}) ({\nonterminal{letter}} \mid {\nonterminal{digit}} \mid \mbox{`\_'} \mid \mbox{`''})*\)
\subsection*{Reserved words and symbols}
The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions.
The reserved words used in Core are the following: \\
\begin{tabular}{lll}
{\reserved{Type}} &{\reserved{case}} &{\reserved{data}} \\
{\reserved{in}} &{\reserved{let}} &{\reserved{of}} \\
{\reserved{where}} & & \\
\end{tabular}\\
The symbols used in Core are the following: \\
\begin{tabular}{lll}
{\symb{;}} &{\symb{:}} &{\symb{\{}} \\
{\symb{\}}} &{\symb{{$=$}}} &{\symb{(}} \\
{\symb{)}} &{\symb{\_}} &{\symb{$\backslash$}} \\
{\symb{{$-$}{$>$}}} &{\symb{.}} & \\
\end{tabular}\\
\subsection*{Comments}
Single-line comments begin with {\symb{{$-$}{$-$}}}. \\Multiple-line comments are enclosed with {\symb{\{{$-$}}} and {\symb{{$-$}\}}}.
\section*{The syntactic structure of Core}
Non-terminals are enclosed between $\langle$ and $\rangle$.
The symbols {\arrow} (production), {\delimit} (union)
and {\emptyP} (empty rule) belong to the BNF notation.
All other symbols are terminals.\\
\begin{tabular}{lll}
{\nonterminal{Module}} & {\arrow} &{\nonterminal{ListDecl}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{ListDecl}} & {\arrow} &{\emptyP} \\
& {\delimit} &{\nonterminal{Decl}} \\
& {\delimit} &{\nonterminal{Decl}} {\terminal{;}} {\nonterminal{ListDecl}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{Decl}} & {\arrow} &{\terminal{data}} {\nonterminal{CIdent}} {\terminal{:}} {\nonterminal{Exp}} {\terminal{where}} {\terminal{\{}} {\nonterminal{ListConsDecl}} {\terminal{\}}} \\
& {\delimit} &{\nonterminal{CIdent}} {\terminal{:}} {\nonterminal{Exp}} \\
& {\delimit} &{\nonterminal{CIdent}} {\terminal{{$=$}}} {\nonterminal{Exp}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{ConsDecl}} & {\arrow} &{\nonterminal{CIdent}} {\terminal{:}} {\nonterminal{Exp}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{ListConsDecl}} & {\arrow} &{\emptyP} \\
& {\delimit} &{\nonterminal{ConsDecl}} \\
& {\delimit} &{\nonterminal{ConsDecl}} {\terminal{;}} {\nonterminal{ListConsDecl}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{ListPattern}} & {\arrow} &{\emptyP} \\
& {\delimit} &{\nonterminal{Pattern}} {\nonterminal{ListPattern}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{Pattern}} & {\arrow} &{\terminal{(}} {\nonterminal{CIdent}} {\nonterminal{ListPattern}} {\terminal{)}} \\
& {\delimit} &{\nonterminal{PatternVariable}} \\
& {\delimit} &{\terminal{\{}} {\nonterminal{ListFieldPattern}} {\terminal{\}}} \\
& {\delimit} &{\terminal{Type}} \\
& {\delimit} &{\nonterminal{String}} \\
& {\delimit} &{\nonterminal{Integer}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{FieldPattern}} & {\arrow} &{\nonterminal{CIdent}} {\terminal{{$=$}}} {\nonterminal{Pattern}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{ListFieldPattern}} & {\arrow} &{\emptyP} \\
& {\delimit} &{\nonterminal{FieldPattern}} \\
& {\delimit} &{\nonterminal{FieldPattern}} {\terminal{;}} {\nonterminal{ListFieldPattern}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{PatternVariable}} & {\arrow} &{\nonterminal{CIdent}} \\
& {\delimit} &{\terminal{\_}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{Exp}} & {\arrow} &{\terminal{let}} {\terminal{\{}} {\nonterminal{ListLetDef}} {\terminal{\}}} {\terminal{in}} {\nonterminal{Exp}} \\
& {\delimit} &{\terminal{case}} {\nonterminal{Exp}} {\terminal{of}} {\terminal{\{}} {\nonterminal{ListCase}} {\terminal{\}}} \\
& {\delimit} &{\nonterminal{Exp1}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{LetDef}} & {\arrow} &{\nonterminal{CIdent}} {\terminal{:}} {\nonterminal{Exp}} {\terminal{{$=$}}} {\nonterminal{Exp}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{ListLetDef}} & {\arrow} &{\emptyP} \\
& {\delimit} &{\nonterminal{LetDef}} \\
& {\delimit} &{\nonterminal{LetDef}} {\terminal{;}} {\nonterminal{ListLetDef}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{Exp2}} & {\arrow} &{\terminal{$\backslash$}} {\nonterminal{PatternVariable}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}} \\
& {\delimit} &{\terminal{(}} {\nonterminal{PatternVariable}} {\terminal{:}} {\nonterminal{Exp}} {\terminal{)}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}} \\
& {\delimit} &{\nonterminal{Exp3}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{Exp3}} & {\arrow} &{\nonterminal{Exp3}} {\nonterminal{Exp4}} \\
& {\delimit} &{\nonterminal{Exp4}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{Exp4}} & {\arrow} &{\nonterminal{Exp4}} {\terminal{.}} {\nonterminal{CIdent}} \\
& {\delimit} &{\nonterminal{Exp5}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{Exp5}} & {\arrow} &{\terminal{\{}} {\terminal{\}}} \\
& {\delimit} &{\terminal{\{}} {\nonterminal{ListFieldType}} {\terminal{\}}} \\
& {\delimit} &{\terminal{\{}} {\nonterminal{ListFieldValue}} {\terminal{\}}} \\
& {\delimit} &{\nonterminal{CIdent}} \\
& {\delimit} &{\terminal{Type}} \\
& {\delimit} &{\nonterminal{String}} \\
& {\delimit} &{\nonterminal{Integer}} \\
& {\delimit} &{\terminal{(}} {\nonterminal{Exp}} {\terminal{)}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{Exp1}} & {\arrow} &{\nonterminal{Exp2}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{Case}} & {\arrow} &{\nonterminal{Pattern}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{ListCase}} & {\arrow} &{\emptyP} \\
& {\delimit} &{\nonterminal{Case}} \\
& {\delimit} &{\nonterminal{Case}} {\terminal{;}} {\nonterminal{ListCase}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{FieldType}} & {\arrow} &{\nonterminal{CIdent}} {\terminal{:}} {\nonterminal{Exp}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{ListFieldType}} & {\arrow} &{\nonterminal{FieldType}} \\
& {\delimit} &{\nonterminal{FieldType}} {\terminal{;}} {\nonterminal{ListFieldType}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{FieldValue}} & {\arrow} &{\nonterminal{CIdent}} {\terminal{{$=$}}} {\nonterminal{Exp}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{ListFieldValue}} & {\arrow} &{\nonterminal{FieldValue}} \\
& {\delimit} &{\nonterminal{FieldValue}} {\terminal{;}} {\nonterminal{ListFieldValue}} \\
\end{tabular}\\
\end{document}

348
src/Transfer/Core/Lex.hs Normal file
View File

File diff suppressed because one or more lines are too long

137
src/Transfer/Core/Lex.x Normal file
View File

@@ -0,0 +1,137 @@
-- -*- haskell -*-
-- This Alex file was machine-generated by the BNF converter
{
module Transfer.Core.Lex where
import Transfer.ErrM
}
$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
$d = [0-9] -- digit
$i = [$l $d _ '] -- identifier character
$u = [\0-\255] -- universal: any character
@rsyms = -- reserved words consisting of special symbols
\; | \: | \{ | \} | \= | \( | \) | \_ | \\ | \- \> | \.
:-
"--" [.]* ; -- Toss single line comments
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
$white+ ;
@rsyms { tok (\p s -> PT p (TS $ share s)) }
($l | \_)($l | $d | \_ | \')* { tok (\p s -> PT p (eitherResIdent (T_CIdent . share) s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
$d+ { tok (\p s -> PT p (TI $ share s)) }
{
tok f p s = f p s
share :: String -> String
share = id
data Tok =
TS !String -- reserved words
| TL !String -- string literals
| TI !String -- integer literals
| TV !String -- identifiers
| TD !String -- double precision float literals
| TC !String -- character literals
| T_CIdent !String
deriving (Eq,Show,Ord)
data Token =
PT Posn Tok
| Err Posn
deriving (Eq,Show,Ord)
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
tokenPos _ = "end of file"
posLineCol (Pn _ l c) = (l,c)
mkPosToken t@(PT p _) = (posLineCol p, prToken t)
prToken t = case t of
PT _ (TS s) -> s
PT _ (TI s) -> s
PT _ (TV s) -> s
PT _ (TD s) -> s
PT _ (TC s) -> s
PT _ (T_CIdent s) -> s
_ -> show t
data BTree = N | B String Tok BTree BTree deriving (Show)
eitherResIdent :: (String -> Tok) -> String -> Tok
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
resWords = b "in" (b "case" (b "Type" N N) (b "data" N N)) (b "of" (b "let" N N) (b "where" N N))
where b s = B s (TS s)
unescapeInitTail :: String -> String
unescapeInitTail = unesc . tail where
unesc s = case s of
'\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
'\\':'n':cs -> '\n' : unesc cs
'\\':'t':cs -> '\t' : unesc cs
'"':[] -> []
c:cs -> c : unesc cs
_ -> []
-------------------------------------------------------------------
-- Alex wrapper code.
-- A modified "posn" wrapper.
-------------------------------------------------------------------
data Posn = Pn !Int !Int !Int
deriving (Eq, Show,Ord)
alexStartPos :: Posn
alexStartPos = Pn 0 1 1
alexMove :: Posn -> Char -> Posn
alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
type AlexInput = (Posn, -- current position,
Char, -- previous char
String) -- current input string
tokens :: String -> [Token]
tokens str = go (alexStartPos, '\n', str)
where
go :: (Posn, Char, String) -> [Token]
go inp@(pos, _, str) =
case alexScan inp 0 of
AlexEOF -> []
AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error"
AlexSkip inp' len -> go inp'
AlexToken inp' len act -> act pos (take len str) : (go inp')
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (p, c, []) = Nothing
alexGetChar (p, _, (c:s)) =
let p' = alexMove p c
in p' `seq` Just (c, (p', c, s))
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (p, c, s) = c
}

1113
src/Transfer/Core/Par.hs Normal file
View File

File diff suppressed because it is too large Load Diff

193
src/Transfer/Core/Par.y Normal file
View File

@@ -0,0 +1,193 @@
-- This Happy file was machine-generated by the BNF converter
{
module Transfer.Core.Par where
import Transfer.Core.Abs
import Transfer.Core.Lex
import Transfer.ErrM
}
%name pModule Module
%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 ".") }
'Type' { PT _ (TS "Type") }
'case' { PT _ (TS "case") }
'data' { PT _ (TS "data") }
'in' { PT _ (TS "in") }
'let' { PT _ (TS "let") }
'of' { PT _ (TS "of") }
'where' { PT _ (TS "where") }
L_quoted { PT _ (TL $$) }
L_integ { PT _ (TI $$) }
L_CIdent { PT _ (T_CIdent $$) }
L_err { _ }
%%
String :: { String } : L_quoted { $1 }
Integer :: { Integer } : L_integ { (read $1) :: Integer }
CIdent :: { CIdent} : L_CIdent { CIdent ($1)}
Module :: { Module }
Module : ListDecl { Module $1 }
ListDecl :: { [Decl] }
ListDecl : {- empty -} { [] }
| Decl { (:[]) $1 }
| Decl ';' ListDecl { (:) $1 $3 }
Decl :: { Decl }
Decl : 'data' CIdent ':' Exp 'where' '{' ListConsDecl '}' { DataDecl $2 $4 $7 }
| CIdent ':' Exp { TypeDecl $1 $3 }
| CIdent '=' Exp { ValueDecl $1 $3 }
ConsDecl :: { ConsDecl }
ConsDecl : CIdent ':' Exp { ConsDecl $1 $3 }
ListConsDecl :: { [ConsDecl] }
ListConsDecl : {- empty -} { [] }
| ConsDecl { (:[]) $1 }
| ConsDecl ';' ListConsDecl { (:) $1 $3 }
ListPattern :: { [Pattern] }
ListPattern : {- empty -} { [] }
| ListPattern Pattern { flip (:) $1 $2 }
Pattern :: { Pattern }
Pattern : '(' CIdent ListPattern ')' { PCons $2 (reverse $3) }
| PatternVariable { PVar $1 }
| '{' ListFieldPattern '}' { PRec $2 }
| 'Type' { PType }
| String { PStr $1 }
| Integer { PInt $1 }
FieldPattern :: { FieldPattern }
FieldPattern : CIdent '=' Pattern { FieldPattern $1 $3 }
ListFieldPattern :: { [FieldPattern] }
ListFieldPattern : {- empty -} { [] }
| FieldPattern { (:[]) $1 }
| FieldPattern ';' ListFieldPattern { (:) $1 $3 }
PatternVariable :: { PatternVariable }
PatternVariable : CIdent { PVVar $1 }
| '_' { PVWild }
Exp :: { Exp }
Exp : 'let' '{' ListLetDef '}' 'in' Exp { ELet $3 $6 }
| 'case' Exp 'of' '{' ListCase '}' { ECase $2 $5 }
| Exp1 { $1 }
LetDef :: { LetDef }
LetDef : CIdent ':' Exp '=' Exp { LetDef $1 $3 $5 }
ListLetDef :: { [LetDef] }
ListLetDef : {- empty -} { [] }
| LetDef { (:[]) $1 }
| LetDef ';' ListLetDef { (:) $1 $3 }
Exp2 :: { Exp }
Exp2 : '\\' PatternVariable '->' Exp { EAbs $2 $4 }
| '(' PatternVariable ':' Exp ')' '->' Exp { EPi $2 $4 $7 }
| Exp3 { $1 }
Exp3 :: { Exp }
Exp3 : Exp3 Exp4 { EApp $1 $2 }
| Exp4 { $1 }
Exp4 :: { Exp }
Exp4 : Exp4 '.' CIdent { EProj $1 $3 }
| Exp5 { $1 }
Exp5 :: { Exp }
Exp5 : '{' '}' { EEmptyRec }
| '{' ListFieldType '}' { ERecType $2 }
| '{' ListFieldValue '}' { ERec $2 }
| CIdent { EVar $1 }
| 'Type' { EType }
| String { EStr $1 }
| Integer { EInt $1 }
| '(' Exp ')' { $2 }
Exp1 :: { Exp }
Exp1 : Exp2 { $1 }
Case :: { Case }
Case : Pattern '->' Exp { Case $1 $3 }
ListCase :: { [Case] }
ListCase : {- empty -} { [] }
| Case { (:[]) $1 }
| Case ';' ListCase { (:) $1 $3 }
FieldType :: { FieldType }
FieldType : CIdent ':' Exp { FieldType $1 $3 }
ListFieldType :: { [FieldType] }
ListFieldType : FieldType { (:[]) $1 }
| FieldType ';' ListFieldType { (:) $1 $3 }
FieldValue :: { FieldValue }
FieldValue : CIdent '=' Exp { FieldValue $1 $3 }
ListFieldValue :: { [FieldValue] }
ListFieldValue : FieldValue { (:[]) $1 }
| FieldValue ';' ListFieldValue { (:) $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
}

152
src/Transfer/Core/Print.hs Normal file
View File

@@ -0,0 +1,152 @@
{-# OPTIONS_GHC -fglasgow-exts #-}
module Transfer.Core.Print where
-- pretty-printer generated by the BNF converter
import Transfer.Core.Abs
import Data.Char
import Data.List (intersperse)
-- the top-level printing method
printTree :: Print a => a -> String
printTree = render . prt 0
type Doc = [ShowS] -> [ShowS]
doc :: ShowS -> Doc
doc = (:)
render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
rend i ss = case ss of
"[" :ts -> showChar '[' . rend i ts
"(" :ts -> showChar '(' . rend i ts
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
";" :ts -> showChar ';' . new i . rend i ts
t : "," :ts -> showString t . space "," . rend i ts
t : ")" :ts -> showString t . showChar ')' . rend i ts
t : "]" :ts -> showString t . showChar ']' . rend i ts
t :ts -> space t . rend i ts
_ -> id
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
space t = showString t . (\s -> if null s then "" else (' ':s))
parenth :: Doc -> Doc
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id
concatD :: [Doc] -> Doc
concatD = foldr (.) id
unwordsD :: [Doc] -> Doc
unwordsD = concatD . intersperse (doc (showChar ' '))
replicateS :: Int -> ShowS -> ShowS
replicateS n f = concatS (replicate n f)
-- the printer class does the job
class Print a where
prt :: Int -> a -> Doc
instance Print Char where
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
instance Print String where
prt _ s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
mkEsc :: Char -> Char -> ShowS
mkEsc q s = case s of
_ | s == q -> showChar '\\' . showChar s
'\\'-> showString "\\\\"
'\n' -> showString "\\n"
'\t' -> showString "\\t"
_ -> showChar s
prPrec :: Int -> Int -> Doc -> Doc
prPrec i j = if j<i then parenth else id
instance Print Integer where
prt _ x = doc (shows x)
instance Print Double where
prt _ x = doc (shows x)
instance Print (Tree c) where
prt _i e = case e of
Module decls -> prPrec _i 0 (concatD [prt 0 decls])
DataDecl cident exp consdecls -> prPrec _i 0 (concatD [doc (showString "data") , prt 0 cident , doc (showString ":") , prt 0 exp , doc (showString "where") , doc (showString "{") , prt 0 consdecls , doc (showString "}")])
TypeDecl cident exp -> prPrec _i 0 (concatD [prt 0 cident , doc (showString ":") , prt 0 exp])
ValueDecl cident exp -> prPrec _i 0 (concatD [prt 0 cident , doc (showString "=") , prt 0 exp])
ConsDecl cident exp -> prPrec _i 0 (concatD [prt 0 cident , doc (showString ":") , prt 0 exp])
PCons cident patterns -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 cident , prt 0 patterns , doc (showString ")")])
PVar patternvariable -> prPrec _i 0 (concatD [prt 0 patternvariable])
PRec fieldpatterns -> prPrec _i 0 (concatD [doc (showString "{") , prt 0 fieldpatterns , doc (showString "}")])
PType -> prPrec _i 0 (concatD [doc (showString "Type")])
PStr str -> prPrec _i 0 (concatD [prt 0 str])
PInt n -> prPrec _i 0 (concatD [prt 0 n])
FieldPattern cident pattern -> prPrec _i 0 (concatD [prt 0 cident , doc (showString "=") , prt 0 pattern])
PVVar cident -> prPrec _i 0 (concatD [prt 0 cident])
PVWild -> prPrec _i 0 (concatD [doc (showString "_")])
ELet letdefs exp -> prPrec _i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 letdefs , doc (showString "}") , doc (showString "in") , prt 0 exp])
ECase exp cases -> prPrec _i 0 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
EAbs patternvariable exp -> prPrec _i 2 (concatD [doc (showString "\\") , prt 0 patternvariable , doc (showString "->") , prt 0 exp])
EPi patternvariable exp0 exp1 -> prPrec _i 2 (concatD [doc (showString "(") , prt 0 patternvariable , doc (showString ":") , prt 0 exp0 , doc (showString ")") , doc (showString "->") , prt 0 exp1])
EApp exp0 exp1 -> prPrec _i 3 (concatD [prt 3 exp0 , prt 4 exp1])
EProj exp cident -> prPrec _i 4 (concatD [prt 4 exp , doc (showString ".") , prt 0 cident])
EEmptyRec -> prPrec _i 5 (concatD [doc (showString "{") , doc (showString "}")])
ERecType fieldtypes -> prPrec _i 5 (concatD [doc (showString "{") , prt 0 fieldtypes , doc (showString "}")])
ERec fieldvalues -> prPrec _i 5 (concatD [doc (showString "{") , prt 0 fieldvalues , doc (showString "}")])
EVar cident -> prPrec _i 5 (concatD [prt 0 cident])
EType -> prPrec _i 5 (concatD [doc (showString "Type")])
EStr str -> prPrec _i 5 (concatD [prt 0 str])
EInt n -> prPrec _i 5 (concatD [prt 0 n])
LetDef cident exp0 exp1 -> prPrec _i 0 (concatD [prt 0 cident , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp1])
Case pattern exp -> prPrec _i 0 (concatD [prt 0 pattern , doc (showString "->") , prt 0 exp])
FieldType cident exp -> prPrec _i 0 (concatD [prt 0 cident , doc (showString ":") , prt 0 exp])
FieldValue cident exp -> prPrec _i 0 (concatD [prt 0 cident , doc (showString "=") , prt 0 exp])
CIdent str -> prPrec _i 0 (doc (showString str))
instance Print [Decl] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [ConsDecl] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [Pattern] where
prt _ es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print [FieldPattern] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [LetDef] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [Case] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [FieldType] where
prt _ es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [FieldValue] where
prt _ es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])

114
src/Transfer/Core/Skel.hs Normal file
View File

@@ -0,0 +1,114 @@
module Transfer.Core.Skel where
-- Haskell module generated by the BNF converter
import Transfer.Core.Abs
import Transfer.ErrM
type Result = Err String
failure :: Show a => a -> Result
failure x = Bad $ "Undefined case: " ++ show x
transTree :: Tree c -> Result
transTree t = case t of
Module decls -> failure t
DataDecl cident exp consdecls -> failure t
TypeDecl cident exp -> failure t
ValueDecl cident exp -> failure t
ConsDecl cident exp -> failure t
PCons cident patterns -> failure t
PVar patternvariable -> failure t
PRec fieldpatterns -> failure t
PType -> failure t
PStr str -> failure t
PInt n -> failure t
FieldPattern cident pattern -> failure t
PVVar cident -> failure t
PVWild -> failure t
ELet letdefs exp -> failure t
ECase exp cases -> failure t
EAbs patternvariable exp -> failure t
EPi patternvariable exp0 exp1 -> failure t
EApp exp0 exp1 -> failure t
EProj exp cident -> failure t
EEmptyRec -> failure t
ERecType fieldtypes -> failure t
ERec fieldvalues -> failure t
EVar cident -> failure t
EType -> failure t
EStr str -> failure t
EInt n -> failure t
LetDef cident exp0 exp1 -> failure t
Case pattern exp -> failure t
FieldType cident exp -> failure t
FieldValue cident exp -> failure t
CIdent str -> failure t
transModule :: Module -> Result
transModule t = case t of
Module decls -> failure t
transDecl :: Decl -> Result
transDecl t = case t of
DataDecl cident exp consdecls -> failure t
TypeDecl cident exp -> failure t
ValueDecl cident exp -> failure t
transConsDecl :: ConsDecl -> Result
transConsDecl t = case t of
ConsDecl cident exp -> failure t
transPattern :: Pattern -> Result
transPattern t = case t of
PCons cident patterns -> failure t
PVar patternvariable -> failure t
PRec fieldpatterns -> failure t
PType -> failure t
PStr str -> failure t
PInt n -> failure t
transFieldPattern :: FieldPattern -> Result
transFieldPattern t = case t of
FieldPattern cident pattern -> failure t
transPatternVariable :: PatternVariable -> Result
transPatternVariable t = case t of
PVVar cident -> failure t
PVWild -> failure t
transExp :: Exp -> Result
transExp t = case t of
ELet letdefs exp -> failure t
ECase exp cases -> failure t
EAbs patternvariable exp -> failure t
EPi patternvariable exp0 exp1 -> failure t
EApp exp0 exp1 -> failure t
EProj exp cident -> failure t
EEmptyRec -> failure t
ERecType fieldtypes -> failure t
ERec fieldvalues -> failure t
EVar cident -> failure t
EType -> failure t
EStr str -> failure t
EInt n -> failure t
transLetDef :: LetDef -> Result
transLetDef t = case t of
LetDef cident exp0 exp1 -> failure t
transCase :: Case -> Result
transCase t = case t of
Case pattern exp -> failure t
transFieldType :: FieldType -> Result
transFieldType t = case t of
FieldType cident exp -> failure t
transFieldValue :: FieldValue -> Result
transFieldValue t = case t of
FieldValue cident exp -> failure t
transCIdent :: CIdent -> Result
transCIdent t = case t of
CIdent str -> failure t

58
src/Transfer/Core/Test.hs Normal file
View File

@@ -0,0 +1,58 @@
-- automatically generated by BNF Converter
module Main where
import IO ( stdin, hGetContents )
import System ( getArgs, getProgName )
import Transfer.Core.Lex
import Transfer.Core.Par
import Transfer.Core.Skel
import Transfer.Core.Print
import Transfer.Core.Abs
import Transfer.ErrM
type ParseFun a = [Token] -> Err a
myLLexer = myLexer
type Verbosity = Int
putStrV :: Verbosity -> String -> IO ()
putStrV v s = if v > 1 then putStrLn s else return ()
runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
runFile v p f = putStrLn f >> readFile f >>= run v p
run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
run v p s = let ts = myLLexer s in case p ts of
Bad s -> do putStrLn "\nParse Failed...\n"
putStrV v "Tokens:"
putStrV v $ show ts
putStrLn s
Ok tree -> do putStrLn "\nParse Successful!"
showTree v 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 = do args <- getArgs
case args of
[] -> hGetContents stdin >>= run 2 pModule
"-s":fs -> mapM_ (runFile 0 pModule) fs
fs -> mapM_ (runFile 2 pModule) fs