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

Move transfer into the GF repo.

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

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

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

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

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

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

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

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

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

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

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

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

File diff suppressed because one or more lines are too long

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

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

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

@@ -0,0 +1,177 @@
{-# OPTIONS_GHC -fglasgow-exts #-}
module Transfer.Syntax.Print where
-- pretty-printer generated by the BNF converter
import Transfer.Syntax.Abs
import Data.Char
import Data.List (intersperse)
-- the top-level printing method
printTree :: Print a => a -> String
printTree = render . prt 0
type Doc = [ShowS] -> [ShowS]
doc :: ShowS -> Doc
doc = (:)
render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
rend i ss = case ss of
"[" :ts -> showChar '[' . rend i ts
"(" :ts -> showChar '(' . rend i ts
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
";" :ts -> showChar ';' . new i . rend i ts
t : "," :ts -> showString t . space "," . rend i ts
t : ")" :ts -> showString t . showChar ')' . rend i ts
t : "]" :ts -> showString t . showChar ']' . rend i ts
t :ts -> space t . rend i ts
_ -> id
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
space t = showString t . (\s -> if null s then "" else (' ':s))
parenth :: Doc -> Doc
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id
concatD :: [Doc] -> Doc
concatD = foldr (.) id
unwordsD :: [Doc] -> Doc
unwordsD = concatD . intersperse (doc (showChar ' '))
replicateS :: Int -> ShowS -> ShowS
replicateS n f = concatS (replicate n f)
-- the printer class does the job
class Print a where
prt :: Int -> a -> Doc
instance Print Char where
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
instance Print String where
prt _ s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
mkEsc :: Char -> Char -> ShowS
mkEsc q s = case s of
_ | s == q -> showChar '\\' . showChar s
'\\'-> showString "\\\\"
'\n' -> showString "\\n"
'\t' -> showString "\\t"
_ -> showChar s
prPrec :: Int -> Int -> Doc -> Doc
prPrec i j = if j<i then parenth else id
instance Print Integer where
prt _ x = doc (shows x)
instance Print Double where
prt _ x = doc (shows x)
instance Print (Tree c) where
prt _i e = case e of
Module imports decls -> prPrec _i 0 (concatD [prt 0 imports , prt 0 decls])
Import i -> prPrec _i 0 (concatD [doc (showString "import") , prt 0 i])
DataDecl i exp consdecls -> prPrec _i 0 (concatD [doc (showString "data") , prt 0 i , doc (showString ":") , prt 0 exp , doc (showString "where") , doc (showString "{") , prt 0 consdecls , doc (showString "}")])
TypeDecl i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString ":") , prt 0 exp])
ValueDecl i patterns exp -> prPrec _i 0 (concatD [prt 0 i , prt 0 patterns , doc (showString "=") , prt 0 exp])
DeriveDecl i0 i1 -> prPrec _i 0 (concatD [doc (showString "derive") , prt 0 i0 , prt 0 i1])
ConsDecl i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString ":") , prt 0 exp])
PConsTop i pattern patterns -> prPrec _i 0 (concatD [prt 0 i , prt 1 pattern , prt 0 patterns])
PCons i patterns -> prPrec _i 1 (concatD [doc (showString "(") , prt 0 i , prt 0 patterns , doc (showString ")")])
PRec fieldpatterns -> prPrec _i 1 (concatD [doc (showString "{") , prt 0 fieldpatterns , doc (showString "}")])
PType -> prPrec _i 1 (concatD [doc (showString "Type")])
PStr str -> prPrec _i 1 (concatD [prt 0 str])
PInt n -> prPrec _i 1 (concatD [prt 0 n])
PVar i -> prPrec _i 1 (concatD [prt 0 i])
PWild -> prPrec _i 1 (concatD [doc (showString "_")])
FieldPattern i pattern -> prPrec _i 0 (concatD [prt 0 i , doc (showString "=") , prt 0 pattern])
ELet letdefs exp -> prPrec _i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 letdefs , doc (showString "}") , doc (showString "in") , prt 0 exp])
ECase exp cases -> prPrec _i 0 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
EIf exp0 exp1 exp2 -> prPrec _i 0 (concatD [doc (showString "if") , prt 0 exp0 , doc (showString "then") , prt 0 exp1 , doc (showString "else") , prt 0 exp2])
EAbs varorwild exp -> prPrec _i 2 (concatD [doc (showString "\\") , prt 0 varorwild , doc (showString "->") , prt 0 exp])
EPi varorwild exp0 exp1 -> prPrec _i 2 (concatD [doc (showString "(") , prt 0 varorwild , doc (showString ":") , prt 0 exp0 , doc (showString ")") , doc (showString "->") , prt 0 exp1])
EPiNoVar exp0 exp1 -> prPrec _i 2 (concatD [prt 3 exp0 , doc (showString "->") , prt 0 exp1])
EOr exp0 exp1 -> prPrec _i 3 (concatD [prt 4 exp0 , doc (showString "||") , prt 3 exp1])
EAnd exp0 exp1 -> prPrec _i 4 (concatD [prt 5 exp0 , doc (showString "&&") , prt 4 exp1])
EEq exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "==") , prt 6 exp1])
ENe exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "/=") , prt 6 exp1])
ELt exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "<") , prt 6 exp1])
ELe exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "<=") , prt 6 exp1])
EGt exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString ">") , prt 6 exp1])
EGe exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString ">=") , prt 6 exp1])
EAdd exp0 exp1 -> prPrec _i 6 (concatD [prt 6 exp0 , doc (showString "+") , prt 7 exp1])
ESub exp0 exp1 -> prPrec _i 6 (concatD [prt 6 exp0 , doc (showString "-") , prt 7 exp1])
EMul exp0 exp1 -> prPrec _i 7 (concatD [prt 7 exp0 , doc (showString "*") , prt 8 exp1])
EDiv exp0 exp1 -> prPrec _i 7 (concatD [prt 7 exp0 , doc (showString "/") , prt 8 exp1])
EMod exp0 exp1 -> prPrec _i 7 (concatD [prt 7 exp0 , doc (showString "%") , prt 8 exp1])
EProj exp i -> prPrec _i 8 (concatD [prt 8 exp , doc (showString ".") , prt 0 i])
ENeg exp -> prPrec _i 9 (concatD [doc (showString "-") , prt 9 exp])
EApp exp0 exp1 -> prPrec _i 10 (concatD [prt 10 exp0 , prt 11 exp1])
EEmptyRec -> prPrec _i 11 (concatD [doc (showString "{") , doc (showString "}")])
ERecType fieldtypes -> prPrec _i 11 (concatD [doc (showString "{") , prt 0 fieldtypes , doc (showString "}")])
ERec fieldvalues -> prPrec _i 11 (concatD [doc (showString "{") , prt 0 fieldvalues , doc (showString "}")])
EVar i -> prPrec _i 11 (concatD [prt 0 i])
EType -> prPrec _i 11 (concatD [doc (showString "Type")])
EStr str -> prPrec _i 11 (concatD [prt 0 str])
EInt n -> prPrec _i 11 (concatD [prt 0 n])
LetDef i exp0 exp1 -> prPrec _i 0 (concatD [prt 0 i , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp1])
Case pattern exp -> prPrec _i 0 (concatD [prt 0 pattern , doc (showString "->") , prt 0 exp])
VVar i -> prPrec _i 0 (concatD [prt 0 i])
VWild -> prPrec _i 0 (concatD [doc (showString "_")])
FieldType i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString ":") , prt 0 exp])
FieldValue i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString "=") , prt 0 exp])
Ident str -> prPrec _i 0 (doc (showString str))
instance Print [Import] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [Decl] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [ConsDecl] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [Pattern] where
prt _ es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 1 x , prt 0 xs])
instance Print [FieldPattern] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [LetDef] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [Case] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [FieldType] where
prt _ es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [FieldValue] where
prt _ es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])

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

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

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

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

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

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

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

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