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

Move transfer into the GF repo.

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

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

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

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

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

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

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

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

File diff suppressed because one or more lines are too long

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

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

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

File diff suppressed because it is too large Load Diff

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

@@ -0,0 +1,193 @@
-- This Happy file was machine-generated by the BNF converter
{
module Transfer.Core.Par where
import Transfer.Core.Abs
import Transfer.Core.Lex
import Transfer.ErrM
}
%name pModule Module
%name pExp Exp
-- no lexer declaration
%monad { Err } { thenM } { returnM }
%tokentype { Token }
%token
';' { PT _ (TS ";") }
':' { PT _ (TS ":") }
'{' { PT _ (TS "{") }
'}' { PT _ (TS "}") }
'=' { PT _ (TS "=") }
'(' { PT _ (TS "(") }
')' { PT _ (TS ")") }
'_' { PT _ (TS "_") }
'\\' { PT _ (TS "\\") }
'->' { PT _ (TS "->") }
'.' { PT _ (TS ".") }
'Type' { PT _ (TS "Type") }
'case' { PT _ (TS "case") }
'data' { PT _ (TS "data") }
'in' { PT _ (TS "in") }
'let' { PT _ (TS "let") }
'of' { PT _ (TS "of") }
'where' { PT _ (TS "where") }
L_quoted { PT _ (TL $$) }
L_integ { PT _ (TI $$) }
L_CIdent { PT _ (T_CIdent $$) }
L_err { _ }
%%
String :: { String } : L_quoted { $1 }
Integer :: { Integer } : L_integ { (read $1) :: Integer }
CIdent :: { CIdent} : L_CIdent { CIdent ($1)}
Module :: { Module }
Module : ListDecl { Module $1 }
ListDecl :: { [Decl] }
ListDecl : {- empty -} { [] }
| Decl { (:[]) $1 }
| Decl ';' ListDecl { (:) $1 $3 }
Decl :: { Decl }
Decl : 'data' CIdent ':' Exp 'where' '{' ListConsDecl '}' { DataDecl $2 $4 $7 }
| CIdent ':' Exp { TypeDecl $1 $3 }
| CIdent '=' Exp { ValueDecl $1 $3 }
ConsDecl :: { ConsDecl }
ConsDecl : CIdent ':' Exp { ConsDecl $1 $3 }
ListConsDecl :: { [ConsDecl] }
ListConsDecl : {- empty -} { [] }
| ConsDecl { (:[]) $1 }
| ConsDecl ';' ListConsDecl { (:) $1 $3 }
ListPattern :: { [Pattern] }
ListPattern : {- empty -} { [] }
| ListPattern Pattern { flip (:) $1 $2 }
Pattern :: { Pattern }
Pattern : '(' CIdent ListPattern ')' { PCons $2 (reverse $3) }
| PatternVariable { PVar $1 }
| '{' ListFieldPattern '}' { PRec $2 }
| 'Type' { PType }
| String { PStr $1 }
| Integer { PInt $1 }
FieldPattern :: { FieldPattern }
FieldPattern : CIdent '=' Pattern { FieldPattern $1 $3 }
ListFieldPattern :: { [FieldPattern] }
ListFieldPattern : {- empty -} { [] }
| FieldPattern { (:[]) $1 }
| FieldPattern ';' ListFieldPattern { (:) $1 $3 }
PatternVariable :: { PatternVariable }
PatternVariable : CIdent { PVVar $1 }
| '_' { PVWild }
Exp :: { Exp }
Exp : 'let' '{' ListLetDef '}' 'in' Exp { ELet $3 $6 }
| 'case' Exp 'of' '{' ListCase '}' { ECase $2 $5 }
| Exp1 { $1 }
LetDef :: { LetDef }
LetDef : CIdent ':' Exp '=' Exp { LetDef $1 $3 $5 }
ListLetDef :: { [LetDef] }
ListLetDef : {- empty -} { [] }
| LetDef { (:[]) $1 }
| LetDef ';' ListLetDef { (:) $1 $3 }
Exp2 :: { Exp }
Exp2 : '\\' PatternVariable '->' Exp { EAbs $2 $4 }
| '(' PatternVariable ':' Exp ')' '->' Exp { EPi $2 $4 $7 }
| Exp3 { $1 }
Exp3 :: { Exp }
Exp3 : Exp3 Exp4 { EApp $1 $2 }
| Exp4 { $1 }
Exp4 :: { Exp }
Exp4 : Exp4 '.' CIdent { EProj $1 $3 }
| Exp5 { $1 }
Exp5 :: { Exp }
Exp5 : '{' '}' { EEmptyRec }
| '{' ListFieldType '}' { ERecType $2 }
| '{' ListFieldValue '}' { ERec $2 }
| CIdent { EVar $1 }
| 'Type' { EType }
| String { EStr $1 }
| Integer { EInt $1 }
| '(' Exp ')' { $2 }
Exp1 :: { Exp }
Exp1 : Exp2 { $1 }
Case :: { Case }
Case : Pattern '->' Exp { Case $1 $3 }
ListCase :: { [Case] }
ListCase : {- empty -} { [] }
| Case { (:[]) $1 }
| Case ';' ListCase { (:) $1 $3 }
FieldType :: { FieldType }
FieldType : CIdent ':' Exp { FieldType $1 $3 }
ListFieldType :: { [FieldType] }
ListFieldType : FieldType { (:[]) $1 }
| FieldType ';' ListFieldType { (:) $1 $3 }
FieldValue :: { FieldValue }
FieldValue : CIdent '=' Exp { FieldValue $1 $3 }
ListFieldValue :: { [FieldValue] }
ListFieldValue : FieldValue { (:[]) $1 }
| FieldValue ';' ListFieldValue { (:) $1 $3 }
{
returnM :: a -> Err a
returnM = return
thenM :: Err a -> (a -> Err b) -> Err b
thenM = (>>=)
happyError :: [Token] -> Err a
happyError ts =
Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts)))
myLexer = tokens
}

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

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

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

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

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

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

16
src/Transfer/ErrM.hs Normal file
View File

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

169
src/Transfer/Interpreter.hs Normal file
View File

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

31
src/Transfer/InterpreterAPI.hs Normal file
View File

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

110
src/Transfer/PathUtil.hs Normal file
View File

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

415
src/Transfer/Syntax/Abs.hs Normal file
View File

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

266
src/Transfer/Syntax/Doc.tex Normal file
View File

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

205
src/Transfer/Syntax/Layout.hs Normal file
View File

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

345
src/Transfer/Syntax/Lex.hs Normal file
View File

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

134
src/Transfer/Syntax/Lex.x Normal file
View File

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

1489
src/Transfer/Syntax/Par.hs Normal file
View File

File diff suppressed because one or more lines are too long

268
src/Transfer/Syntax/Par.y Normal file
View File

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

177
src/Transfer/Syntax/Print.hs Normal file
View File

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

22
src/Transfer/Syntax/ResolveLayout.hs Normal file
View File

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

157
src/Transfer/Syntax/Skel.hs Normal file
View File

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

109
src/Transfer/Syntax/Syntax.cf Normal file
View File

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

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

@@ -0,0 +1,58 @@
-- automatically generated by BNF Converter
module Main where
import IO ( stdin, hGetContents )
import System ( getArgs, getProgName )
import Transfer.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

406
src/Transfer/SyntaxToCore.hs Normal file
View File

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

50
transfer/Makefile Normal file
View File

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

57
transfer/TODO Normal file
View File

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

52
transfer/compile_to_core.hs Normal file
View File

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

10
transfer/examples/array.tr Normal file
View File

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

8
transfer/examples/bool.tr Normal file
View File

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

31
transfer/examples/exp.tr Normal file
View File

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

11
transfer/examples/fib.tr Normal file
View File

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

5
transfer/examples/layout.tr Normal file
View File

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

17
transfer/examples/list.tr Normal file
View File

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

23
transfer/examples/nat.tr Normal file
View File

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

11
transfer/examples/pair.tr Normal file
View File

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

5
transfer/examples/prelude.tr Normal file
View File

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

23
transfer/examples/prim.tr Normal file
View File

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

3
transfer/examples/test.tr Normal file
View File

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

26
transfer/run_core.hs Normal file
View File

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