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

GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

Browse Source
This commit is contained in:
aarne
2008-05-21 09:26:44 +00:00
parent b24ca795ca
commit 2bab9286f1
536 changed files with 0 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

267
src-3.0/Transfer/Core/Abs.hs Normal file
View File

@@ -0,0 +1,267 @@
{-# OPTIONS_GHC -fglasgow-exts #-}
module Transfer.Core.Abs (Tree(..), Module, Decl, ConsDecl, Pattern, FieldPattern, PatternVariable, Exp, LetDef, Case, FieldType, FieldValue, TMeta, CIdent, composOp, composOpM, composOpM_, composOpMPlus, composOpMonoid, composOpFold, compos, johnMajorEq) where
import Control.Monad (ap,MonadPlus,msum,mplus,mzero)
import Control.Monad.Identity
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 TMeta_
type TMeta = Tree TMeta_
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_
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_
ERecType :: [FieldType] -> Tree Exp_
ERec :: [FieldValue] -> Tree Exp_
EVar :: CIdent -> Tree Exp_
EType :: Tree Exp_
EStr :: String -> Tree Exp_
EInteger :: Integer -> Tree Exp_
EDouble :: Double -> Tree Exp_
EMeta :: TMeta -> Tree Exp_
LetDef :: CIdent -> Exp -> Tree LetDef_
Case :: Pattern -> Exp -> Exp -> Tree Case_
FieldType :: CIdent -> Exp -> Tree FieldType_
FieldValue :: CIdent -> Exp -> Tree FieldValue_
TMeta :: String -> Tree TMeta_
CIdent :: String -> Tree CIdent_
composOp :: (forall a. Tree a -> Tree a) -> Tree c -> Tree c
composOp f = runIdentity . composOpM (Identity . f)
composOpM :: Monad m => (forall a. Tree a -> m (Tree a)) -> Tree c -> m (Tree c)
composOpM = compos return ap
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
newtype C b a = C { unC :: b }
composOpFold :: b -> (b -> b -> b) -> (forall a. Tree a -> b) -> Tree c -> b
composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)
compos :: (forall a. a -> m a)
-> (forall a b. m (a -> b) -> m a -> m b)
-> (forall a. Tree a -> m (Tree a)) -> Tree c -> m (Tree c)
compos r a f t = case t of
Module decls -> r Module `a` foldr (a . a (r (:)) . f) (r []) decls
DataDecl cident exp consdecls -> r DataDecl `a` f cident `a` f exp `a` foldr (a . a (r (:)) . f) (r []) consdecls
TypeDecl cident exp -> r TypeDecl `a` f cident `a` f exp
ValueDecl cident exp -> r ValueDecl `a` f cident `a` f exp
ConsDecl cident exp -> r ConsDecl `a` f cident `a` f exp
PCons cident patterns -> r PCons `a` f cident `a` foldr (a . a (r (:)) . f) (r []) patterns
PVar patternvariable -> r PVar `a` f patternvariable
PRec fieldpatterns -> r PRec `a` foldr (a . a (r (:)) . f) (r []) fieldpatterns
FieldPattern cident pattern -> r FieldPattern `a` f cident `a` f pattern
PVVar cident -> r PVVar `a` f cident
ELet letdefs exp -> r ELet `a` foldr (a . a (r (:)) . f) (r []) letdefs `a` f exp
ECase exp cases -> r ECase `a` f exp `a` foldr (a . a (r (:)) . f) (r []) cases
EAbs patternvariable exp -> r EAbs `a` f patternvariable `a` f exp
EPi patternvariable exp0 exp1 -> r EPi `a` f patternvariable `a` f exp0 `a` f exp1
EApp exp0 exp1 -> r EApp `a` f exp0 `a` f exp1
EProj exp cident -> r EProj `a` f exp `a` f cident
ERecType fieldtypes -> r ERecType `a` foldr (a . a (r (:)) . f) (r []) fieldtypes
ERec fieldvalues -> r ERec `a` foldr (a . a (r (:)) . f) (r []) fieldvalues
EVar cident -> r EVar `a` f cident
EMeta tmeta -> r EMeta `a` f tmeta
LetDef cident exp -> r LetDef `a` f cident `a` f exp
Case pattern exp0 exp1 -> r Case `a` f pattern `a` f exp0 `a` f exp1
FieldType cident exp -> r FieldType `a` f cident `a` f exp
FieldValue cident exp -> r FieldValue `a` f cident `a` f exp
_ -> r t
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
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
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
EInteger n -> opar n . showString "EInteger" . showChar ' ' . showsPrec 1 n . cpar n
EDouble d -> opar n . showString "EDouble" . showChar ' ' . showsPrec 1 d . cpar n
EMeta tmeta -> opar n . showString "EMeta" . showChar ' ' . showsPrec 1 tmeta . cpar n
LetDef cident exp -> opar n . showString "LetDef" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
Case pattern exp0 exp1 -> opar n . showString "Case" . showChar ' ' . showsPrec 1 pattern . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . 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
TMeta str -> opar n . showString "TMeta" . showChar ' ' . showsPrec 1 str . 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 (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 (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 (EInteger n) (EInteger n_) = n == n_
johnMajorEq (EDouble d) (EDouble d_) = d == d_
johnMajorEq (EMeta tmeta) (EMeta tmeta_) = tmeta == tmeta_
johnMajorEq (LetDef cident exp) (LetDef cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (Case pattern exp0 exp1) (Case pattern_ exp0_ exp1_) = pattern == pattern_ && exp0 == exp0_ && exp1 == exp1_
johnMajorEq (FieldType cident exp) (FieldType cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (FieldValue cident exp) (FieldValue cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (TMeta str) (TMeta str_) = str == str_
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
index :: Tree c -> Int
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 (PStr _) = 8
index (PInt _) = 9
index (FieldPattern _ _) = 10
index (PVVar _) = 11
index (PVWild ) = 12
index (ELet _ _) = 13
index (ECase _ _) = 14
index (EAbs _ _) = 15
index (EPi _ _ _) = 16
index (EApp _ _) = 17
index (EProj _ _) = 18
index (ERecType _) = 19
index (ERec _) = 20
index (EVar _) = 21
index (EType ) = 22
index (EStr _) = 23
index (EInteger _) = 24
index (EDouble _) = 25
index (EMeta _) = 26
index (LetDef _ _) = 27
index (Case _ _ _) = 28
index (FieldType _ _) = 29
index (FieldValue _ _) = 30
index (TMeta _) = 31
index (CIdent _) = 32
compareSame :: Tree c -> Tree c -> Ordering
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 (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 (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 (EInteger n) (EInteger n_) = compare n n_
compareSame (EDouble d) (EDouble d_) = compare d d_
compareSame (EMeta tmeta) (EMeta tmeta_) = compare tmeta tmeta_
compareSame (LetDef cident exp) (LetDef cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
compareSame (Case pattern exp0 exp1) (Case pattern_ exp0_ exp1_) = mappend (compare pattern pattern_) (mappend (compare exp0 exp0_) (compare exp1 exp1_))
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 (TMeta str) (TMeta str_) = compare str str_
compareSame (CIdent str) (CIdent str_) = compare str str_
compareSame x y = error "BNFC error:" compareSame

93
src-3.0/Transfer/Core/Core.cf Normal file
View File

@@ -0,0 +1,93 @@
-- 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 ::= "rec" "{" [FieldPattern] "}";
-- 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 ;
separator LetDef ";" ;
-- Case expressions.
ECase. Exp ::= "case" Exp "of" "{" [Case] "}" ;
Case. Case ::= Pattern "|" Exp "->" Exp ;
separator Case ";" ;
-- Lambda abstractions.
EAbs. Exp1 ::= "\\" PatternVariable "->" Exp ;
-- Function types.
EPi. Exp1 ::= "(" PatternVariable ":" Exp ")" "->" Exp ;
-- Function application.
EApp. Exp3 ::= Exp3 Exp4 ;
-- Record field projection.
EProj. Exp4 ::= Exp4 "." CIdent ;
-- Record types.
ERecType. Exp5 ::= "sig" "{" [FieldType] "}" ;
FieldType. FieldType ::= CIdent ":" Exp ;
separator FieldType ";" ;
-- Record expressions.
ERec. Exp5 ::= "rec" "{" [FieldValue] "}" ;
FieldValue.FieldValue ::= CIdent "=" Exp ;
separator FieldValue ";" ;
-- Functions, constructors and local variables.
EVar. Exp5 ::= CIdent ;
-- The constant Type.
EType. Exp5 ::= "Type" ;
-- String literal expressions.
EStr. Exp5 ::= String ;
-- Integer literal expressions.
EInteger. Exp5 ::= Integer ;
-- Double literal expressions.
EDouble. Exp5 ::= Double ;
-- Meta variables
EMeta. Exp5 ::= TMeta ;
token TMeta ('?' digit+) ;
coercions Exp 5 ;
-- Identifiers in core can start with underscore to allow
-- generating unique identifiers easily.
token CIdent ((letter | '_') (letter | digit | '_' | '\'')*) ;

215
src-3.0/Transfer/Core/Doc.tex Normal file
View File

@@ -0,0 +1,215 @@
\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.
Double-precision float literals \nonterminal{Double}\ have the structure
indicated by the regular expression $\nonterminal{digit}+ \mbox{{\it `.'}} \nonterminal{digit}+ (\mbox{{\it `e'}} \mbox{{\it `-'}}? \nonterminal{digit}+)?$ i.e.\
two sequences of digits separated by a decimal point, optionally
followed by an unsigned or negative exponent.
TMeta literals are recognized by the regular expression
\(\mbox{`?'} {\nonterminal{digit}}+\)
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{rec}} &{\reserved{sig}} &{\reserved{where}} \\
\end{tabular}\\
The symbols used in Core are the following: \\
\begin{tabular}{lll}
{\symb{;}} &{\symb{:}} &{\symb{\{}} \\
{\symb{\}}} &{\symb{{$=$}}} &{\symb{(}} \\
{\symb{)}} &{\symb{\_}} &{\symb{{$|$}}} \\
{\symb{{$-$}{$>$}}} &{\symb{$\backslash$}} &{\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{rec}} {\terminal{\{}} {\nonterminal{ListFieldPattern}} {\terminal{\}}} \\
& {\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}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{ListLetDef}} & {\arrow} &{\emptyP} \\
& {\delimit} &{\nonterminal{LetDef}} \\
& {\delimit} &{\nonterminal{LetDef}} {\terminal{;}} {\nonterminal{ListLetDef}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{Case}} & {\arrow} &{\nonterminal{Pattern}} {\terminal{{$|$}}} {\nonterminal{Exp}} {\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{Exp1}} & {\arrow} &{\terminal{$\backslash$}} {\nonterminal{PatternVariable}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}} \\
& {\delimit} &{\terminal{(}} {\nonterminal{PatternVariable}} {\terminal{:}} {\nonterminal{Exp}} {\terminal{)}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}} \\
& {\delimit} &{\nonterminal{Exp2}} \\
\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{sig}} {\terminal{\{}} {\nonterminal{ListFieldType}} {\terminal{\}}} \\
& {\delimit} &{\terminal{rec}} {\terminal{\{}} {\nonterminal{ListFieldValue}} {\terminal{\}}} \\
& {\delimit} &{\nonterminal{CIdent}} \\
& {\delimit} &{\terminal{Type}} \\
& {\delimit} &{\nonterminal{String}} \\
& {\delimit} &{\nonterminal{Integer}} \\
& {\delimit} &{\nonterminal{Double}} \\
& {\delimit} &{\nonterminal{TMeta}} \\
& {\delimit} &{\terminal{(}} {\nonterminal{Exp}} {\terminal{)}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{FieldType}} & {\arrow} &{\nonterminal{CIdent}} {\terminal{:}} {\nonterminal{Exp}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{ListFieldType}} & {\arrow} &{\emptyP} \\
& {\delimit} &{\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} &{\emptyP} \\
& {\delimit} &{\nonterminal{FieldValue}} \\
& {\delimit} &{\nonterminal{FieldValue}} {\terminal{;}} {\nonterminal{ListFieldValue}} \\
\end{tabular}\\
\begin{tabular}{lll}
{\nonterminal{Exp2}} & {\arrow} &{\nonterminal{Exp3}} \\
\end{tabular}\\
\end{document}

343
src-3.0/Transfer/Core/Lex.hs Normal file
View File

File diff suppressed because one or more lines are too long

140
src-3.0/Transfer/Core/Lex.x Normal file
View File

@@ -0,0 +1,140 @@
-- -*- haskell -*-
-- This Alex file was machine-generated by the BNF converter
{
{-# OPTIONS -fno-warn-incomplete-patterns #-}
module Transfer.Core.Lex where
}
$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 = -- symbols and non-identifier-like reserved words
\; | \: | \{ | \} | \= | \( | \) | \_ | \| | \- \> | \\ | \.
:-
"--" [.]* ; -- Toss single line comments
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
$white+ ;
@rsyms { tok (\p s -> PT p (TS $ share s)) }
\? $d + { tok (\p s -> PT p (eitherResIdent (T_TMeta . 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)) }
$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
{
tok f p s = f p s
share :: String -> String
share = id
data Tok =
TS !String -- reserved words and symbols
| TL !String -- string literals
| TI !String -- integer literals
| TV !String -- identifiers
| TD !String -- double precision float literals
| TC !String -- character literals
| T_TMeta !String
| 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_TMeta 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 "let" (b "data" (b "case" (b "Type" N N) N) (b "in" N N)) (b "sig" (b "rec" (b "of" N 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
}

1149
src-3.0/Transfer/Core/Par.hs Normal file
View File

File diff suppressed because it is too large Load Diff

203
src-3.0/Transfer/Core/Par.y Normal file
View File

@@ -0,0 +1,203 @@
-- This Happy file was machine-generated by the BNF converter
{
{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
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 "\\") }
'.' { 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") }
'rec' { PT _ (TS "rec") }
'sig' { PT _ (TS "sig") }
'where' { PT _ (TS "where") }
L_quoted { PT _ (TL $$) }
L_integ { PT _ (TI $$) }
L_doubl { PT _ (TD $$) }
L_TMeta { PT _ (T_TMeta $$) }
L_CIdent { PT _ (T_CIdent $$) }
L_err { _ }
%%
String :: { String } : L_quoted { $1 }
Integer :: { Integer } : L_integ { (read $1) :: Integer }
Double :: { Double } : L_doubl { (read $1) :: Double }
TMeta :: { TMeta} : L_TMeta { TMeta ($1)}
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 }
| 'rec' '{' ListFieldPattern '}' { PRec $3 }
| 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 { LetDef $1 $3 }
ListLetDef :: { [LetDef] }
ListLetDef : {- empty -} { [] }
| LetDef { (:[]) $1 }
| LetDef ';' ListLetDef { (:) $1 $3 }
Case :: { Case }
Case : Pattern '|' Exp '->' Exp { Case $1 $3 $5 }
ListCase :: { [Case] }
ListCase : {- empty -} { [] }
| Case { (:[]) $1 }
| Case ';' ListCase { (:) $1 $3 }
Exp1 :: { Exp }
Exp1 : '\\' PatternVariable '->' Exp { EAbs $2 $4 }
| '(' PatternVariable ':' Exp ')' '->' Exp { EPi $2 $4 $7 }
| Exp2 { $1 }
Exp3 :: { Exp }
Exp3 : Exp3 Exp4 { EApp $1 $2 }
| Exp4 { $1 }
Exp4 :: { Exp }
Exp4 : Exp4 '.' CIdent { EProj $1 $3 }
| Exp5 { $1 }
Exp5 :: { Exp }
Exp5 : 'sig' '{' ListFieldType '}' { ERecType $3 }
| 'rec' '{' ListFieldValue '}' { ERec $3 }
| CIdent { EVar $1 }
| 'Type' { EType }
| String { EStr $1 }
| Integer { EInteger $1 }
| Double { EDouble $1 }
| TMeta { EMeta $1 }
| '(' Exp ')' { $2 }
FieldType :: { FieldType }
FieldType : CIdent ':' Exp { FieldType $1 $3 }
ListFieldType :: { [FieldType] }
ListFieldType : {- empty -} { [] }
| FieldType { (:[]) $1 }
| FieldType ';' ListFieldType { (:) $1 $3 }
FieldValue :: { FieldValue }
FieldValue : CIdent '=' Exp { FieldValue $1 $3 }
ListFieldValue :: { [FieldValue] }
ListFieldValue : {- empty -} { [] }
| FieldValue { (:[]) $1 }
| FieldValue ';' ListFieldValue { (:) $1 $3 }
Exp2 :: { Exp }
Exp2 : Exp3 { $1 }
{
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
}

155
src-3.0/Transfer/Core/Print.hs Normal file
View File

@@ -0,0 +1,155 @@
{-# 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 "rec") , doc (showString "{") , prt 0 fieldpatterns , doc (showString "}")])
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 1 (concatD [doc (showString "\\") , prt 0 patternvariable , doc (showString "->") , prt 0 exp])
EPi patternvariable exp0 exp1 -> prPrec _i 1 (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])
ERecType fieldtypes -> prPrec _i 5 (concatD [doc (showString "sig") , doc (showString "{") , prt 0 fieldtypes , doc (showString "}")])
ERec fieldvalues -> prPrec _i 5 (concatD [doc (showString "rec") , 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])
EInteger n -> prPrec _i 5 (concatD [prt 0 n])
EDouble d -> prPrec _i 5 (concatD [prt 0 d])
EMeta tmeta -> prPrec _i 5 (concatD [prt 0 tmeta])
LetDef cident exp -> prPrec _i 0 (concatD [prt 0 cident , doc (showString "=") , prt 0 exp])
Case pattern exp0 exp1 -> prPrec _i 0 (concatD [prt 0 pattern , doc (showString "|") , prt 0 exp0 , doc (showString "->") , prt 0 exp1])
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])
TMeta str -> prPrec _i 0 (doc (showString str))
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
[] -> (concatD [])
[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
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])

119
src-3.0/Transfer/Core/Skel.hs Normal file
View File

@@ -0,0 +1,119 @@
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
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
ERecType fieldtypes -> failure t
ERec fieldvalues -> failure t
EVar cident -> failure t
EType -> failure t
EStr str -> failure t
EInteger n -> failure t
EDouble d -> failure t
EMeta tmeta -> failure t
LetDef cident exp -> failure t
Case pattern exp0 exp1 -> failure t
FieldType cident exp -> failure t
FieldValue cident exp -> failure t
TMeta str -> 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
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
ERecType fieldtypes -> failure t
ERec fieldvalues -> failure t
EVar cident -> failure t
EType -> failure t
EStr str -> failure t
EInteger n -> failure t
EDouble d -> failure t
EMeta tmeta -> failure t
transLetDef :: LetDef -> Result
transLetDef t = case t of
LetDef cident exp -> failure t
transCase :: Case -> Result
transCase t = case t of
Case pattern exp0 exp1 -> 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
transTMeta :: TMeta -> Result
transTMeta t = case t of
TMeta str -> failure t
transCIdent :: CIdent -> Result
transCIdent t = case t of
CIdent str -> failure t

58
src-3.0/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