mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
Move transfer into the GF repo.
This commit is contained in:
bringert
275
src/Transfer/Core/Abs.hs
Normal file
275
src/Transfer/Core/Abs.hs
Normal 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
98
src/Transfer/Core/Core.cf
Normal 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
203
src/Transfer/Core/Doc.tex
Normal 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
348
src/Transfer/Core/Lex.hs
Normal file
File diff suppressed because one or more lines are too long
137
src/Transfer/Core/Lex.x
Normal file
137
src/Transfer/Core/Lex.x
Normal 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
1113
src/Transfer/Core/Par.hs
Normal file
File diff suppressed because it is too large
Load Diff
193
src/Transfer/Core/Par.y
Normal file
193
src/Transfer/Core/Par.y
Normal 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
152
src/Transfer/Core/Print.hs
Normal 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
114
src/Transfer/Core/Skel.hs
Normal 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
58
src/Transfer/Core/Test.hs
Normal 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
16
src/Transfer/ErrM.hs
Normal 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
169
src/Transfer/Interpreter.hs
Normal 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
31
src/Transfer/InterpreterAPI.hs
Normal 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
110
src/Transfer/PathUtil.hs
Normal 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
415
src/Transfer/Syntax/Abs.hs
Normal 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
266
src/Transfer/Syntax/Doc.tex
Normal 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
205
src/Transfer/Syntax/Layout.hs
Normal 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
345
src/Transfer/Syntax/Lex.hs
Normal 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
134
src/Transfer/Syntax/Lex.x
Normal 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
1489
src/Transfer/Syntax/Par.hs
Normal file
File diff suppressed because one or more lines are too long
268
src/Transfer/Syntax/Par.y
Normal file
268
src/Transfer/Syntax/Par.y
Normal 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
177
src/Transfer/Syntax/Print.hs
Normal 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
22
src/Transfer/Syntax/ResolveLayout.hs
Normal 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
157
src/Transfer/Syntax/Skel.hs
Normal 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
109
src/Transfer/Syntax/Syntax.cf
Normal 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
58
src/Transfer/Syntax/Test.hs
Normal 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
406
src/Transfer/SyntaxToCore.hs
Normal 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
50
transfer/Makefile
Normal 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
57
transfer/TODO
Normal 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
52
transfer/compile_to_core.hs
Normal 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
10
transfer/examples/array.tr
Normal 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
8
transfer/examples/bool.tr
Normal 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
31
transfer/examples/exp.tr
Normal 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
11
transfer/examples/fib.tr
Normal 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
5
transfer/examples/layout.tr
Normal 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
17
transfer/examples/list.tr
Normal 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
23
transfer/examples/nat.tr
Normal 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
11
transfer/examples/pair.tr
Normal 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
5
transfer/examples/prelude.tr
Normal 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
23
transfer/examples/prim.tr
Normal 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
3
transfer/examples/test.tr
Normal file
@@ -0,0 +1,3 @@
|
||||
import nat ;
|
||||
|
||||
main = natToInt (intToNat 100) ;
|
||||
26
transfer/run_core.hs
Normal file
26
transfer/run_core.hs
Normal 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
|
||||
Reference in New Issue
Block a user