Move transfer into the GF repo.

src/Transfer/Core/Abs.hs

@@ -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

src/Transfer/Core/Core.cf

@@ -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 | '_' | '\'')*) ;

src/Transfer/Core/Doc.tex

@@ -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}
+

src/Transfer/Core/Lex.x

@@ -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
+}

src/Transfer/Core/Par.y

@@ -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
+}
+

src/Transfer/Core/Print.hs

@@ -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])

src/Transfer/Core/Skel.hs

@@ -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
+

src/Transfer/Core/Test.hs

@@ -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
+
+
+
+
+

src/Transfer/ErrM.hs

@@ -0,0 +1,16 @@
+-- BNF Converter: Error Monad
+-- Copyright (C) 2004  Author:  Aarne Ranta
+
+-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
+module Transfer.ErrM where
+
+-- the Error monad: like Maybe type with error msgs
+
+data Err a = Ok a | Bad String
+  deriving (Read, Show, Eq)
+
+instance Monad Err where
+  return      = Ok
+  fail        = Bad
+  Ok a  >>= f = f a
+  Bad s >>= f = Bad s

src/Transfer/Interpreter.hs

@@ -0,0 +1,169 @@
+module Transfer.Interpreter where
+
+import Transfer.Core.Abs
+import Transfer.Core.Print
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+
+import Debug.Trace
+
+data Value = VStr String
+           | VInt Integer
+           | VType
+           | VRec [(CIdent,Value)]
+           | VAbs (Value -> Value)
+           | VPi (Value -> Value)
+           | VCons CIdent [Value]
+  deriving (Show)
+
+instance Show (a -> b) where
+    show _ = "<<function>>"
+
+type Env = [(CIdent,Value)]
+
+
+builtin :: Env
+builtin = [mkIntUn  "neg" negate,
+           mkIntBin "add" (+),
+           mkIntBin "sub" (-),
+           mkIntBin "mul" (*),
+           mkIntBin "div" div,
+           mkIntBin "mod" mod,
+           mkIntCmp "lt"  (<),
+           mkIntCmp "le"  (<=),
+           mkIntCmp "gt"  (>),
+           mkIntCmp "ge"  (>=),
+           mkIntCmp "eq"  (==),
+           mkIntCmp "ne"  (/=)]
+  where 
+  mkIntUn x f = let c = CIdent ("prim_"++x++"_Int")
+                 in (c, VAbs (\n -> appInt1 c (VInt . f) n))
+  mkIntBin x f = let c = CIdent ("prim_"++x++"_Int")
+                  in (c, VAbs (\n -> VAbs (\m -> appInt2 c (\n m -> VInt (f n m)) n m )))
+  mkIntCmp x f = let c = CIdent ("prim_"++x++"_Int")
+                  in (c, VAbs (\n -> VAbs (\m -> appInt2 c (\n m -> toBool (f n m)) n m)))
+  toBool b = VCons (CIdent (if b then "True" else "False")) []
+  appInt1 c f x = case x of
+                         VInt n -> f n
+                         _ -> error $ printValue x ++ " is not an integer" -- VCons c [x]
+  appInt2 c f x y = case (x,y) of
+                         (VInt n,VInt m) -> f n m
+                         _ -> error $ printValue x ++ " and " ++ printValue y ++ " are not both integers" -- VCons c [x,y]
+
+addModuleEnv :: Env -> Module -> Env
+addModuleEnv env (Module ds) = 
+    let env' = [ (c,VCons c []) | DataDecl _ _ cs <- ds, ConsDecl c _ <- cs ] 
+              ++ [ (t,VCons t []) | DataDecl t _  _ <- ds ] 
+              ++ [ (x,eval env' e) | ValueDecl x e <- ds]
+              ++ env
+     in env'
+
+eval :: Env -> Exp -> Value
+eval env x = case x of
+  ELet defs exp2 -> 
+      let env' = deepSeqList [ v `seq` (id, v) | LetDef id _ e <- defs, 
+                                                 let v = eval env' e] 
+                 ++ env
+       in eval env' exp2
+  ECase exp cases  -> let v = eval env exp
+                          r = case firstMatch v cases of
+                                  Nothing -> error $ "No pattern matched " ++ printValue v
+                                  Just (e,bs) -> eval (bs++env) e
+                         in v `seq` r
+  EAbs id exp  -> VAbs $! (\v -> eval (bind id v ++ env) exp)
+  EPi id _ exp  -> VPi $! (\v -> eval (bind id v ++ env) exp)
+  EApp exp1 exp2 -> let v1 = eval env exp1
+                        v2 = eval env exp2
+                     in case v1 of
+                               VAbs f -> f $! v2
+                               VCons c vs -> (VCons $! c) $! ((++) $! vs) $! [v2]
+                               _ -> error $ "Bad application (" ++ printValue v1 ++ ") (" ++ printValue v2 ++ ")"
+  EProj exp id  -> let v = eval env exp
+                    in case v of
+                               VRec fs -> recLookup id fs
+                               _ -> error $ printValue v ++ " is not a record, cannot get field " ++ printTree id
+
+  EEmptyRec  -> VRec []
+  ERecType fts -> VRec $! deepSeqList $! [ v `seq` (f,v) | FieldType  f e <- fts, let v = eval env e]
+  ERec fvs     -> VRec $! deepSeqList $! [ v `seq` (f,v) | FieldValue f e <- fvs, let v = eval env e]
+  EVar id  -> case lookup id env of
+                    Just x -> x
+                    Nothing -> error $ "Variable " ++ printTree id ++ " not in environment."
+                                       ++ " Environment contains: " ++ show (map (printTree . fst) env)
+  EType  -> VType
+  EStr str  -> VStr str
+  EInt n  -> VInt n
+
+firstMatch :: Value -> [Case] -> Maybe (Exp,Env)
+firstMatch _ [] = Nothing
+firstMatch v (Case p e:cs) = case match p v of
+                                            Nothing -> firstMatch v cs
+                                            Just env -> {- trace (show v ++ " matched " ++ show p) $ -} Just (e,env)
+
+bind :: PatternVariable -> Value -> Env
+bind (PVVar x) v = [(x,v)]
+bind PVWild _ = []
+
+match :: Pattern -> Value -> Maybe Env
+match (PCons c' ps) (VCons c vs) 
+    | c == c' = if length vs == length ps 
+                 then concatM $ zipWith match ps vs
+                 else error $ "Wrong number of arguments to " ++ printTree c
+match (PVar x) v                   = Just (bind x v)
+match (PRec fps) (VRec fs) = concatM [ match p (recLookup f fs) | FieldPattern f p <- fps ]
+match (PInt i) (VInt i') | i == i' = Just []
+match PType VType                  = Just []
+match (PStr s) (VStr s') | s == s' = Just []
+match (PInt i) (VInt i') | i == i' = Just []
+match _ _ = Nothing
+
+
+recLookup :: CIdent -> [(CIdent,Value)] -> Value
+recLookup l fs = 
+    case lookup l fs of
+        Just x -> x
+        Nothing -> error $ printValue (VRec fs) ++ " has no field " ++ printTree l
+
+--
+-- * Utilities
+--
+
+concatM :: Monad m => [m [a]] -> m [a]
+concatM = liftM concat . sequence
+
+-- | Force a list and its values.
+deepSeqList :: [a] -> [a]
+deepSeqList = foldr (\x xs -> x `seq` xs `seq` (x:xs)) []
+
+--
+-- * Pretty printing of values
+--
+
+printValue :: Value -> String
+printValue v = prValue 0 0 v ""
+  where
+  prValue p n v = case v of
+              VStr s     -> shows s
+              VInt i     -> shows i
+              VType      -> showString "Type"
+              VRec cs    -> showChar '{' . joinS (showChar ';') 
+                               (map prField cs) . showChar '}'
+              VAbs f     -> showString "<<function>>"
+                            {- let x = "$"++show n
+                             in showChar '\\' . showString (x++" -> ") 
+                                    . prValue 0 (n+1) (f (VCons (CIdent x) [])) -- hacky to use VCons
+                             -}
+              VPi f      -> showString "<<function type>>"
+              VCons c [] -> showIdent c
+              VCons c vs -> parenth (showIdent c . concatS (map (\v -> spaceS . prValue 1 n v) vs))
+   where prField (i,v) = showIdent i . showChar '=' . prValue 0 n v
+         parenth s = if p > 0 then showChar '(' . s . showChar ')' else s
+  showIdent (CIdent i) = showString i
+
+spaceS :: ShowS
+spaceS = showChar ' '
+
+joinS :: ShowS -> [ShowS] -> ShowS
+joinS glue = concatS . intersperse glue

src/Transfer/InterpreterAPI.hs

@@ -0,0 +1,31 @@
+module Transfer.InterpreterAPI (Env, load, loadFile, evaluateString) where
+
+import Transfer.Core.Abs
+import Transfer.Core.Lex
+import Transfer.Core.Par
+import Transfer.Core.Print
+import Transfer.Interpreter
+import Transfer.ErrM
+
+-- | Read a transfer module in core format from a string.
+load :: Monad m => 
+        String -- ^ Input source name, for error messages.
+     -> String -- ^ Module contents.
+     -> m Env
+load n s = case pModule (myLexer s) of
+              Bad e -> fail $ "Parse error in " ++ n ++ ": " ++ e
+              Ok  m -> return $ addModuleEnv builtin m
+
+-- | Read a transfer module in core format from a file.
+loadFile :: FilePath -> IO Env
+loadFile f = readFile f >>= load f
+
+-- | Read a transfer expression from a string and evaluate it.
+--   Returns the result as a string.
+evaluateString :: Monad m => Env -> String -> m String
+evaluateString env s = 
+    case pExp (myLexer s) of
+        Bad e -> fail $ "Parse error: " ++ e
+        Ok  e -> do
+                 let v = eval env e
+                 return $ printValue v

src/Transfer/PathUtil.hs

@@ -0,0 +1,110 @@
+{-# OPTIONS_GHC -cpp #-}
+
+-----------------------------------------------------------------------------
+-- File name and directory utilities. Stolen from 
+-- ghc-6.4.1/ghc/compiler/main/DriverUtil.hs
+--
+-- (c) The University of Glasgow 2000
+--
+-----------------------------------------------------------------------------
+
+module Transfer.PathUtil (
+	Suffix, splitFilename, getFileSuffix,
+	splitFilename3, remove_suffix, split_longest_prefix,
+	replaceFilenameSuffix, directoryOf, filenameOf,
+	replaceFilenameDirectory, replaceFilename, remove_spaces, escapeSpaces,
+  ) where
+
+import Data.Char (isSpace)
+	
+type Suffix = String
+
+splitFilename :: String -> (String,Suffix)
+splitFilename f = split_longest_prefix f (=='.')
+
+getFileSuffix :: String -> Suffix
+getFileSuffix f = drop_longest_prefix f (=='.')
+
+-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
+splitFilenameDir :: String -> (String,String)
+splitFilenameDir str
+  = let (dir, rest) = split_longest_prefix str isPathSeparator
+  	real_dir | null dir  = "."
+		 | otherwise = dir
+    in  (real_dir, rest)
+
+-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
+splitFilename3 :: String -> (String,String,Suffix)
+splitFilename3 str
+   = let (dir, rest) = split_longest_prefix str isPathSeparator
+	 (name, ext) = splitFilename rest
+	 real_dir | null dir  = "."
+		  | otherwise = dir
+     in  (real_dir, name, ext)
+
+remove_suffix :: Char -> String -> Suffix
+remove_suffix c s
+  | null pre  = s
+  | otherwise = reverse pre
+  where (suf,pre) = break (==c) (reverse s)
+
+drop_longest_prefix :: String -> (Char -> Bool) -> String
+drop_longest_prefix s pred = reverse suf
+  where (suf,_pre) = break pred (reverse s)
+
+take_longest_prefix :: String -> (Char -> Bool) -> String
+take_longest_prefix s pred = reverse pre
+  where (_suf,pre) = break pred (reverse s)
+
+-- split a string at the last character where 'pred' is True,
+-- returning a pair of strings. The first component holds the string
+-- up (but not including) the last character for which 'pred' returned
+-- True, the second whatever comes after (but also not including the
+-- last character).
+--
+-- If 'pred' returns False for all characters in the string, the original
+-- string is returned in the second component (and the first one is just
+-- empty).
+split_longest_prefix :: String -> (Char -> Bool) -> (String,String)
+split_longest_prefix s pred
+  = case pre of
+	[]      -> ([], reverse suf)
+	(_:pre) -> (reverse pre, reverse suf)
+  where (suf,pre) = break pred (reverse s)
+
+replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
+replaceFilenameSuffix s suf = remove_suffix '.' s ++ suf
+
+-- directoryOf strips the filename off the input string, returning
+-- the directory.
+directoryOf :: FilePath -> String
+directoryOf = fst . splitFilenameDir
+
+-- filenameOf strips the directory off the input string, returning
+-- the filename.
+filenameOf :: FilePath -> String
+filenameOf = snd . splitFilenameDir
+
+replaceFilenameDirectory :: FilePath -> String -> FilePath
+replaceFilenameDirectory s dir
+ = dir ++ '/':drop_longest_prefix s isPathSeparator
+
+replaceFilename :: FilePath -> String -> FilePath
+replaceFilename f n
+ = case directoryOf f of
+                      "" -> n
+                      d  -> d ++ '/' : n
+
+remove_spaces :: String -> String
+remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+
+escapeSpaces :: String -> String
+escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
+
+isPathSeparator :: Char -> Bool
+isPathSeparator ch =
+#ifdef mingw32_TARGET_OS
+  ch == '/' || ch == '\\'
+#else
+  ch == '/'
+#endif

src/Transfer/Syntax/Abs.hs

@@ -0,0 +1,415 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module Transfer.Syntax.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 Import_
+type Import = Tree Import_
+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 Exp_
+type Exp = Tree Exp_
+data LetDef_
+type LetDef = Tree LetDef_
+data Case_
+type Case = Tree Case_
+data VarOrWild_
+type VarOrWild = Tree VarOrWild_
+data FieldType_
+type FieldType = Tree FieldType_
+data FieldValue_
+type FieldValue = Tree FieldValue_
+data Ident_
+type Ident = Tree Ident_
+
+data Tree :: * -> * where
+    Module :: [Import] -> [Decl] -> Tree Module_
+    Import :: Ident -> Tree Import_
+    DataDecl :: Ident -> Exp -> [ConsDecl] -> Tree Decl_
+    TypeDecl :: Ident -> Exp -> Tree Decl_
+    ValueDecl :: Ident -> [Pattern] -> Exp -> Tree Decl_
+    DeriveDecl :: Ident -> Ident -> Tree Decl_
+    ConsDecl :: Ident -> Exp -> Tree ConsDecl_
+    PConsTop :: Ident -> Pattern -> [Pattern] -> Tree Pattern_
+    PCons :: Ident -> [Pattern] -> Tree Pattern_
+    PRec :: [FieldPattern] -> Tree Pattern_
+    PType :: Tree Pattern_
+    PStr :: String -> Tree Pattern_
+    PInt :: Integer -> Tree Pattern_
+    PVar :: Ident -> Tree Pattern_
+    PWild :: Tree Pattern_
+    FieldPattern :: Ident -> Pattern -> Tree FieldPattern_
+    ELet :: [LetDef] -> Exp -> Tree Exp_
+    ECase :: Exp -> [Case] -> Tree Exp_
+    EIf :: Exp -> Exp -> Exp -> Tree Exp_
+    EAbs :: VarOrWild -> Exp -> Tree Exp_
+    EPi :: VarOrWild -> Exp -> Exp -> Tree Exp_
+    EPiNoVar :: Exp -> Exp -> Tree Exp_
+    EOr :: Exp -> Exp -> Tree Exp_
+    EAnd :: Exp -> Exp -> Tree Exp_
+    EEq :: Exp -> Exp -> Tree Exp_
+    ENe :: Exp -> Exp -> Tree Exp_
+    ELt :: Exp -> Exp -> Tree Exp_
+    ELe :: Exp -> Exp -> Tree Exp_
+    EGt :: Exp -> Exp -> Tree Exp_
+    EGe :: Exp -> Exp -> Tree Exp_
+    EAdd :: Exp -> Exp -> Tree Exp_
+    ESub :: Exp -> Exp -> Tree Exp_
+    EMul :: Exp -> Exp -> Tree Exp_
+    EDiv :: Exp -> Exp -> Tree Exp_
+    EMod :: Exp -> Exp -> Tree Exp_
+    EProj :: Exp -> Ident -> Tree Exp_
+    ENeg :: Exp -> Tree Exp_
+    EApp :: Exp -> Exp -> Tree Exp_
+    EEmptyRec :: Tree Exp_
+    ERecType :: [FieldType] -> Tree Exp_
+    ERec :: [FieldValue] -> Tree Exp_
+    EVar :: Ident -> Tree Exp_
+    EType :: Tree Exp_
+    EStr :: String -> Tree Exp_
+    EInt :: Integer -> Tree Exp_
+    LetDef :: Ident -> Exp -> Exp -> Tree LetDef_
+    Case :: Pattern -> Exp -> Tree Case_
+    VVar :: Ident -> Tree VarOrWild_
+    VWild :: Tree VarOrWild_
+    FieldType :: Ident -> Exp -> Tree FieldType_
+    FieldValue :: Ident -> Exp -> Tree FieldValue_
+    Ident :: String -> Tree Ident_
+
+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 imports decls -> return Module `ap` mapM f imports `ap` mapM f decls
+    Import i -> return Import `ap` f i
+    DataDecl i exp consdecls -> return DataDecl `ap` f i `ap` f exp `ap` mapM f consdecls
+    TypeDecl i exp -> return TypeDecl `ap` f i `ap` f exp
+    ValueDecl i patterns exp -> return ValueDecl `ap` f i `ap` mapM f patterns `ap` f exp
+    DeriveDecl i0 i1 -> return DeriveDecl `ap` f i0 `ap` f i1
+    ConsDecl i exp -> return ConsDecl `ap` f i `ap` f exp
+    PConsTop i pattern patterns -> return PConsTop `ap` f i `ap` f pattern `ap` mapM f patterns
+    PCons i patterns -> return PCons `ap` f i `ap` mapM f patterns
+    PRec fieldpatterns -> return PRec `ap` mapM f fieldpatterns
+    PVar i -> return PVar `ap` f i
+    FieldPattern i pattern -> return FieldPattern `ap` f i `ap` f pattern
+    ELet letdefs exp -> return ELet `ap` mapM f letdefs `ap` f exp
+    ECase exp cases -> return ECase `ap` f exp `ap` mapM f cases
+    EIf exp0 exp1 exp2 -> return EIf `ap` f exp0 `ap` f exp1 `ap` f exp2
+    EAbs varorwild exp -> return EAbs `ap` f varorwild `ap` f exp
+    EPi varorwild exp0 exp1 -> return EPi `ap` f varorwild `ap` f exp0 `ap` f exp1
+    EPiNoVar exp0 exp1 -> return EPiNoVar `ap` f exp0 `ap` f exp1
+    EOr exp0 exp1 -> return EOr `ap` f exp0 `ap` f exp1
+    EAnd exp0 exp1 -> return EAnd `ap` f exp0 `ap` f exp1
+    EEq exp0 exp1 -> return EEq `ap` f exp0 `ap` f exp1
+    ENe exp0 exp1 -> return ENe `ap` f exp0 `ap` f exp1
+    ELt exp0 exp1 -> return ELt `ap` f exp0 `ap` f exp1
+    ELe exp0 exp1 -> return ELe `ap` f exp0 `ap` f exp1
+    EGt exp0 exp1 -> return EGt `ap` f exp0 `ap` f exp1
+    EGe exp0 exp1 -> return EGe `ap` f exp0 `ap` f exp1
+    EAdd exp0 exp1 -> return EAdd `ap` f exp0 `ap` f exp1
+    ESub exp0 exp1 -> return ESub `ap` f exp0 `ap` f exp1
+    EMul exp0 exp1 -> return EMul `ap` f exp0 `ap` f exp1
+    EDiv exp0 exp1 -> return EDiv `ap` f exp0 `ap` f exp1
+    EMod exp0 exp1 -> return EMod `ap` f exp0 `ap` f exp1
+    EProj exp i -> return EProj `ap` f exp `ap` f i
+    ENeg exp -> return ENeg `ap` f exp
+    EApp exp0 exp1 -> return EApp `ap` f exp0 `ap` f exp1
+    ERecType fieldtypes -> return ERecType `ap` mapM f fieldtypes
+    ERec fieldvalues -> return ERec `ap` mapM f fieldvalues
+    EVar i -> return EVar `ap` f i
+    LetDef i exp0 exp1 -> return LetDef `ap` f i `ap` f exp0 `ap` f exp1
+    Case pattern exp -> return Case `ap` f pattern `ap` f exp
+    VVar i -> return VVar `ap` f i
+    FieldType i exp -> return FieldType `ap` f i `ap` f exp
+    FieldValue i exp -> return FieldValue `ap` f i `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 imports decls -> foldr combine zero (map f imports) `combine` foldr combine zero (map f decls)
+    Import i -> f i
+    DataDecl i exp consdecls -> f i `combine` f exp `combine` foldr combine zero (map f consdecls)
+    TypeDecl i exp -> f i `combine` f exp
+    ValueDecl i patterns exp -> f i `combine` foldr combine zero (map f patterns) `combine` f exp
+    DeriveDecl i0 i1 -> f i0 `combine` f i1
+    ConsDecl i exp -> f i `combine` f exp
+    PConsTop i pattern patterns -> f i `combine` f pattern `combine` foldr combine zero (map f patterns)
+    PCons i patterns -> f i `combine` foldr combine zero (map f patterns)
+    PRec fieldpatterns -> foldr combine zero (map f fieldpatterns)
+    PVar i -> f i
+    FieldPattern i pattern -> f i `combine` f pattern
+    ELet letdefs exp -> foldr combine zero (map f letdefs) `combine` f exp
+    ECase exp cases -> f exp `combine` foldr combine zero (map f cases)
+    EIf exp0 exp1 exp2 -> f exp0 `combine` f exp1 `combine` f exp2
+    EAbs varorwild exp -> f varorwild `combine` f exp
+    EPi varorwild exp0 exp1 -> f varorwild `combine` f exp0 `combine` f exp1
+    EPiNoVar exp0 exp1 -> f exp0 `combine` f exp1
+    EOr exp0 exp1 -> f exp0 `combine` f exp1
+    EAnd exp0 exp1 -> f exp0 `combine` f exp1
+    EEq exp0 exp1 -> f exp0 `combine` f exp1
+    ENe exp0 exp1 -> f exp0 `combine` f exp1
+    ELt exp0 exp1 -> f exp0 `combine` f exp1
+    ELe exp0 exp1 -> f exp0 `combine` f exp1
+    EGt exp0 exp1 -> f exp0 `combine` f exp1
+    EGe exp0 exp1 -> f exp0 `combine` f exp1
+    EAdd exp0 exp1 -> f exp0 `combine` f exp1
+    ESub exp0 exp1 -> f exp0 `combine` f exp1
+    EMul exp0 exp1 -> f exp0 `combine` f exp1
+    EDiv exp0 exp1 -> f exp0 `combine` f exp1
+    EMod exp0 exp1 -> f exp0 `combine` f exp1
+    EProj exp i -> f exp `combine` f i
+    ENeg exp -> f exp
+    EApp exp0 exp1 -> f exp0 `combine` f exp1
+    ERecType fieldtypes -> foldr combine zero (map f fieldtypes)
+    ERec fieldvalues -> foldr combine zero (map f fieldvalues)
+    EVar i -> f i
+    LetDef i exp0 exp1 -> f i `combine` f exp0 `combine` f exp1
+    Case pattern exp -> f pattern `combine` f exp
+    VVar i -> f i
+    FieldType i exp -> f i `combine` f exp
+    FieldValue i exp -> f i `combine` f exp
+    _ -> zero
+
+instance Show (Tree c) where
+  showsPrec n t = case t of
+    Module imports decls -> opar n . showString "Module" . showChar ' ' . showsPrec 1 imports . showChar ' ' . showsPrec 1 decls . cpar n
+    Import i -> opar n . showString "Import" . showChar ' ' . showsPrec 1 i . cpar n
+    DataDecl i exp consdecls -> opar n . showString "DataDecl" . showChar ' ' . showsPrec 1 i . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 consdecls . cpar n
+    TypeDecl i exp -> opar n . showString "TypeDecl" . showChar ' ' . showsPrec 1 i . showChar ' ' . showsPrec 1 exp . cpar n
+    ValueDecl i patterns exp -> opar n . showString "ValueDecl" . showChar ' ' . showsPrec 1 i . showChar ' ' . showsPrec 1 patterns . showChar ' ' . showsPrec 1 exp . cpar n
+    DeriveDecl i0 i1 -> opar n . showString "DeriveDecl" . showChar ' ' . showsPrec 1 i0 . showChar ' ' . showsPrec 1 i1 . cpar n
+    ConsDecl i exp -> opar n . showString "ConsDecl" . showChar ' ' . showsPrec 1 i . showChar ' ' . showsPrec 1 exp . cpar n
+    PConsTop i pattern patterns -> opar n . showString "PConsTop" . showChar ' ' . showsPrec 1 i . showChar ' ' . showsPrec 1 pattern . showChar ' ' . showsPrec 1 patterns . cpar n
+    PCons i patterns -> opar n . showString "PCons" . showChar ' ' . showsPrec 1 i . showChar ' ' . showsPrec 1 patterns . 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
+    PVar i -> opar n . showString "PVar" . showChar ' ' . showsPrec 1 i . cpar n
+    PWild -> showString "PWild"
+    FieldPattern i pattern -> opar n . showString "FieldPattern" . showChar ' ' . showsPrec 1 i . showChar ' ' . showsPrec 1 pattern . cpar n
+    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
+    EIf exp0 exp1 exp2 -> opar n . showString "EIf" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . showChar ' ' . showsPrec 1 exp2 . cpar n
+    EAbs varorwild exp -> opar n . showString "EAbs" . showChar ' ' . showsPrec 1 varorwild . showChar ' ' . showsPrec 1 exp . cpar n
+    EPi varorwild exp0 exp1 -> opar n . showString "EPi" . showChar ' ' . showsPrec 1 varorwild . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    EPiNoVar exp0 exp1 -> opar n . showString "EPiNoVar" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    EOr exp0 exp1 -> opar n . showString "EOr" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    EAnd exp0 exp1 -> opar n . showString "EAnd" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    EEq exp0 exp1 -> opar n . showString "EEq" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    ENe exp0 exp1 -> opar n . showString "ENe" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    ELt exp0 exp1 -> opar n . showString "ELt" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    ELe exp0 exp1 -> opar n . showString "ELe" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    EGt exp0 exp1 -> opar n . showString "EGt" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    EGe exp0 exp1 -> opar n . showString "EGe" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    EAdd exp0 exp1 -> opar n . showString "EAdd" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    ESub exp0 exp1 -> opar n . showString "ESub" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    EMul exp0 exp1 -> opar n . showString "EMul" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    EDiv exp0 exp1 -> opar n . showString "EDiv" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    EMod exp0 exp1 -> opar n . showString "EMod" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
+    EProj exp i -> opar n . showString "EProj" . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 i . cpar n
+    ENeg exp -> opar n . showString "ENeg" . showChar ' ' . showsPrec 1 exp . cpar n
+    EApp exp0 exp1 -> opar n . showString "EApp" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . 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 i -> opar n . showString "EVar" . showChar ' ' . showsPrec 1 i . 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 i exp0 exp1 -> opar n . showString "LetDef" . showChar ' ' . showsPrec 1 i . 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
+    VVar i -> opar n . showString "VVar" . showChar ' ' . showsPrec 1 i . cpar n
+    VWild -> showString "VWild"
+    FieldType i exp -> opar n . showString "FieldType" . showChar ' ' . showsPrec 1 i . showChar ' ' . showsPrec 1 exp . cpar n
+    FieldValue i exp -> opar n . showString "FieldValue" . showChar ' ' . showsPrec 1 i . showChar ' ' . showsPrec 1 exp . cpar n
+    Ident str -> opar n . showString "Ident" . 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 imports decls) (Module imports_ decls_) = imports == imports_ && decls == decls_
+johnMajorEq (Import i) (Import i_) = i == i_
+johnMajorEq (DataDecl i exp consdecls) (DataDecl i_ exp_ consdecls_) = i == i_ && exp == exp_ && consdecls == consdecls_
+johnMajorEq (TypeDecl i exp) (TypeDecl i_ exp_) = i == i_ && exp == exp_
+johnMajorEq (ValueDecl i patterns exp) (ValueDecl i_ patterns_ exp_) = i == i_ && patterns == patterns_ && exp == exp_
+johnMajorEq (DeriveDecl i0 i1) (DeriveDecl i0_ i1_) = i0 == i0_ && i1 == i1_
+johnMajorEq (ConsDecl i exp) (ConsDecl i_ exp_) = i == i_ && exp == exp_
+johnMajorEq (PConsTop i pattern patterns) (PConsTop i_ pattern_ patterns_) = i == i_ && pattern == pattern_ && patterns == patterns_
+johnMajorEq (PCons i patterns) (PCons i_ patterns_) = i == i_ && patterns == patterns_
+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 (PVar i) (PVar i_) = i == i_
+johnMajorEq PWild PWild = True
+johnMajorEq (FieldPattern i pattern) (FieldPattern i_ pattern_) = i == i_ && pattern == pattern_
+johnMajorEq (ELet letdefs exp) (ELet letdefs_ exp_) = letdefs == letdefs_ && exp == exp_
+johnMajorEq (ECase exp cases) (ECase exp_ cases_) = exp == exp_ && cases == cases_
+johnMajorEq (EIf exp0 exp1 exp2) (EIf exp0_ exp1_ exp2_) = exp0 == exp0_ && exp1 == exp1_ && exp2 == exp2_
+johnMajorEq (EAbs varorwild exp) (EAbs varorwild_ exp_) = varorwild == varorwild_ && exp == exp_
+johnMajorEq (EPi varorwild exp0 exp1) (EPi varorwild_ exp0_ exp1_) = varorwild == varorwild_ && exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (EPiNoVar exp0 exp1) (EPiNoVar exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (EOr exp0 exp1) (EOr exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (EAnd exp0 exp1) (EAnd exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (EEq exp0 exp1) (EEq exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (ENe exp0 exp1) (ENe exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (ELt exp0 exp1) (ELt exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (ELe exp0 exp1) (ELe exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (EGt exp0 exp1) (EGt exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (EGe exp0 exp1) (EGe exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (EAdd exp0 exp1) (EAdd exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (ESub exp0 exp1) (ESub exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (EMul exp0 exp1) (EMul exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (EDiv exp0 exp1) (EDiv exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (EMod exp0 exp1) (EMod exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (EProj exp i) (EProj exp_ i_) = exp == exp_ && i == i_
+johnMajorEq (ENeg exp) (ENeg exp_) = exp == exp_
+johnMajorEq (EApp exp0 exp1) (EApp exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
+johnMajorEq EEmptyRec EEmptyRec = True
+johnMajorEq (ERecType fieldtypes) (ERecType fieldtypes_) = fieldtypes == fieldtypes_
+johnMajorEq (ERec fieldvalues) (ERec fieldvalues_) = fieldvalues == fieldvalues_
+johnMajorEq (EVar i) (EVar i_) = i == i_
+johnMajorEq EType EType = True
+johnMajorEq (EStr str) (EStr str_) = str == str_
+johnMajorEq (EInt n) (EInt n_) = n == n_
+johnMajorEq (LetDef i exp0 exp1) (LetDef i_ exp0_ exp1_) = i == i_ && exp0 == exp0_ && exp1 == exp1_
+johnMajorEq (Case pattern exp) (Case pattern_ exp_) = pattern == pattern_ && exp == exp_
+johnMajorEq (VVar i) (VVar i_) = i == i_
+johnMajorEq VWild VWild = True
+johnMajorEq (FieldType i exp) (FieldType i_ exp_) = i == i_ && exp == exp_
+johnMajorEq (FieldValue i exp) (FieldValue i_ exp_) = i == i_ && exp == exp_
+johnMajorEq (Ident str) (Ident 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 (Import _) = 1
+    index (DataDecl _ _ _) = 2
+    index (TypeDecl _ _) = 3
+    index (ValueDecl _ _ _) = 4
+    index (DeriveDecl _ _) = 5
+    index (ConsDecl _ _) = 6
+    index (PConsTop _ _ _) = 7
+    index (PCons _ _) = 8
+    index (PRec _) = 9
+    index (PType ) = 10
+    index (PStr _) = 11
+    index (PInt _) = 12
+    index (PVar _) = 13
+    index (PWild ) = 14
+    index (FieldPattern _ _) = 15
+    index (ELet _ _) = 16
+    index (ECase _ _) = 17
+    index (EIf _ _ _) = 18
+    index (EAbs _ _) = 19
+    index (EPi _ _ _) = 20
+    index (EPiNoVar _ _) = 21
+    index (EOr _ _) = 22
+    index (EAnd _ _) = 23
+    index (EEq _ _) = 24
+    index (ENe _ _) = 25
+    index (ELt _ _) = 26
+    index (ELe _ _) = 27
+    index (EGt _ _) = 28
+    index (EGe _ _) = 29
+    index (EAdd _ _) = 30
+    index (ESub _ _) = 31
+    index (EMul _ _) = 32
+    index (EDiv _ _) = 33
+    index (EMod _ _) = 34
+    index (EProj _ _) = 35
+    index (ENeg _) = 36
+    index (EApp _ _) = 37
+    index (EEmptyRec ) = 38
+    index (ERecType _) = 39
+    index (ERec _) = 40
+    index (EVar _) = 41
+    index (EType ) = 42
+    index (EStr _) = 43
+    index (EInt _) = 44
+    index (LetDef _ _ _) = 45
+    index (Case _ _) = 46
+    index (VVar _) = 47
+    index (VWild ) = 48
+    index (FieldType _ _) = 49
+    index (FieldValue _ _) = 50
+    index (Ident _) = 51
+    compareSame (Module imports decls) (Module imports_ decls_) = mappend (compare imports imports_) (compare decls decls_)
+    compareSame (Import i) (Import i_) = compare i i_
+    compareSame (DataDecl i exp consdecls) (DataDecl i_ exp_ consdecls_) = mappend (compare i i_) (mappend (compare exp exp_) (compare consdecls consdecls_))
+    compareSame (TypeDecl i exp) (TypeDecl i_ exp_) = mappend (compare i i_) (compare exp exp_)
+    compareSame (ValueDecl i patterns exp) (ValueDecl i_ patterns_ exp_) = mappend (compare i i_) (mappend (compare patterns patterns_) (compare exp exp_))
+    compareSame (DeriveDecl i0 i1) (DeriveDecl i0_ i1_) = mappend (compare i0 i0_) (compare i1 i1_)
+    compareSame (ConsDecl i exp) (ConsDecl i_ exp_) = mappend (compare i i_) (compare exp exp_)
+    compareSame (PConsTop i pattern patterns) (PConsTop i_ pattern_ patterns_) = mappend (compare i i_) (mappend (compare pattern pattern_) (compare patterns patterns_))
+    compareSame (PCons i patterns) (PCons i_ patterns_) = mappend (compare i i_) (compare patterns patterns_)
+    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 (PVar i) (PVar i_) = compare i i_
+    compareSame PWild PWild = EQ
+    compareSame (FieldPattern i pattern) (FieldPattern i_ pattern_) = mappend (compare i i_) (compare pattern pattern_)
+    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 (EIf exp0 exp1 exp2) (EIf exp0_ exp1_ exp2_) = mappend (compare exp0 exp0_) (mappend (compare exp1 exp1_) (compare exp2 exp2_))
+    compareSame (EAbs varorwild exp) (EAbs varorwild_ exp_) = mappend (compare varorwild varorwild_) (compare exp exp_)
+    compareSame (EPi varorwild exp0 exp1) (EPi varorwild_ exp0_ exp1_) = mappend (compare varorwild varorwild_) (mappend (compare exp0 exp0_) (compare exp1 exp1_))
+    compareSame (EPiNoVar exp0 exp1) (EPiNoVar exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (EOr exp0 exp1) (EOr exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (EAnd exp0 exp1) (EAnd exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (EEq exp0 exp1) (EEq exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (ENe exp0 exp1) (ENe exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (ELt exp0 exp1) (ELt exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (ELe exp0 exp1) (ELe exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (EGt exp0 exp1) (EGt exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (EGe exp0 exp1) (EGe exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (EAdd exp0 exp1) (EAdd exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (ESub exp0 exp1) (ESub exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (EMul exp0 exp1) (EMul exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (EDiv exp0 exp1) (EDiv exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (EMod exp0 exp1) (EMod exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame (EProj exp i) (EProj exp_ i_) = mappend (compare exp exp_) (compare i i_)
+    compareSame (ENeg exp) (ENeg exp_) = compare exp exp_
+    compareSame (EApp exp0 exp1) (EApp exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
+    compareSame EEmptyRec EEmptyRec = EQ
+    compareSame (ERecType fieldtypes) (ERecType fieldtypes_) = compare fieldtypes fieldtypes_
+    compareSame (ERec fieldvalues) (ERec fieldvalues_) = compare fieldvalues fieldvalues_
+    compareSame (EVar i) (EVar i_) = compare i i_
+    compareSame EType EType = EQ
+    compareSame (EStr str) (EStr str_) = compare str str_
+    compareSame (EInt n) (EInt n_) = compare n n_
+    compareSame (LetDef i exp0 exp1) (LetDef i_ exp0_ exp1_) = mappend (compare i i_) (mappend (compare exp0 exp0_) (compare exp1 exp1_))
+    compareSame (Case pattern exp) (Case pattern_ exp_) = mappend (compare pattern pattern_) (compare exp exp_)
+    compareSame (VVar i) (VVar i_) = compare i i_
+    compareSame VWild VWild = EQ
+    compareSame (FieldType i exp) (FieldType i_ exp_) = mappend (compare i i_) (compare exp exp_)
+    compareSame (FieldValue i exp) (FieldValue i_ exp_) = mappend (compare i i_) (compare exp exp_)
+    compareSame (Ident str) (Ident str_) = compare str str_
+    compareSame x y = error "BNFC error:" compareSame

src/Transfer/Syntax/Doc.tex

@@ -0,0 +1,266 @@
+\batchmode
+%This Latex file is machine-generated by the BNF-converter
+
+\documentclass[a4paper,11pt]{article}
+\author{BNF-converter}
+\title{The Language Syntax}
+\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 Syntax}
+\subsection*{Identifiers}
+Identifiers \nonterminal{Ident} are unquoted strings beginning with a letter,
+followed by any combination of letters, digits, and the characters {\tt \_ '},
+reserved words excluded.
+
+
+\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.
+
+
+
+
+\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 Syntax are the following: \\
+
+\begin{tabular}{lll}
+{\reserved{Type}} &{\reserved{case}} &{\reserved{data}} \\
+{\reserved{derive}} &{\reserved{else}} &{\reserved{if}} \\
+{\reserved{import}} &{\reserved{in}} &{\reserved{let}} \\
+{\reserved{of}} &{\reserved{then}} &{\reserved{where}} \\
+\end{tabular}\\
+
+The symbols used in Syntax are the following: \\
+
+\begin{tabular}{lll}
+{\symb{;}} &{\symb{:}} &{\symb{\{}} \\
+{\symb{\}}} &{\symb{{$=$}}} &{\symb{(}} \\
+{\symb{)}} &{\symb{\_}} &{\symb{{$-$}{$>$}}} \\
+{\symb{$\backslash$}} &{\symb{{$|$}{$|$}}} &{\symb{\&\&}} \\
+{\symb{{$=$}{$=$}}} &{\symb{/{$=$}}} &{\symb{{$<$}}} \\
+{\symb{{$<$}{$=$}}} &{\symb{{$>$}}} &{\symb{{$>$}{$=$}}} \\
+{\symb{{$+$}}} &{\symb{{$-$}}} &{\symb{*}} \\
+{\symb{/}} &{\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 Syntax}
+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{ListImport}} {\nonterminal{ListDecl}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Import}} & {\arrow}  &{\terminal{import}} {\nonterminal{Ident}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{ListImport}} & {\arrow}  &{\emptyP} \\
+ & {\delimit}  &{\nonterminal{Import}}  \\
+ & {\delimit}  &{\nonterminal{Import}} {\terminal{;}} {\nonterminal{ListImport}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Decl}} & {\arrow}  &{\terminal{data}} {\nonterminal{Ident}} {\terminal{:}} {\nonterminal{Exp}} {\terminal{where}} {\terminal{\{}} {\nonterminal{ListConsDecl}} {\terminal{\}}}  \\
+ & {\delimit}  &{\nonterminal{Ident}} {\terminal{:}} {\nonterminal{Exp}}  \\
+ & {\delimit}  &{\nonterminal{Ident}} {\nonterminal{ListPattern}} {\terminal{{$=$}}} {\nonterminal{Exp}}  \\
+ & {\delimit}  &{\terminal{derive}} {\nonterminal{Ident}} {\nonterminal{Ident}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{ListDecl}} & {\arrow}  &{\emptyP} \\
+ & {\delimit}  &{\nonterminal{Decl}}  \\
+ & {\delimit}  &{\nonterminal{Decl}} {\terminal{;}} {\nonterminal{ListDecl}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{ConsDecl}} & {\arrow}  &{\nonterminal{Ident}} {\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{Pattern}} & {\arrow}  &{\nonterminal{Ident}} {\nonterminal{Pattern1}} {\nonterminal{ListPattern}}  \\
+ & {\delimit}  &{\nonterminal{Pattern1}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Pattern1}} & {\arrow}  &{\terminal{(}} {\nonterminal{Ident}} {\nonterminal{ListPattern}} {\terminal{)}}  \\
+ & {\delimit}  &{\terminal{\{}} {\nonterminal{ListFieldPattern}} {\terminal{\}}}  \\
+ & {\delimit}  &{\terminal{Type}}  \\
+ & {\delimit}  &{\nonterminal{String}}  \\
+ & {\delimit}  &{\nonterminal{Integer}}  \\
+ & {\delimit}  &{\nonterminal{Ident}}  \\
+ & {\delimit}  &{\terminal{\_}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{ListPattern}} & {\arrow}  &{\emptyP} \\
+ & {\delimit}  &{\nonterminal{Pattern1}} {\nonterminal{ListPattern}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{FieldPattern}} & {\arrow}  &{\nonterminal{Ident}} {\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{Exp}} & {\arrow}  &{\terminal{let}} {\terminal{\{}} {\nonterminal{ListLetDef}} {\terminal{\}}} {\terminal{in}} {\nonterminal{Exp}}  \\
+ & {\delimit}  &{\terminal{case}} {\nonterminal{Exp}} {\terminal{of}} {\terminal{\{}} {\nonterminal{ListCase}} {\terminal{\}}}  \\
+ & {\delimit}  &{\terminal{if}} {\nonterminal{Exp}} {\terminal{then}} {\nonterminal{Exp}} {\terminal{else}} {\nonterminal{Exp}}  \\
+ & {\delimit}  &{\nonterminal{Exp1}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{LetDef}} & {\arrow}  &{\nonterminal{Ident}} {\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{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{Exp2}} & {\arrow}  &{\terminal{$\backslash$}} {\nonterminal{VarOrWild}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}}  \\
+ & {\delimit}  &{\terminal{(}} {\nonterminal{VarOrWild}} {\terminal{:}} {\nonterminal{Exp}} {\terminal{)}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}}  \\
+ & {\delimit}  &{\nonterminal{Exp3}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}}  \\
+ & {\delimit}  &{\nonterminal{Exp3}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{VarOrWild}} & {\arrow}  &{\nonterminal{Ident}}  \\
+ & {\delimit}  &{\terminal{\_}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Exp3}} & {\arrow}  &{\nonterminal{Exp4}} {\terminal{{$|$}{$|$}}} {\nonterminal{Exp3}}  \\
+ & {\delimit}  &{\nonterminal{Exp4}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Exp4}} & {\arrow}  &{\nonterminal{Exp5}} {\terminal{\&\&}} {\nonterminal{Exp4}}  \\
+ & {\delimit}  &{\nonterminal{Exp5}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Exp5}} & {\arrow}  &{\nonterminal{Exp6}} {\terminal{{$=$}{$=$}}} {\nonterminal{Exp6}}  \\
+ & {\delimit}  &{\nonterminal{Exp6}} {\terminal{/{$=$}}} {\nonterminal{Exp6}}  \\
+ & {\delimit}  &{\nonterminal{Exp6}} {\terminal{{$<$}}} {\nonterminal{Exp6}}  \\
+ & {\delimit}  &{\nonterminal{Exp6}} {\terminal{{$<$}{$=$}}} {\nonterminal{Exp6}}  \\
+ & {\delimit}  &{\nonterminal{Exp6}} {\terminal{{$>$}}} {\nonterminal{Exp6}}  \\
+ & {\delimit}  &{\nonterminal{Exp6}} {\terminal{{$>$}{$=$}}} {\nonterminal{Exp6}}  \\
+ & {\delimit}  &{\nonterminal{Exp6}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Exp6}} & {\arrow}  &{\nonterminal{Exp6}} {\terminal{{$+$}}} {\nonterminal{Exp7}}  \\
+ & {\delimit}  &{\nonterminal{Exp6}} {\terminal{{$-$}}} {\nonterminal{Exp7}}  \\
+ & {\delimit}  &{\nonterminal{Exp7}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Exp7}} & {\arrow}  &{\nonterminal{Exp7}} {\terminal{*}} {\nonterminal{Exp8}}  \\
+ & {\delimit}  &{\nonterminal{Exp7}} {\terminal{/}} {\nonterminal{Exp8}}  \\
+ & {\delimit}  &{\nonterminal{Exp7}} {\terminal{\%}} {\nonterminal{Exp8}}  \\
+ & {\delimit}  &{\nonterminal{Exp8}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Exp8}} & {\arrow}  &{\nonterminal{Exp8}} {\terminal{.}} {\nonterminal{Ident}}  \\
+ & {\delimit}  &{\nonterminal{Exp9}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Exp9}} & {\arrow}  &{\terminal{{$-$}}} {\nonterminal{Exp9}}  \\
+ & {\delimit}  &{\nonterminal{Exp10}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Exp10}} & {\arrow}  &{\nonterminal{Exp10}} {\nonterminal{Exp11}}  \\
+ & {\delimit}  &{\nonterminal{Exp11}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Exp11}} & {\arrow}  &{\terminal{\{}} {\terminal{\}}}  \\
+ & {\delimit}  &{\terminal{\{}} {\nonterminal{ListFieldType}} {\terminal{\}}}  \\
+ & {\delimit}  &{\terminal{\{}} {\nonterminal{ListFieldValue}} {\terminal{\}}}  \\
+ & {\delimit}  &{\nonterminal{Ident}}  \\
+ & {\delimit}  &{\terminal{Type}}  \\
+ & {\delimit}  &{\nonterminal{String}}  \\
+ & {\delimit}  &{\nonterminal{Integer}}  \\
+ & {\delimit}  &{\terminal{(}} {\nonterminal{Exp}} {\terminal{)}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{FieldType}} & {\arrow}  &{\nonterminal{Ident}} {\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{Ident}} {\terminal{{$=$}}} {\nonterminal{Exp}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{ListFieldValue}} & {\arrow}  &{\nonterminal{FieldValue}}  \\
+ & {\delimit}  &{\nonterminal{FieldValue}} {\terminal{;}} {\nonterminal{ListFieldValue}}  \\
+\end{tabular}\\
+
+\begin{tabular}{lll}
+{\nonterminal{Exp1}} & {\arrow}  &{\nonterminal{Exp2}}  \\
+\end{tabular}\\
+
+
+
+\end{document}
+

src/Transfer/Syntax/Layout.hs

@@ -0,0 +1,205 @@
+module Transfer.Syntax.Layout where
+
+import Transfer.Syntax.Lex
+
+
+import Data.Maybe (isNothing, fromJust)
+
+-- Generated by the BNF Converter
+
+-- local parameters
+
+topLayout = True
+layoutWords = ["let","where","of"]
+layoutStopWords = ["in"]
+
+-- layout separators
+
+layoutOpen  = "{"
+layoutClose = "}"
+layoutSep   = ";"
+
+-- | Replace layout syntax with explicit layout tokens.
+resolveLayout :: Bool    -- ^ Whether to use top-level layout.
+              -> [Token] -> [Token]
+resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]
+  where
+  -- Do top-level layout if the function parameter and the grammar say so.
+  tl = tp && topLayout
+
+  res :: Maybe Token -- ^ The previous token, if any.
+      -> [Block] -- ^ A stack of layout blocks.
+      -> [Token] -> [Token]
+
+  -- The stack should never be empty.
+  res _ [] ts = error $ "Layout error: stack empty. Tokens: " ++ show ts
+
+  res _ st (t0:ts)
+    -- We found an open brace in the input,
+    -- put an explicit layout block on the stack.
+    -- This is done even if there was no layout word,
+    -- to keep of opening and closing braces.
+    | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts
+
+  res _ st (t0:ts)
+    -- Start a new layout block if the first token is a layout word
+    | isLayout t0 =
+        case ts of
+            -- Explicit layout, just move on. The case above
+            -- will push an explicit layout block.
+            t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts
+                     -- at end of file, the start column doesn't matter
+            _ -> let col = if null ts then column t0 else column (head ts)
+                     -- insert an open brace after the layout word
+                     b:ts' = addToken (nextPos t0) layoutOpen ts
+                     -- save the start column
+                     st' = Implicit col:st 
+                  in moveAlong st' [t0,b] ts'
+
+    -- If we encounter a closing brace, exit the first explicit layout block.
+    | isLayoutClose t0 = 
+          let st' = drop 1 (dropWhile isImplicit st)
+           in if null st' 
+                 then error $ "Layout error: Found " ++ layoutClose ++ " at (" 
+                              ++ show (line t0) ++ "," ++ show (column t0) 
+                              ++ ") without an explicit layout block."
+                 else moveAlong st' [t0] ts
+
+  -- We are in an implicit layout block
+  res pt st@(Implicit n:ns) (t0:ts)
+    -- End of an implicit layout block
+    | isStop t0 || column t0 < n  = 
+           -- Insert a closing brace before the current token.
+       let b:t0':ts' = addToken (position t0) layoutClose (t0:ts)
+           -- Exit the current block and all implicit blocks 
+           -- such that the current token is less indented than them.
+           st' = dropWhile (isLessIndentedThan t0) ns
+        in moveAlong st' [b,t0'] ts'
+
+    -- Encounted a new line in an implicit layout block.
+    | column t0 == n = 
+       -- Insert a semicolon before the start of the next line, 
+       -- unless we are the beginning of the file,
+       -- or the previous token is a semicolon or open brace.
+       if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt) 
+          then moveAlong st [t0] ts
+          else let b:t0':ts' = addToken (position t0) layoutSep (t0:ts)
+                in moveAlong st [b,t0'] ts'
+
+  -- Nothing to see here, move along.
+  res _ st (t:ts)  = moveAlong st [t] ts
+
+  -- We are at EOF, close all open implicit non-top-level layout blocks.
+  res (Just t) st [] = 
+        addTokens (position t) [layoutClose | Implicit n <- st, 
+                                              not (tl && n == 1)] []
+
+  -- This should only happen if the input is empty.
+  res Nothing st [] = []
+
+  -- | Move on to the next token.
+  moveAlong :: [Block] -- ^ The layout stack.
+            -> [Token] -- ^ Any tokens just processed.
+            -> [Token] -- ^ the rest of the tokens.
+            -> [Token]
+  moveAlong st [] ts = error $ "Layout error: moveAlong got [] as old tokens"
+  moveAlong st ot ts = ot ++ res (Just $ last ot) st ts
+
+
+ 
+data Block = Implicit Int -- ^ An implicit layout block with its start column.
+           | Explicit 
+             deriving Show
+
+type Position = Posn
+
+-- | Check if s block is implicit.
+isImplicit :: Block -> Bool
+isImplicit (Implicit _) = True
+isImplicit _ = False
+
+-- | Checks if the given token is less indented than the given
+--   block. For explicit blocks, False is always returned.
+isLessIndentedThan :: Token -> Block -> Bool
+isLessIndentedThan t (Implicit n) = column t < n
+isLessIndentedThan _ Explicit = False
+
+
+-- | Insert a number of tokens at the begninning of a list of tokens.
+addTokens :: Position -- ^ Position of the first new token.
+          -> [String] -- ^ Token symbols.
+          -> [Token]  -- ^ The rest of the tokens. These will have their
+                      --   positions updated to make room for the new tokens .
+          -> [Token]                       
+addTokens p ss ts = foldr (addToken p) ts ss
+
+-- | Insert a new symbol token at the begninning of a list of tokens.
+addToken :: Position -- ^ Position of the new token.
+         -> String   -- ^ Symbol in the new token.
+         -> [Token]  -- ^ The rest of the tokens. These will have their
+                     --   positions updated to make room for the new token.
+         -> [Token]
+addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts
+
+-- | Get the position immediately to the right of the given token.
+nextPos :: Token -> Position 
+nextPos t = Pn (g + s) l (c + s + 1) 
+  where Pn g l c = position t
+        s = tokenLength t
+
+-- | Add to the global and column positions of a token.
+--   The column position is only changed if the token is on
+--   the same line as the given position.
+incrGlobal :: Position -- ^ If the token is on the same line
+                       --   as this position, update the column position.
+           -> Int      -- ^ Number of characters to add to the position.
+           -> Token -> Token
+incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) =
+  if l /= l0 then PT (Pn (g + i) l c) t
+             else PT (Pn (g + i) l (c + i)) t
+incrGlobal _ _ p = error $ "cannot add token at " ++ show p
+
+-- | Create a symbol token.
+sToken :: Position -> String -> Token
+sToken p s = PT p (TS s) -- reserved word or symbol
+
+-- | Get the position of a token.
+position :: Token -> Position
+position t = case t of
+  PT p _ -> p
+  Err p -> p
+
+-- | Get the line number of a token.
+line :: Token -> Int
+line t = case position t of Pn _ l _ -> l
+
+-- | Get the column number of a token.
+column :: Token -> Int
+column t = case position t of Pn _ _ c -> c
+
+-- | Check if a token is one of the given symbols.
+isTokenIn :: [String] -> Token -> Bool
+isTokenIn ts t = case t of
+  PT _ (TS r) | elem r ts -> True
+  _ -> False
+
+-- | Check if a word is a layout start token.
+isLayout :: Token -> Bool
+isLayout = isTokenIn layoutWords
+
+-- | Check if a token is a layout stop token.
+isStop :: Token -> Bool
+isStop = isTokenIn layoutStopWords
+
+-- | Check if a token is the layout open token.
+isLayoutOpen :: Token -> Bool
+isLayoutOpen = isTokenIn [layoutOpen]
+
+-- | Check if a token is the layout close token.
+isLayoutClose :: Token -> Bool
+isLayoutClose = isTokenIn [layoutClose]
+
+-- | Get the number of characters in the token.
+tokenLength :: Token -> Int
+tokenLength t = length $ prToken t
+

src/Transfer/Syntax/Lex.hs

@@ -0,0 +1,345 @@
+{-# OPTIONS -fglasgow-exts -cpp #-}
+{-# LINE 3 "Transfer/Syntax/Lex.x" #-}
+module Transfer.Syntax.Lex where
+
+import Transfer.ErrM
+
+
+#if __GLASGOW_HASKELL__ >= 603
+#include "ghcconfig.h"
+#else
+#include "config.h"
+#endif
+#if __GLASGOW_HASKELL__ >= 503
+import Data.Array
+import Data.Char (ord)
+import Data.Array.Base (unsafeAt)
+#else
+import Array
+import Char (ord)
+#endif
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.Exts
+#else
+import GlaExts
+#endif
+alex_base :: AlexAddr
+alex_base = AlexA# "\x01\x00\x00\x00\x15\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x18\x00\x00\x00\x19\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x45\x00\x00\x00\x1b\x00\x00\x00\x1c\x00\x00\x00\x1d\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x14\x00\x00\x00\x16\x00\x00\x00\x17\x00\x00\x00\xd6\xff\xff\xff\x2f\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x17\x01\x00\x00\xd5\x00\x00\x00\x33\x00\x00\x00"#
+
+alex_table :: AlexAddr
+alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\xff\xff\x17\x00\xff\xff\xff\xff\x0e\x00\x14\x00\xff\xff\x0e\x00\x0e\x00\x0e\x00\x0e\x00\xff\xff\x05\x00\x0e\x00\x10\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x0e\x00\x0e\x00\x11\x00\x0f\x00\x12\x00\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\x03\x00\x03\x00\x09\x00\x09\x00\x09\x00\x0b\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x0e\x00\xff\xff\xff\xff\x0e\x00\xff\xff\x0d\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x13\x00\x0e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x06\x00\x07\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x17\x00\xff\xff\x00\x00\x00\x00\x15\x00\x17\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x18\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
+
+alex_check :: AlexAddr
+alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2d\x00\x0a\x00\x0a\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3d\x00\x3d\x00\x7c\x00\x3d\x00\x3d\x00\x26\x00\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x7d\x00\x7d\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xf7\x00\xff\xff\xff\xff\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
+
+alex_deflt :: AlexAddr
+alex_deflt = AlexA# "\x15\x00\xff\xff\x02\x00\x02\x00\xff\xff\xff\xff\x0a\x00\xff\xff\x0a\x00\x0a\x00\x0a\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\xff\xff\xff\xff"#
+
+alex_accept = listArray (0::Int,25) [[],[],[(AlexAccSkip)],[(AlexAccSkip)],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[],[],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[],[],[(AlexAcc (alex_action_6))]]
+{-# LINE 34 "Transfer/Syntax/Lex.x" #-}
+
+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
+
+ 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
+
+  _ -> 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 "import" (b "derive" (b "case" (b "Type" N N) (b "data" N N)) (b "if" (b "else" N N) N)) (b "of" (b "let" (b "in" N N) N) (b "where" (b "then" N 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
+
+alex_action_3 = tok (\p s -> PT p (TS $ share s)) 
+alex_action_4 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) 
+alex_action_5 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) 
+alex_action_6 = tok (\p s -> PT p (TI $ share s))    
+{-# LINE 1 "GenericTemplate.hs" #-}
+{-# LINE 1 "<built-in>" #-}
+{-# LINE 1 "<command line>" #-}
+{-# LINE 1 "GenericTemplate.hs" #-}
+-- -----------------------------------------------------------------------------
+-- ALEX TEMPLATE
+--
+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use
+-- it for any purpose whatsoever.
+
+-- -----------------------------------------------------------------------------
+-- INTERNALS and main scanner engine
+
+
+{-# LINE 35 "GenericTemplate.hs" #-}
+
+
+
+
+
+
+
+
+
+
+
+
+data AlexAddr = AlexA# Addr#
+
+#if __GLASGOW_HASKELL__ < 503
+uncheckedShiftL# = shiftL#
+#endif
+
+{-# INLINE alexIndexInt16OffAddr #-}
+alexIndexInt16OffAddr (AlexA# arr) off =
+#ifdef WORDS_BIGENDIAN
+  narrow16Int# i
+  where
+	i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
+	high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
+	low  = int2Word# (ord# (indexCharOffAddr# arr off'))
+	off' = off *# 2#
+#else
+  indexInt16OffAddr# arr off
+#endif
+
+
+
+
+
+{-# INLINE alexIndexInt32OffAddr #-}
+alexIndexInt32OffAddr (AlexA# arr) off = 
+#ifdef WORDS_BIGENDIAN
+  narrow32Int# i
+  where
+   i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`
+		     (b2 `uncheckedShiftL#` 16#) `or#`
+		     (b1 `uncheckedShiftL#` 8#) `or#` b0)
+   b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))
+   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))
+   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
+   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))
+   off' = off *# 4#
+#else
+  indexInt32OffAddr# arr off
+#endif
+
+
+
+
+
+#if __GLASGOW_HASKELL__ < 503
+quickIndex arr i = arr ! i
+#else
+-- GHC >= 503, unsafeAt is available from Data.Array.Base.
+quickIndex = unsafeAt
+#endif
+
+
+
+
+-- -----------------------------------------------------------------------------
+-- Main lexing routines
+
+data AlexReturn a
+  = AlexEOF
+  | AlexError  !AlexInput
+  | AlexSkip   !AlexInput !Int
+  | AlexToken  !AlexInput !Int a
+
+-- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act)
+alexScan input (I# (sc))
+  = alexScanUser undefined input (I# (sc))
+
+alexScanUser user input (I# (sc))
+  = case alex_scan_tkn user input 0# input sc AlexNone of
+	(AlexNone, input') ->
+		case alexGetChar input of
+			Nothing -> 
+
+
+
+				   AlexEOF
+			Just _ ->
+
+
+
+				   AlexError input'
+
+	(AlexLastSkip input len, _) ->
+
+
+
+		AlexSkip input len
+
+	(AlexLastAcc k input len, _) ->
+
+
+
+		AlexToken input len k
+
+
+-- Push the input through the DFA, remembering the most recent accepting
+-- state it encountered.
+
+alex_scan_tkn user orig_input len input s last_acc =
+  input `seq` -- strict in the input
+  case s of 
+    -1# -> (last_acc, input)
+    _ -> alex_scan_tkn' user orig_input len input s last_acc
+
+alex_scan_tkn' user orig_input len input s last_acc =
+  let 
+	new_acc = check_accs (alex_accept `quickIndex` (I# (s)))
+  in
+  new_acc `seq`
+  case alexGetChar input of
+     Nothing -> (new_acc, input)
+     Just (c, new_input) -> 
+
+
+
+	let
+		base   = alexIndexInt32OffAddr alex_base s
+		(I# (ord_c)) = ord c
+		offset = (base +# ord_c)
+		check  = alexIndexInt16OffAddr alex_check offset
+		
+		new_s = if (offset >=# 0#) && (check ==# ord_c)
+			  then alexIndexInt16OffAddr alex_table offset
+			  else alexIndexInt16OffAddr alex_deflt s
+	in
+	alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc
+
+  where
+	check_accs [] = last_acc
+	check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))
+	check_accs (AlexAccSkip : _)  = AlexLastSkip  input (I# (len))
+	check_accs (AlexAccPred a pred : rest)
+	   | pred user orig_input (I# (len)) input
+	   = AlexLastAcc a input (I# (len))
+	check_accs (AlexAccSkipPred pred : rest)
+	   | pred user orig_input (I# (len)) input
+	   = AlexLastSkip input (I# (len))
+	check_accs (_ : rest) = check_accs rest
+
+data AlexLastAcc a
+  = AlexNone
+  | AlexLastAcc a !AlexInput !Int
+  | AlexLastSkip  !AlexInput !Int
+
+data AlexAcc a user
+  = AlexAcc a
+  | AlexAccSkip
+  | AlexAccPred a (AlexAccPred user)
+  | AlexAccSkipPred (AlexAccPred user)
+
+type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool
+
+-- -----------------------------------------------------------------------------
+-- Predicates on a rule
+
+alexAndPred p1 p2 user in1 len in2
+  = p1 user in1 len in2 && p2 user in1 len in2
+
+--alexPrevCharIsPred :: Char -> AlexAccPred _ 
+alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input
+
+--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ 
+alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input
+
+--alexRightContext :: Int -> AlexAccPred _
+alexRightContext (I# (sc)) user _ _ input = 
+     case alex_scan_tkn user input 0# input sc AlexNone of
+	  (AlexNone, _) -> False
+	  _ -> True
+	-- TODO: there's no need to find the longest
+	-- match when checking the right context, just
+	-- the first match will do.
+
+-- used by wrappers
+iUnbox (I# (i)) = i

src/Transfer/Syntax/Lex.x

@@ -0,0 +1,134 @@
+-- -*- haskell -*-
+-- This Alex file was machine-generated by the BNF converter
+{
+module Transfer.Syntax.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 $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
+
+ 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
+
+  _ -> 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 "import" (b "derive" (b "case" (b "Type" N N) (b "data" N N)) (b "if" (b "else" N N) N)) (b "of" (b "let" (b "in" N N) N) (b "where" (b "then" N 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
+}

src/Transfer/Syntax/Par.y

@@ -0,0 +1,268 @@
+-- This Happy file was machine-generated by the BNF converter
+{
+module Transfer.Syntax.Par where
+import Transfer.Syntax.Abs
+import Transfer.Syntax.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 "&&") }
+ '==' { 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") }
+ 'derive' { PT _ (TS "derive") }
+ 'else' { PT _ (TS "else") }
+ 'if' { PT _ (TS "if") }
+ 'import' { PT _ (TS "import") }
+ 'in' { PT _ (TS "in") }
+ 'let' { PT _ (TS "let") }
+ 'of' { PT _ (TS "of") }
+ 'then' { PT _ (TS "then") }
+ 'where' { PT _ (TS "where") }
+
+L_ident  { PT _ (TV $$) }
+L_quoted { PT _ (TL $$) }
+L_integ  { PT _ (TI $$) }
+L_err    { _ }
+
+
+%%
+
+Ident   :: { Ident }   : L_ident  { Ident $1 }
+String  :: { String }  : L_quoted { $1 }
+Integer :: { Integer } : L_integ  { (read $1) :: Integer }
+
+Module :: { Module }
+Module : ListImport ListDecl { Module $1 $2 } 
+
+
+Import :: { Import }
+Import : 'import' Ident { Import $2 } 
+
+
+ListImport :: { [Import] }
+ListImport : {- empty -} { [] } 
+  | Import { (:[]) $1 }
+  | Import ';' ListImport { (:) $1 $3 }
+
+
+Decl :: { Decl }
+Decl : 'data' Ident ':' Exp 'where' '{' ListConsDecl '}' { DataDecl $2 $4 $7 } 
+  | Ident ':' Exp { TypeDecl $1 $3 }
+  | Ident ListPattern '=' Exp { ValueDecl $1 (reverse $2) $4 }
+  | 'derive' Ident Ident { DeriveDecl $2 $3 }
+
+
+ListDecl :: { [Decl] }
+ListDecl : {- empty -} { [] } 
+  | Decl { (:[]) $1 }
+  | Decl ';' ListDecl { (:) $1 $3 }
+
+
+ConsDecl :: { ConsDecl }
+ConsDecl : Ident ':' Exp { ConsDecl $1 $3 } 
+
+
+ListConsDecl :: { [ConsDecl] }
+ListConsDecl : {- empty -} { [] } 
+  | ConsDecl { (:[]) $1 }
+  | ConsDecl ';' ListConsDecl { (:) $1 $3 }
+
+
+Pattern :: { Pattern }
+Pattern : Ident Pattern1 ListPattern { PConsTop $1 $2 (reverse $3) } 
+  | Pattern1 { $1 }
+
+
+Pattern1 :: { Pattern }
+Pattern1 : '(' Ident ListPattern ')' { PCons $2 (reverse $3) } 
+  | '{' ListFieldPattern '}' { PRec $2 }
+  | 'Type' { PType }
+  | String { PStr $1 }
+  | Integer { PInt $1 }
+  | Ident { PVar $1 }
+  | '_' { PWild }
+
+
+ListPattern :: { [Pattern] }
+ListPattern : {- empty -} { [] } 
+  | ListPattern Pattern1 { flip (:) $1 $2 }
+
+
+FieldPattern :: { FieldPattern }
+FieldPattern : Ident '=' Pattern { FieldPattern $1 $3 } 
+
+
+ListFieldPattern :: { [FieldPattern] }
+ListFieldPattern : {- empty -} { [] } 
+  | FieldPattern { (:[]) $1 }
+  | FieldPattern ';' ListFieldPattern { (:) $1 $3 }
+
+
+Exp :: { Exp }
+Exp : 'let' '{' ListLetDef '}' 'in' Exp { ELet $3 $6 } 
+  | 'case' Exp 'of' '{' ListCase '}' { ECase $2 $5 }
+  | 'if' Exp 'then' Exp 'else' Exp { EIf $2 $4 $6 }
+  | Exp1 { $1 }
+
+
+LetDef :: { LetDef }
+LetDef : Ident ':' Exp '=' Exp { LetDef $1 $3 $5 } 
+
+
+ListLetDef :: { [LetDef] }
+ListLetDef : {- empty -} { [] } 
+  | LetDef { (:[]) $1 }
+  | LetDef ';' ListLetDef { (:) $1 $3 }
+
+
+Case :: { Case }
+Case : Pattern '->' Exp { Case $1 $3 } 
+
+
+ListCase :: { [Case] }
+ListCase : {- empty -} { [] } 
+  | Case { (:[]) $1 }
+  | Case ';' ListCase { (:) $1 $3 }
+
+
+Exp2 :: { Exp }
+Exp2 : '\\' VarOrWild '->' Exp { EAbs $2 $4 } 
+  | '(' VarOrWild ':' Exp ')' '->' Exp { EPi $2 $4 $7 }
+  | Exp3 '->' Exp { EPiNoVar $1 $3 }
+  | Exp3 { $1 }
+
+
+VarOrWild :: { VarOrWild }
+VarOrWild : Ident { VVar $1 } 
+  | '_' { VWild }
+
+
+Exp3 :: { Exp }
+Exp3 : Exp4 '||' Exp3 { EOr $1 $3 } 
+  | Exp4 { $1 }
+
+
+Exp4 :: { Exp }
+Exp4 : Exp5 '&&' Exp4 { EAnd $1 $3 } 
+  | Exp5 { $1 }
+
+
+Exp5 :: { Exp }
+Exp5 : Exp6 '==' Exp6 { EEq $1 $3 } 
+  | Exp6 '/=' Exp6 { ENe $1 $3 }
+  | Exp6 '<' Exp6 { ELt $1 $3 }
+  | Exp6 '<=' Exp6 { ELe $1 $3 }
+  | Exp6 '>' Exp6 { EGt $1 $3 }
+  | Exp6 '>=' Exp6 { EGe $1 $3 }
+  | Exp6 { $1 }
+
+
+Exp6 :: { Exp }
+Exp6 : Exp6 '+' Exp7 { EAdd $1 $3 } 
+  | Exp6 '-' Exp7 { ESub $1 $3 }
+  | Exp7 { $1 }
+
+
+Exp7 :: { Exp }
+Exp7 : Exp7 '*' Exp8 { EMul $1 $3 } 
+  | Exp7 '/' Exp8 { EDiv $1 $3 }
+  | Exp7 '%' Exp8 { EMod $1 $3 }
+  | Exp8 { $1 }
+
+
+Exp8 :: { Exp }
+Exp8 : Exp8 '.' Ident { EProj $1 $3 } 
+  | Exp9 { $1 }
+
+
+Exp9 :: { Exp }
+Exp9 : '-' Exp9 { ENeg $2 } 
+  | Exp10 { $1 }
+
+
+Exp10 :: { Exp }
+Exp10 : Exp10 Exp11 { EApp $1 $2 } 
+  | Exp11 { $1 }
+
+
+Exp11 :: { Exp }
+Exp11 : '{' '}' { EEmptyRec } 
+  | '{' ListFieldType '}' { ERecType $2 }
+  | '{' ListFieldValue '}' { ERec $2 }
+  | Ident { EVar $1 }
+  | 'Type' { EType }
+  | String { EStr $1 }
+  | Integer { EInt $1 }
+  | '(' Exp ')' { $2 }
+
+
+FieldType :: { FieldType }
+FieldType : Ident ':' Exp { FieldType $1 $3 } 
+
+
+ListFieldType :: { [FieldType] }
+ListFieldType : FieldType { (:[]) $1 } 
+  | FieldType ';' ListFieldType { (:) $1 $3 }
+
+
+FieldValue :: { FieldValue }
+FieldValue : Ident '=' Exp { FieldValue $1 $3 } 
+
+
+ListFieldValue :: { [FieldValue] }
+ListFieldValue : FieldValue { (:[]) $1 } 
+  | FieldValue ';' ListFieldValue { (:) $1 $3 }
+
+
+Exp1 :: { Exp }
+Exp1 : Exp2 { $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
+}
+

src/Transfer/Syntax/Print.hs

@@ -0,0 +1,177 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module Transfer.Syntax.Print where
+
+-- pretty-printer generated by the BNF converter
+
+import Transfer.Syntax.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 imports decls -> prPrec _i 0 (concatD [prt 0 imports , prt 0 decls])
+    Import i -> prPrec _i 0 (concatD [doc (showString "import") , prt 0 i])
+    DataDecl i exp consdecls -> prPrec _i 0 (concatD [doc (showString "data") , prt 0 i , doc (showString ":") , prt 0 exp , doc (showString "where") , doc (showString "{") , prt 0 consdecls , doc (showString "}")])
+    TypeDecl i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString ":") , prt 0 exp])
+    ValueDecl i patterns exp -> prPrec _i 0 (concatD [prt 0 i , prt 0 patterns , doc (showString "=") , prt 0 exp])
+    DeriveDecl i0 i1 -> prPrec _i 0 (concatD [doc (showString "derive") , prt 0 i0 , prt 0 i1])
+    ConsDecl i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString ":") , prt 0 exp])
+    PConsTop i pattern patterns -> prPrec _i 0 (concatD [prt 0 i , prt 1 pattern , prt 0 patterns])
+    PCons i patterns -> prPrec _i 1 (concatD [doc (showString "(") , prt 0 i , prt 0 patterns , doc (showString ")")])
+    PRec fieldpatterns -> prPrec _i 1 (concatD [doc (showString "{") , prt 0 fieldpatterns , doc (showString "}")])
+    PType  -> prPrec _i 1 (concatD [doc (showString "Type")])
+    PStr str -> prPrec _i 1 (concatD [prt 0 str])
+    PInt n -> prPrec _i 1 (concatD [prt 0 n])
+    PVar i -> prPrec _i 1 (concatD [prt 0 i])
+    PWild  -> prPrec _i 1 (concatD [doc (showString "_")])
+    FieldPattern i pattern -> prPrec _i 0 (concatD [prt 0 i , doc (showString "=") , prt 0 pattern])
+    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 "}")])
+    EIf exp0 exp1 exp2 -> prPrec _i 0 (concatD [doc (showString "if") , prt 0 exp0 , doc (showString "then") , prt 0 exp1 , doc (showString "else") , prt 0 exp2])
+    EAbs varorwild exp -> prPrec _i 2 (concatD [doc (showString "\\") , prt 0 varorwild , doc (showString "->") , prt 0 exp])
+    EPi varorwild exp0 exp1 -> prPrec _i 2 (concatD [doc (showString "(") , prt 0 varorwild , doc (showString ":") , prt 0 exp0 , doc (showString ")") , doc (showString "->") , prt 0 exp1])
+    EPiNoVar exp0 exp1 -> prPrec _i 2 (concatD [prt 3 exp0 , doc (showString "->") , prt 0 exp1])
+    EOr exp0 exp1 -> prPrec _i 3 (concatD [prt 4 exp0 , doc (showString "||") , prt 3 exp1])
+    EAnd exp0 exp1 -> prPrec _i 4 (concatD [prt 5 exp0 , doc (showString "&&") , prt 4 exp1])
+    EEq exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "==") , prt 6 exp1])
+    ENe exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "/=") , prt 6 exp1])
+    ELt exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "<") , prt 6 exp1])
+    ELe exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "<=") , prt 6 exp1])
+    EGt exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString ">") , prt 6 exp1])
+    EGe exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString ">=") , prt 6 exp1])
+    EAdd exp0 exp1 -> prPrec _i 6 (concatD [prt 6 exp0 , doc (showString "+") , prt 7 exp1])
+    ESub exp0 exp1 -> prPrec _i 6 (concatD [prt 6 exp0 , doc (showString "-") , prt 7 exp1])
+    EMul exp0 exp1 -> prPrec _i 7 (concatD [prt 7 exp0 , doc (showString "*") , prt 8 exp1])
+    EDiv exp0 exp1 -> prPrec _i 7 (concatD [prt 7 exp0 , doc (showString "/") , prt 8 exp1])
+    EMod exp0 exp1 -> prPrec _i 7 (concatD [prt 7 exp0 , doc (showString "%") , prt 8 exp1])
+    EProj exp i -> prPrec _i 8 (concatD [prt 8 exp , doc (showString ".") , prt 0 i])
+    ENeg exp -> prPrec _i 9 (concatD [doc (showString "-") , prt 9 exp])
+    EApp exp0 exp1 -> prPrec _i 10 (concatD [prt 10 exp0 , prt 11 exp1])
+    EEmptyRec  -> prPrec _i 11 (concatD [doc (showString "{") , doc (showString "}")])
+    ERecType fieldtypes -> prPrec _i 11 (concatD [doc (showString "{") , prt 0 fieldtypes , doc (showString "}")])
+    ERec fieldvalues -> prPrec _i 11 (concatD [doc (showString "{") , prt 0 fieldvalues , doc (showString "}")])
+    EVar i -> prPrec _i 11 (concatD [prt 0 i])
+    EType  -> prPrec _i 11 (concatD [doc (showString "Type")])
+    EStr str -> prPrec _i 11 (concatD [prt 0 str])
+    EInt n -> prPrec _i 11 (concatD [prt 0 n])
+    LetDef i exp0 exp1 -> prPrec _i 0 (concatD [prt 0 i , 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])
+    VVar i -> prPrec _i 0 (concatD [prt 0 i])
+    VWild  -> prPrec _i 0 (concatD [doc (showString "_")])
+    FieldType i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString ":") , prt 0 exp])
+    FieldValue i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString "=") , prt 0 exp])
+    Ident str -> prPrec _i 0 (doc (showString str))
+
+instance Print [Import] 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 [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 1 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])

src/Transfer/Syntax/ResolveLayout.hs

@@ -0,0 +1,22 @@
+module Main where
+
+import System.Environment (getArgs)
+
+import Transfer.Syntax.Lex
+import Transfer.Syntax.Layout
+
+prTokens :: [Token] -> String
+prTokens = prTokens_ 1 1
+  where 
+  prTokens_ _ _ [] = ""
+  prTokens_ l c (PT p t:ts) = 
+--  prTokens_ l c (Err p:ts) = 
+
+layout :: String -> String
+layout s = prTokens . resolveLayout True . tokens
+
+main :: IO ()
+main = do args <- getArgs
+          case args of
+            [] -> getContents >>= putStrLn . layout
+            fs -> mapM_ (\f -> readFile f >>= putStrLn . layout) fs

src/Transfer/Syntax/Skel.hs

@@ -0,0 +1,157 @@
+module Transfer.Syntax.Skel where
+
+-- Haskell module generated by the BNF converter
+
+import Transfer.Syntax.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 imports decls -> failure t
+  Import i -> failure t
+  DataDecl i exp consdecls -> failure t
+  TypeDecl i exp -> failure t
+  ValueDecl i patterns exp -> failure t
+  DeriveDecl i0 i1 -> failure t
+  ConsDecl i exp -> failure t
+  PConsTop i pattern patterns -> failure t
+  PCons i patterns -> failure t
+  PRec fieldpatterns -> failure t
+  PType  -> failure t
+  PStr str -> failure t
+  PInt n -> failure t
+  PVar i -> failure t
+  PWild  -> failure t
+  FieldPattern i pattern -> failure t
+  ELet letdefs exp -> failure t
+  ECase exp cases -> failure t
+  EIf exp0 exp1 exp2 -> failure t
+  EAbs varorwild exp -> failure t
+  EPi varorwild exp0 exp1 -> failure t
+  EPiNoVar exp0 exp1 -> failure t
+  EOr exp0 exp1 -> failure t
+  EAnd exp0 exp1 -> failure t
+  EEq exp0 exp1 -> failure t
+  ENe exp0 exp1 -> failure t
+  ELt exp0 exp1 -> failure t
+  ELe exp0 exp1 -> failure t
+  EGt exp0 exp1 -> failure t
+  EGe exp0 exp1 -> failure t
+  EAdd exp0 exp1 -> failure t
+  ESub exp0 exp1 -> failure t
+  EMul exp0 exp1 -> failure t
+  EDiv exp0 exp1 -> failure t
+  EMod exp0 exp1 -> failure t
+  EProj exp i -> failure t
+  ENeg exp -> failure t
+  EApp exp0 exp1 -> failure t
+  EEmptyRec  -> failure t
+  ERecType fieldtypes -> failure t
+  ERec fieldvalues -> failure t
+  EVar i -> failure t
+  EType  -> failure t
+  EStr str -> failure t
+  EInt n -> failure t
+  LetDef i exp0 exp1 -> failure t
+  Case pattern exp -> failure t
+  VVar i -> failure t
+  VWild  -> failure t
+  FieldType i exp -> failure t
+  FieldValue i exp -> failure t
+  Ident str -> failure t
+
+transModule :: Module -> Result
+transModule t = case t of
+  Module imports decls -> failure t
+
+transImport :: Import -> Result
+transImport t = case t of
+  Import i -> failure t
+
+transDecl :: Decl -> Result
+transDecl t = case t of
+  DataDecl i exp consdecls -> failure t
+  TypeDecl i exp -> failure t
+  ValueDecl i patterns exp -> failure t
+  DeriveDecl i0 i1 -> failure t
+
+transConsDecl :: ConsDecl -> Result
+transConsDecl t = case t of
+  ConsDecl i exp -> failure t
+
+transPattern :: Pattern -> Result
+transPattern t = case t of
+  PConsTop i pattern patterns -> failure t
+  PCons i patterns -> failure t
+  PRec fieldpatterns -> failure t
+  PType  -> failure t
+  PStr str -> failure t
+  PInt n -> failure t
+  PVar i -> failure t
+  PWild  -> failure t
+
+transFieldPattern :: FieldPattern -> Result
+transFieldPattern t = case t of
+  FieldPattern i pattern -> failure t
+
+transExp :: Exp -> Result
+transExp t = case t of
+  ELet letdefs exp -> failure t
+  ECase exp cases -> failure t
+  EIf exp0 exp1 exp2 -> failure t
+  EAbs varorwild exp -> failure t
+  EPi varorwild exp0 exp1 -> failure t
+  EPiNoVar exp0 exp1 -> failure t
+  EOr exp0 exp1 -> failure t
+  EAnd exp0 exp1 -> failure t
+  EEq exp0 exp1 -> failure t
+  ENe exp0 exp1 -> failure t
+  ELt exp0 exp1 -> failure t
+  ELe exp0 exp1 -> failure t
+  EGt exp0 exp1 -> failure t
+  EGe exp0 exp1 -> failure t
+  EAdd exp0 exp1 -> failure t
+  ESub exp0 exp1 -> failure t
+  EMul exp0 exp1 -> failure t
+  EDiv exp0 exp1 -> failure t
+  EMod exp0 exp1 -> failure t
+  EProj exp i -> failure t
+  ENeg exp -> failure t
+  EApp exp0 exp1 -> failure t
+  EEmptyRec  -> failure t
+  ERecType fieldtypes -> failure t
+  ERec fieldvalues -> failure t
+  EVar i -> failure t
+  EType  -> failure t
+  EStr str -> failure t
+  EInt n -> failure t
+
+transLetDef :: LetDef -> Result
+transLetDef t = case t of
+  LetDef i exp0 exp1 -> failure t
+
+transCase :: Case -> Result
+transCase t = case t of
+  Case pattern exp -> failure t
+
+transVarOrWild :: VarOrWild -> Result
+transVarOrWild t = case t of
+  VVar i -> failure t
+  VWild  -> failure t
+
+transFieldType :: FieldType -> Result
+transFieldType t = case t of
+  FieldType i exp -> failure t
+
+transFieldValue :: FieldValue -> Result
+transFieldValue t = case t of
+  FieldValue i exp -> failure t
+
+transIdent :: Ident -> Result
+transIdent t = case t of
+  Ident str -> failure t
+

src/Transfer/Syntax/Syntax.cf

@@ -0,0 +1,109 @@
+entrypoints Module, Exp ;
+
+layout "let", "where", "of" ;
+layout stop "in" ;
+layout toplevel ;
+
+comment "--" ;
+comment "{-" "-}" ;
+
+Module. Module ::= [Import] [Decl] ;
+
+Import. Import ::= "import" Ident ;
+separator Import ";" ;
+
+DataDecl.  Decl ::= "data" Ident ":" Exp "where" "{" [ConsDecl] "}" ;
+TypeDecl.  Decl ::= Ident ":" Exp ;
+ValueDecl. Decl ::= Ident [Pattern] "=" Exp ;
+DeriveDecl. Decl ::= "derive" Ident Ident ;
+separator Decl ";" ;
+
+ConsDecl. ConsDecl ::= Ident ":" Exp ;
+separator ConsDecl ";" ;
+
+-- Hack: constructor applied to at least one pattern
+-- this is to separate it from variable patterns
+PConsTop. Pattern ::= Ident Pattern1 [Pattern] ;
+_.        Pattern ::= Pattern1 ;
+-- Constructor pattern with parantheses
+PCons.    Pattern1 ::= "(" Ident [Pattern] ")" ;
+-- Record patterns
+PRec.     Pattern1 ::= "{" [FieldPattern] "}";
+-- The pattern matching the Type constant
+PType.    Pattern1 ::= "Type" ;
+-- String literal patterns
+PStr.     Pattern1 ::= String ;
+-- Integer literal patterns
+PInt.     Pattern1 ::= Integer ;
+-- Variable patterns
+PVar.     Pattern1 ::= Ident ;
+-- Wild card patterns
+PWild.    Pattern1 ::= "_" ;
+
+[].  [Pattern] ::= ;
+(:). [Pattern] ::= Pattern1 [Pattern] ;
+
+FieldPattern. FieldPattern ::= Ident "=" Pattern ;
+separator FieldPattern ";" ;
+
+ELet.      Exp  ::= "let" "{" [LetDef] "}" "in" Exp ;
+LetDef.    LetDef ::= Ident ":" Exp "=" Exp ;
+separator LetDef ";" ;
+
+ECase.     Exp  ::= "case" Exp "of" "{" [Case] "}" ;
+Case. Case ::= Pattern "->" Exp ;
+separator Case ";" ;
+
+EIf.       Exp  ::= "if" Exp "then" Exp "else" Exp ;
+
+EAbs.      Exp2 ::= "\\" VarOrWild "->" Exp ;
+EPi.       Exp2 ::= "(" VarOrWild ":" Exp ")" "->" Exp ;
+EPiNoVar.  Exp2 ::= Exp3 "->" Exp ;
+VVar.      VarOrWild ::= Ident ;
+VWild.     VarOrWild ::= "_" ;
+
+EOr.       Exp3 ::= Exp4 "||" Exp3 ;
+EAnd.      Exp4 ::= Exp5 "&&" Exp4 ;
+
+EEq.       Exp5 ::= Exp6 "==" Exp6 ;
+ENe.       Exp5 ::= Exp6 "/=" Exp6 ;
+ELt.       Exp5 ::= Exp6 "<"  Exp6 ;
+ELe.       Exp5 ::= Exp6 "<=" Exp6 ;
+EGt.       Exp5 ::= Exp6 ">"  Exp6 ;
+EGe.       Exp5 ::= Exp6 ">=" Exp6 ;
+
+EAdd.      Exp6 ::= Exp6 "+" Exp7 ;
+ESub.      Exp6 ::= Exp6 "-" Exp7 ;
+
+EMul.      Exp7 ::= Exp7 "*" Exp8 ;
+EDiv.      Exp7 ::= Exp7 "/" Exp8 ;
+EMod.      Exp7 ::= Exp7 "%" Exp8 ;
+
+EProj.     Exp8 ::= Exp8 "." Ident ;
+
+ENeg.      Exp9 ::= "-" Exp9 ;
+
+EApp.      Exp10 ::= Exp10 Exp11 ;
+
+EEmptyRec. Exp11 ::= "{" "}" ;
+
+ERecType.  Exp11 ::= "{" [FieldType] "}" ;
+FieldType. FieldType  ::= Ident ":" Exp ;
+separator nonempty FieldType ";" ;
+
+ERec.      Exp11 ::= "{" [FieldValue] "}" ;
+FieldValue.FieldValue ::= Ident "=" Exp ;
+separator nonempty FieldValue ";" ;
+
+EVar.      Exp11 ::= Ident ;
+EType.     Exp11 ::= "Type" ;
+EStr.      Exp11 ::= String ;
+EInt.      Exp11 ::= Integer ;
+
+coercions Exp 11 ;
+
+
+
+
+
+

src/Transfer/Syntax/Test.hs

@@ -0,0 +1,58 @@
+-- automatically generated by BNF Converter
+module Main where
+
+
+import IO ( stdin, hGetContents )
+import System ( getArgs, getProgName )
+
+import Transfer.Syntax.Lex
+import Transfer.Syntax.Par
+import Transfer.Syntax.Skel
+import Transfer.Syntax.Print
+import Transfer.Syntax.Abs
+import Transfer.Syntax.Layout
+
+
+
+import Transfer.ErrM
+
+type ParseFun a = [Token] -> Err a
+
+myLLexer = resolveLayout True . 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
+
+
+
+
+

src/Transfer/SyntaxToCore.hs

@@ -0,0 +1,406 @@
+-- | Translate to the core language
+module Transfer.SyntaxToCore where
+
+import Transfer.Syntax.Abs
+import Transfer.Syntax.Print
+
+import Control.Monad.State
+import Data.List
+import Data.Maybe
+import qualified Data.Set as Set
+import Data.Set (Set)
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.Monoid
+
+import Debug.Trace
+
+type C a = State CState a
+
+type CState = Integer
+
+
+
+declsToCore :: [Decl] -> [Decl]
+declsToCore m = evalState (declsToCore_ m) newState
+
+declsToCore_ :: [Decl] -> C [Decl]
+declsToCore_ =     deriveDecls
+               >>> replaceCons 
+               >>> compilePattDecls 
+               >>> desugar 
+               >>> optimize
+
+optimize :: [Decl] -> C [Decl]
+optimize =     removeUselessMatch
+           >>> betaReduce
+
+newState :: CState
+newState = 0
+
+--
+-- * Pattern equations
+--
+
+compilePattDecls :: [Decl] -> C [Decl]
+compilePattDecls [] = return []
+compilePattDecls (d@(ValueDecl x _ _):ds) =
+    do
+    let (xs,rest) = span (isValueDecl x) ds
+    d <- mergeDecls (d:xs)
+    rs <- compilePattDecls rest
+    return (d:rs)
+compilePattDecls (d:ds) = liftM (d:) (compilePattDecls ds)
+
+-- | Take a non-empty list of pattern equations for the same
+--   function, and produce a single declaration.
+mergeDecls :: [Decl] -> C Decl
+mergeDecls ds@(ValueDecl x p _:_)
+    = do let cs = [ (ps,rhs) | ValueDecl _ ps rhs <- ds ]
+             (pss,rhss) = unzip cs
+             n = length p
+         when (not (all ((== n) . length) pss))
+              $ fail $ "Pattern count mismatch for " ++ printTree x
+         vs <- replicateM n freshIdent
+         let cases = map (\ (ps,rhs) -> Case (mkPRec ps) rhs) cs
+             c = ECase (mkERec (map EVar vs)) cases
+             f = foldr (EAbs . VVar) c vs
+         return $ ValueDecl x [] f
+  where mkRec r f = r . zipWith (\i e -> f (Ident ("p"++show i)) e) [0..]
+        mkPRec = mkRec PRec FieldPattern
+        mkERec xs | null xs = EEmptyRec
+                  | otherwise = mkRec ERec FieldValue xs
+
+--
+-- * Derived function definitions
+--
+
+deriveDecls :: [Decl] -> C [Decl]
+deriveDecls ds = liftM concat (mapM der ds)
+  where 
+  ts = dataTypes ds
+  der (DeriveDecl (Ident f) t) = 
+      case lookup f derivators of
+           Just d -> d t k cs
+           _ -> fail $ "Don't know how to derive " ++ f
+      where (k,cs) = getDataType ts t
+  der d                = return [d]
+
+type Derivator = Ident -> Exp -> [(Ident,Exp)] -> C [Decl]
+
+derivators :: [(String, Derivator)]
+derivators = [
+              ("composOp", deriveComposOp),
+              ("show", deriveShow),
+              ("eq", deriveEq),
+              ("ord", deriveOrd)
+             ]
+
+deriveComposOp :: Derivator
+deriveComposOp t k cs = 
+    do
+    a <- freshIdent
+    c <- freshIdent
+    f <- freshIdent
+    x <- freshIdent
+    let co = Ident ("composOp_" ++ printTree t)
+        e = EVar
+        pv = VVar
+        infixr 3 -->
+        (-->) = EPiNoVar
+        ta = EApp (e t) (e a)
+        tc = EApp (e t) (e c)
+        infixr 3 \->
+        (\->) = EAbs
+        mkCase ci ct = 
+            do
+            vars <- replicateM (arity ct) freshIdent
+            -- FIXME: the type argument to f is wrong if the constructor
+            -- has a dependent type
+            -- FIXME: make a special case for lists?
+            let rec v at = case at of
+                                   EApp (EVar t') _ | t' == t -> apply (e f) [at, e v]
+                                   _ -> e v
+                calls = zipWith rec vars (argumentTypes ct)
+            return $ Case (PCons ci (map PVar vars)) (apply (e ci) calls)
+    cases <- mapM (uncurry mkCase) cs
+    let cases' = cases ++ [Case PWild (e x)]
+    return $ [TypeDecl co $ EPi (pv c) EType $ (EPi (pv a) EType $ ta --> ta) --> tc --> tc,
+              ValueDecl co [] $ VWild \-> pv f \-> pv x \-> ECase (e x) cases']
+
+deriveShow :: Derivator
+deriveShow t k cs = fail $ "derive show not implemented"
+
+deriveEq :: Derivator
+deriveEq t k cs = fail $ "derive eq not implemented"
+
+deriveOrd :: Derivator
+deriveOrd t k cs = fail $ "derive ord not implemented"
+
+--
+-- * Constructor patterns and applications.
+--
+
+type DataConsInfo = Map Ident Int
+
+consArities :: [Decl] -> DataConsInfo
+consArities ds = Map.fromList [ (c, arity t) | DataDecl _ _ cs <- ds, 
+                                               ConsDecl c t <- cs ]
+
+-- | Get the arity of a function type.
+arity :: Exp -> Int
+arity = length . argumentTypes
+
+-- | Get the argument type of a function type. Note that
+--   the returned types may contains free variables 
+--   which should be bound to the values of earlier arguments.
+argumentTypes :: Exp -> [Exp]
+argumentTypes e = case e of
+                      EPi _ t e' -> t : argumentTypes e'
+                      EPiNoVar t e' -> t : argumentTypes e'
+                      _ -> []
+
+-- | Fix up constructor patterns and applications.
+replaceCons :: [Decl] -> C [Decl]
+replaceCons ds = mapM f ds
+  where
+  cs = consArities ds 
+  isCons id = id `Map.member` cs 
+  f :: Tree a -> C (Tree a)
+  f t = case t of
+        -- get rid of the PConsTop hack
+        PConsTop id p1 ps -> f (PCons id (p1:ps))
+        -- replace patterns C where C is a constructor with (C)
+        PVar id | isCons id -> return $ PCons id []
+        -- eta-expand constructors. betaReduce will remove any beta 
+        -- redexes produced here.
+        EVar id | isCons id -> do
+                               let Just n = Map.lookup id cs
+                               vs <- replicateM n freshIdent
+                               let c = apply t (map EVar vs)
+                               return $ foldr (EAbs . VVar) c vs
+        _ -> composOpM f t
+
+--
+-- * Do simple beta reductions.
+--
+
+betaReduce :: [Decl] -> C [Decl]
+betaReduce = return . map f
+ where
+ f :: Tree a -> Tree a
+ f t = case t of
+              EApp (EAbs (VVar x) b) e | countFreeOccur x b == 1 -> f (subst x e b)
+              _ -> composOp f t
+
+--
+-- * Remove useless pattern matching.
+--
+
+removeUselessMatch :: [Decl] -> C [Decl]
+removeUselessMatch = return . map f
+ where
+ f :: Tree a -> Tree a
+ f x = case x of
+       -- replace \x -> case x of { y -> e } with \y -> e,
+       -- if x is not free in e
+       -- FIXME: this checks the result of the recursive call,
+       --        can we do something about this?
+       EAbs (VVar x) b -> 
+           case f b of
+                    ECase (EVar x') [Case (PVar y) e]
+                          | x' == x && not (x `isFreeIn` e)
+                              -> f (EAbs (VVar y) e)
+                    e -> EAbs (VVar x) e
+       -- for value declarations without patterns, compilePattDecls 
+       -- generates pattern matching on the empty record, remove these
+       ECase EEmptyRec [Case (PRec []) e] -> f e
+       -- if the pattern matching is on a single field of a record expression
+       -- with only one field, there is no need to wrap it in a record
+       ECase (ERec [FieldValue x e]) cs | all (isSingleFieldPattern x) [ p | Case p _ <- cs]
+              -> f (ECase e [ Case p r | Case (PRec [FieldPattern _ p]) r <- cs ])
+       -- In cases: remove record field patterns which only bind unused variables
+       Case (PRec fps) e -> Case (f (PRec (fps \\ unused))) (f e)
+          where unused = [fp | fp@(FieldPattern l (PVar id)) <- fps, 
+                               not (id `isFreeIn` e)]
+       -- Remove wild card patterns in record patterns
+       PRec fps -> PRec (map f (fps \\ wildcards))
+          where wildcards = [fp | fp@(FieldPattern _ PWild) <- fps]
+       _ -> composOp f x
+ isSingleFieldPattern :: Ident -> Pattern -> Bool
+ isSingleFieldPattern x p = case p of
+                                PRec [FieldPattern y _] -> x == y
+                                _ -> False
+
+--
+-- * Remove simple syntactic sugar.
+--
+
+desugar :: [Decl] -> C [Decl]
+desugar = return . map f
+ where
+ f :: Tree a -> Tree a
+ f x = case x of
+              EIf exp0 exp1 exp2 -> ifBool          <| exp0 <| exp1 <| exp2
+              EPiNoVar exp0 exp1 -> EPi VWild       <| exp0 <| exp1
+              EOr  exp0 exp1     -> andBool         <| exp0 <| exp1
+              EAnd exp0 exp1     -> orBool          <| exp0 <| exp1
+              EEq  exp0 exp1     -> appIntBin "eq"  <| exp0 <| exp1
+              ENe  exp0 exp1     -> appIntBin "ne"  <| exp0 <| exp1
+              ELt  exp0 exp1     -> appIntBin "lt"  <| exp0 <| exp1
+              ELe  exp0 exp1     -> appIntBin "le"  <| exp0 <| exp1
+              EGt  exp0 exp1     -> appIntBin "gt"  <| exp0 <| exp1
+              EGe  exp0 exp1     -> appIntBin "ge"  <| exp0 <| exp1
+              EAdd exp0 exp1     -> appIntBin "add" <| exp0 <| exp1
+              ESub exp0 exp1     -> appIntBin "sub" <| exp0 <| exp1
+              EMul exp0 exp1     -> appIntBin "mul" <| exp0 <| exp1
+              EDiv exp0 exp1     -> appIntBin "div" <| exp0 <| exp1
+              EMod exp0 exp1     -> appIntBin "mod" <| exp0 <| exp1
+              ENeg exp0          -> appIntUn  "neg" <| exp0
+              _                  -> composOp f x
+    where g <| x = g (f x)
+
+--
+-- * Integers
+--
+
+appIntUn :: String -> Exp -> Exp
+appIntUn f e = EApp (var ("prim_"++f++"_Int")) e
+
+appIntBin :: String -> Exp -> Exp -> Exp
+appIntBin f e1 e2 = EApp (EApp (var ("prim_"++f++"_Int")) e1) e2
+
+--
+-- * Booleans
+--
+
+andBool :: Exp -> Exp -> Exp
+andBool e1 e2 = ifBool e1 e2 (var "False")
+
+orBool :: Exp -> Exp -> Exp
+orBool e1 e2 = ifBool e1 (var "True") e2
+
+ifBool :: Exp -> Exp -> Exp -> Exp
+ifBool c t e = ECase c [Case (PCons (Ident "True") []) t,
+                        Case (PCons (Ident "False") []) e]
+
+--
+-- * Substitution
+--
+
+subst :: Ident -> Exp -> Exp -> Exp
+subst x e = f
+ where 
+ f :: Tree a -> Tree a
+ f t = case t of
+   ELet defs exp3 | x `Set.member` letDefBinds defs ->
+         ELet [ LetDef id (f exp1) exp2 | LetDef id exp1 exp2 <- defs] exp3
+   Case p e | x `Set.member` binds p -> t
+   EAbs (VVar id) _ | x == id -> t
+   EPi (VVar id) exp1 exp2 | x == id -> EPi (VVar id) (f exp1) exp2
+   EVar i | i == x -> e
+   _      -> composOp f t
+
+--
+-- * Abstract syntax utilities
+--
+
+var :: String -> Exp
+var s = EVar (Ident s)
+
+-- | Apply an expression to a list of arguments.
+apply :: Exp -> [Exp] -> Exp
+apply = foldl EApp
+
+-- | Get an identifier which cannot occur in user-written
+--   code, and which has not been generated before.
+freshIdent :: C Ident
+freshIdent = do
+             i <- get
+             put (i+1)
+             return (Ident ("x_"++show i))
+
+-- | Get the variables bound by a set of let definitions.
+letDefBinds :: [LetDef] -> Set Ident
+letDefBinds defs = Set.fromList [ id | LetDef id _ _ <- defs]
+
+letDefTypes :: [LetDef] -> [Exp]
+letDefTypes defs = [ exp1 | LetDef _ exp1 _ <- defs ]
+
+letDefRhss :: [LetDef] -> [Exp]
+letDefRhss defs = [ exp2 | LetDef _ _ exp2 <- defs ]
+
+-- | Get the free variables in an expression.
+freeVars :: Exp -> Set Ident
+freeVars = f
+  where
+  f :: Tree a -> Set Ident
+  f t = case t of
+   ELet defs exp3 -> 
+        Set.unions $
+           (Set.unions (f exp3:map f (letDefRhss defs)) Set.\\ letDefBinds defs)
+           :map f (letDefTypes defs)
+   ECase exp cases -> f exp `Set.union` 
+                      Set.unions [ f e Set.\\ binds p | Case p e <- cases]
+   EAbs (VVar id) exp -> Set.delete id (f exp)
+   EPi (VVar id) exp1 exp2 -> f exp1 `Set.union` Set.delete id (f exp2)
+   EVar i -> Set.singleton i
+   _      -> composOpMonoid f t
+
+isFreeIn :: Ident -> Exp -> Bool
+isFreeIn x e = countFreeOccur x e > 0
+
+-- | Count the number of times a variable occurs free in an expression.
+countFreeOccur :: Ident -> Exp -> Int
+countFreeOccur x = f
+  where
+  f :: Tree a -> Int
+  f t = case t of
+   ELet defs _ | x `Set.member` letDefBinds defs ->
+            sum (map f (letDefTypes defs))
+   Case p e | x `Set.member` binds p -> 0
+   EAbs (VVar id) _ | id == x -> 0
+   EPi (VVar id) exp1 _ | id == x -> f exp1
+   EVar id | id == x -> 1
+   _      -> composOpFold 0 (+) f t
+
+-- | Get the variables bound by a pattern.
+binds :: Pattern -> Set Ident
+binds = f
+ where 
+ f :: Tree a -> Set Ident
+ f p = case p of
+                 -- replaceCons removes non-variable PVars
+                 PVar id -> Set.singleton id 
+                 _ -> composOpMonoid f p
+
+-- | Checks if a declaration is a value declaration
+--   of the given identifier.
+isValueDecl :: Ident -> Decl -> Bool
+isValueDecl x (ValueDecl y _ _) = x == y
+isValueDecl _ _ = False
+
+--
+-- * Data types
+--
+
+type DataTypes = Map Ident (Exp,[(Ident,Exp)])
+
+-- | Get a map of data type names to the type of the type constructor
+--   and all data constructors with their types.
+dataTypes :: [Decl] -> Map Ident (Exp,[(Ident,Exp)])
+dataTypes ds = Map.fromList [ (i,(t,[(c,ct) | ConsDecl c ct <- cs])) | DataDecl i t cs <- ds]
+
+getDataType :: DataTypes -> Ident -> (Exp,[(Ident,Exp)])
+getDataType ts i = 
+    fromMaybe (error $ "Data type " ++ printTree i ++ " not found")
+              (Map.lookup i ts) 
+
+--
+-- * Utilities
+--
+
+infixl 1 >>>
+
+(>>>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c
+f >>> g = (g =<<) . f

transfer/Makefile

@@ -0,0 +1,50 @@
+SRCDIR=../src
+
+GHC=ghc
+GHCFLAGS=-i$(SRCDIR)
+
+
+.PHONY: all bnfc bnfctest doc docclean clean bnfcclean distclean
+
+all:
+	$(GHC) $(GHCFLAGS) --make -o run_core run_core.hs
+	$(GHC) $(GHCFLAGS) --make -o compile_to_core compile_to_core.hs
+
+bnfc: bnfcclean
+	cd $(SRCDIR) && bnfc -gadt -d -p Transfer Transfer/Core/Core.cf
+	perl -i -pe 's/^import Transfer.Core.ErrM/import Transfer.ErrM/' $(SRCDIR)/Transfer/Core/*.{hs,x,y}
+	-rm -f $(SRCDIR)/Transfer/Core/ErrM.hs
+	cd $(SRCDIR) && alex -g Transfer/Core/Lex.x
+	cd $(SRCDIR) && happy -gca Transfer/Core/Par.y
+	cd $(SRCDIR) && bnfc -gadt -d -p Transfer Transfer/Syntax/Syntax.cf
+	perl -i -pe 's/^import Transfer.Syntax.ErrM/import Transfer.ErrM/' $(SRCDIR)/Transfer/Syntax/*.{hs,x,y}
+	-rm -f $(SRCDIR)/Transfer/Syntax/ErrM.hs
+	cd $(SRCDIR) && alex -g Transfer/Syntax/Lex.x
+	cd $(SRCDIR) && happy -gca Transfer/Syntax/Par.y
+
+bnfctest:
+	ghc $(GHCFLAGS) --make $(SRCDIR)/Transfer/Core/Test.hs -o test_core
+	ghc $(GHCFLAGS) --make $(SRCDIR)/Transfer/Syntax/Test.hs -o test_syntax
+	ghc $(GHCFLAGS) --make $(SRCDIR)/Transfer/Syntax/ResolveLayout.hs -o test_layout
+
+doc:
+	(cd $(SRCDIR)/Transfer/Core/; latex Doc.tex; dvips Doc.dvi -o Doc.ps)
+	(cd $(SRCDIR)/Transfer/Syntax/; latex Doc.tex; dvips Doc.dvi -o Doc.ps)
+
+docclean:
+	-rm -f $(SRCDIR)/Transfer/Core/*.{log,aux,dvi,ps}
+	-rm -f $(SRCDIR)/Transfer/Syntax/*.{log,aux,dvi,ps}
+
+clean:
+	-rm -f *.o *.hi
+	find $(SRCDIR)/Transfer -name '*.o' -o -name '*.hi' | xargs rm -f
+	-rm -f run_core	
+	-rm -f compile_to_core
+	-rm -f test_core test_syntax test_layout
+
+bnfcclean: 
+	-rm -f $(SRCDIR)/Transfer/Core/{Doc,Lex,Par,Layout,Skel,Print,Test,Abs}.*
+	-rm -f $(SRCDIR)/Transfer/Syntax/{Doc,Lex,Par,Layout,Skel,Print,Test,Abs}.*
+
+distclean: clean bnfcclean
+

transfer/TODO

@@ -0,0 +1,57 @@
+* Improve front-end language
+
+- Tuple syntax in expressions, types and patterns. Implemented with records.
+
+- List syntax in expressions, types and patterns. Implemented with List.
+
+- operators for primitive string operations: 
+
+- list operators: ++, :
+
+- overloaded operators?
+
+- implicit arguments?
+
+- layout syntax?
+
+- composOp generation
+
+- show generation
+
+- eq generation
+
+- better module system
+
+- Disjunctive patterns
+
+- Negated patterns?
+
+- Fix BNFC layout resolver to not insert double ; (instead of removing them)
+
+* Improve interpreter
+
+- More efficient handling of constructor application
+
+* Improve interpreter API
+
+- Allow passing terms as some structured type.
+
+* Improve the core language
+
+* Improve compilation
+
+- Eta-expand constructor applications and use the core feature for them.
+
+* Add primitive operations to core
+
+- primitive operations on strings:
+
+- add floating-point numbers with primitive oeprations?
+
+* Implement module system in interpreter
+
+* Add type checker for core
+
+* Add friendly type checker for front-end language
+
+* Add termination checker

transfer/compile_to_core.hs

@@ -0,0 +1,52 @@
+module Main where
+
+import Transfer.Syntax.Lex
+import Transfer.Syntax.Par
+import Transfer.Syntax.Print
+import Transfer.Syntax.Abs
+import Transfer.Syntax.Layout
+
+import Transfer.ErrM
+import Transfer.SyntaxToCore
+
+import Transfer.PathUtil
+
+import System.Environment
+import System.Exit
+import System.IO
+
+import Debug.Trace
+
+myLLexer = resolveLayout True . myLexer
+
+compile :: Monad m => [Decl] -> m String
+compile m = return (printTree $ declsToCore m)
+
+loadModule :: FilePath -> IO [Decl]
+loadModule f = 
+    do
+    s <- readFile f
+    Module is ds <- case pModule (myLLexer s) of
+                     Bad e    -> die $ "Parse error in " ++ f ++ ": " ++ e
+                     Ok  m    -> return m 
+    let dir = directoryOf f
+        deps = [ replaceFilename f i ++ ".tr" | Import (Ident i) <- is ]
+    dss <- mapM loadModule deps
+    return $ concat (ds:dss)
+
+die :: String -> IO a
+die s = do
+        hPutStrLn stderr s
+        exitFailure
+
+coreFile :: FilePath -> FilePath
+coreFile f = replaceFilenameSuffix f "trc"
+
+compileFile :: FilePath -> IO String
+compileFile f = loadModule f >>= compile
+
+main :: IO ()
+main = do args <- getArgs
+          case args of
+            [f] -> compileFile f >>= writeFile (coreFile f)
+            _   -> die "Usage: compile_to_core <file>"

transfer/examples/array.tr

@@ -0,0 +1,10 @@
+import nat ;
+
+data Array : Type -> Nat -> Type where {
+   Empty : (A:Type) -> Array A Zero ;
+   Cell : (A:Type) -> (n:Nat) -> A -> Array A n -> Array A (Succ n) ;
+ } ;
+
+mapA : (A:Type) -> (B:Type) -> (n:Nat) -> (A -> B) -> Array A n -> Array B n ;
+mapA A B _ f (Empty _) = Empty B ;
+mapA A B (Succ n) f (Cell _ _ x xs) = Cell B n (f x) (mapA A B n f xs) ;

transfer/examples/bool.tr

@@ -0,0 +1,8 @@
+data Bool : Type where { True : Bool; False : Bool; } ;
+
+depif : (A:Type) -> (B:Type) -> (b:Bool) -> A -> B -> if Type b then A else B ;
+depif _ _ True x _ = x ;
+depif _ _ False _ y = y ;
+
+not : Bool -> Bool ;
+not b = if b then False else True ;

transfer/examples/exp.tr

@@ -0,0 +1,31 @@
+data Stm : Type where {} ;
+data Exp : Type where {} ;
+data Var : Type where {} ;
+data Typ : Type where {} ;
+
+data ListStm : Type where {} ;
+
+data Tree : Type -> Type where {
+  SDecl   : Tree Typ -> Tree Var -> Tree Stm ;
+  SAss    : Tree Var -> Tree Exp -> Tree Stm ;
+  SBlock  : Tree ListStm -> Tree Stm ;
+  EAdd    : Tree Exp -> Tree Exp -> Tree Exp ;
+  EStm    : Tree Stm -> Tree Exp ;
+  EVar    : Tree Var -> Tree Exp ;
+  EInt    : Integer -> Tree Exp ;
+  V       : String -> Tree Var ;
+  TInt    : Tree Typ ;
+  TFloat  : Tree Typ ;
+
+  NilStm  : Tree ListStm ;
+  ConsStm : Tree Stm -> Tree ListStm -> Tree ListStm ;
+ } ;
+
+derive composOp Tree ;
+
+rename : (String -> String) -> (C : Type) -> Tree C -> Tree C;
+rename f C t = case t of {
+		   V x -> V (f x) ;
+		   _ -> composOp_Tree C (rename f) t;
+                 } ;
+

transfer/examples/fib.tr

@@ -0,0 +1,11 @@
+import nat ;
+
+fib : Int -> Int ;
+fib 0 = 1 ;
+fib 1 = 1 ;
+fib n = fib (n-1) + fib (n-2) ;
+
+fibNat : Nat -> Nat ;
+fibNat Zero = Succ Zero ;
+fibNat (Succ Zero) = Succ Zero ;
+fibNat (Succ (Succ n)) = plus (fibNat (Succ n)) (fibNat n) ;

transfer/examples/layout.tr

@@ -0,0 +1,5 @@
+x : Apa
+x = let x : T = y 
+     in case y of
+         f -> q
+         _ -> a

transfer/examples/list.tr

@@ -0,0 +1,17 @@
+import nat ;
+
+data List : (_:Type) -> Type where 
+	{ Nil : (A:Type) -> List A ;
+          Cons : (A:Type) -> A -> List A -> List A ; } ;
+
+size : (A:Type) -> List A -> Nat ;
+size _ (Nil _) = Zero ;
+size A (Cons _ x xs) = Succ (size A xs) ;
+
+map : (A:Type) -> (B:Type) -> (A -> B) -> List A -> List B ;
+map _ B _ (Nil _) = Nil B ;
+map A B f (Cons _ x xs) = Cons B (f x) (map A B f xs) ;
+
+append : (A:Type) -> (xs:List A) -> List A -> List A ;
+append _ (Nil _) ys = ys ;
+append A (Cons _ x xs) ys = Cons A x (append A xs ys) ;

transfer/examples/nat.tr

@@ -0,0 +1,23 @@
+data Nat : Type where { 
+	Zero : Nat ;
+  	Succ : (n:Nat) -> Nat ;
+ } ;
+
+plus : Nat -> Nat -> Nat ;
+plus Zero y = y ;
+plus (Succ x) y = Succ (plus x y) ;
+
+pred : Nat -> Nat ;
+pred Zero = Zero ;
+pred (Succ n) = n ;
+
+natToInt : Nat -> Int ;
+natToInt Zero = 0 ;
+natToInt (Succ n) = 1 + natToInt n ;
+
+plus : Nat -> Nat -> Nat ;
+plus Zero y = y ;
+plus (Succ x) y = Succ (plus x y) ;
+
+intToNat : Int -> Nat ;
+intToNat n = if n == 0 then Zero else Succ (intToNat (n-1)) ;

transfer/examples/pair.tr

@@ -0,0 +1,11 @@
+Pair : Type -> Type -> Type ;
+Pair A B = { p1 : A; p2 : B } ;
+
+pair : (A:Type) -> (B:Type) -> A -> B -> Pair A B ;
+pair _ _ x y = { p1 = x; p2 = y } ;
+
+fst : (A:Type) -> (B:Type) -> Pair A B -> A ;
+fst _ _ p = case p of { (Pair _ _ x _) -> x } ;
+
+snd : (A:Type) -> (B:Type) -> Pair A B -> B ;
+snd _ _ p = case p of { (Pair _ _ x _) -> x } ;

transfer/examples/prelude.tr

@@ -0,0 +1,5 @@
+const : (A:Type) -> (B:Type) -> A -> B -> A ;
+const _ _ x _ = x ;
+
+id : (A:Type) -> A -> A ;
+id A x = x ;

transfer/examples/prim.tr

@@ -0,0 +1,23 @@
+--
+-- Primitives
+--
+
+
+String : Type ;
+
+Int : Type ;
+
+prim_add_Int : (_:Int) -> (_:Int) -> Int ;
+prim_sub_Int : (_:Int) -> (_:Int) -> Int ;
+prim_mul_Int : (_:Int) -> (_:Int) -> Int ;
+prim_div_Int : (_:Int) -> (_:Int) -> Int ;
+prim_mod_Int : (_:Int) -> (_:Int) -> Int ;
+
+prim_neg_Int : (_:Int) -> Int ;
+
+prim_lt_Int : (_:Int) -> (_:Int) -> Bool ;
+prim_le_Int : (_:Int) -> (_:Int) -> Bool ;
+prim_gt_Int : (_:Int) -> (_:Int) -> Bool ;
+prim_ge_Int : (_:Int) -> (_:Int) -> Bool ;
+prim_eq_Int : (_:Int) -> (_:Int) -> Bool ;
+prim_ne_Int : (_:Int) -> (_:Int) -> Bool ;

transfer/examples/test.tr

@@ -0,0 +1,3 @@
+import nat ;
+
+main = natToInt (intToNat 100) ;

transfer/run_core.hs

@@ -0,0 +1,26 @@
+import Transfer.InterpreterAPI
+
+import Data.List (partition, isPrefixOf)
+import System.Environment (getArgs)
+
+interpretLoop :: Env -> IO ()
+interpretLoop env = do    
+                    line <- getLine
+                    r <- evaluateString env line
+                    putStrLn r
+                    interpretLoop env
+
+runMain :: Env -> IO ()
+runMain env = do
+              r <- evaluateString env "main"
+              putStrLn r
+
+main :: IO ()
+main = do args <- getArgs
+          let (flags,files) = partition ("-" `isPrefixOf`) args
+          env <- case files of
+            [f] -> loadFile f
+            _   -> fail "Usage: run_core [-i] <file>"
+          if "-i" `elem` flags 
+            then interpretLoop env
+            else runMain env