mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-11 13:59:31 -06:00
removed Transfer interpreter
This commit is contained in:
aarne
@@ -1,75 +0,0 @@
|
||||
module Transfer.CompilerAPI 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 Data.List
|
||||
import System.Directory
|
||||
|
||||
|
||||
-- | Compile a source module file to a a code file.
|
||||
compileFile :: [FilePath] -- ^ directories to look for imported modules in
|
||||
-> FilePath -- ^ source module file
|
||||
-> IO FilePath -- ^ path to the core file that was written
|
||||
compileFile path f = do
|
||||
ds <- loadModule path f
|
||||
s <- compile ds
|
||||
writeFile coreFile s
|
||||
return coreFile
|
||||
where coreFile = replaceFilenameSuffix f "trc"
|
||||
|
||||
-- | Compile a self-contained list of declarations to a core program.
|
||||
compile :: Monad m => [Decl] -> m String
|
||||
compile m = return (printTree $ declsToCore m)
|
||||
|
||||
-- | Load a source module file and all its dependencies.
|
||||
loadModule :: [FilePath] -- ^ directories to look for imported modules in
|
||||
-> FilePath -- ^ source module file
|
||||
-> IO [Decl]
|
||||
loadModule = loadModule_ []
|
||||
where
|
||||
loadModule_ ms path f =
|
||||
do
|
||||
s <- readFile f
|
||||
Module is ds <- case pModule (myLLexer s) of
|
||||
Bad e -> fail $ "Parse error in " ++ f ++ ": " ++ e
|
||||
Ok m -> return m
|
||||
let load = [ i | Import (Ident i) <- is ] \\ ms
|
||||
let path' = directoryOf f : path
|
||||
files <- mapM (findFile path' . (++".tra")) load
|
||||
dss <- mapM (loadModule_ (load++ms) path) files
|
||||
return $ concat (dss++[ds])
|
||||
|
||||
myLLexer :: String -> [Token]
|
||||
myLLexer = resolveLayout True . myLexer
|
||||
|
||||
-- | Find a file in one of the given directories.
|
||||
-- Fails if the file was not found.
|
||||
findFile :: [FilePath] -- ^ directories to look in
|
||||
-> FilePath -- ^ file name to find
|
||||
-> IO FilePath
|
||||
findFile path f =
|
||||
do
|
||||
mf <- findFileM path f
|
||||
case mf of
|
||||
Nothing -> fail $ f ++ " not found in path: " ++ show path
|
||||
Just f' -> return f'
|
||||
|
||||
-- | Find a file in one of the given directories.
|
||||
findFileM :: [FilePath] -- ^ directories to look in
|
||||
-> FilePath -- ^ file name to find
|
||||
-> IO (Maybe FilePath)
|
||||
findFileM [] _ = return Nothing
|
||||
findFileM (p:ps) f =
|
||||
do
|
||||
let f' = p ++ "/" ++ f
|
||||
e <- doesFileExist f'
|
||||
if e then return (Just f') else findFileM ps f
|
||||
@@ -1,267 +0,0 @@
|
||||
{-# OPTIONS_GHC -fglasgow-exts #-}
|
||||
module Transfer.Core.Abs (Tree(..), Module, Decl, ConsDecl, Pattern, FieldPattern, PatternVariable, Exp, LetDef, Case, FieldType, FieldValue, TMeta, CIdent, composOp, composOpM, composOpM_, composOpMPlus, composOpMonoid, composOpFold, compos, johnMajorEq) where
|
||||
|
||||
import Control.Monad (ap,MonadPlus,msum,mplus,mzero)
|
||||
import Control.Monad.Identity
|
||||
import Data.Monoid
|
||||
|
||||
-- Haskell module generated by the BNF converter
|
||||
|
||||
data Module_
|
||||
type Module = Tree Module_
|
||||
data Decl_
|
||||
type Decl = Tree Decl_
|
||||
data ConsDecl_
|
||||
type ConsDecl = Tree ConsDecl_
|
||||
data Pattern_
|
||||
type Pattern = Tree Pattern_
|
||||
data FieldPattern_
|
||||
type FieldPattern = Tree FieldPattern_
|
||||
data PatternVariable_
|
||||
type PatternVariable = Tree PatternVariable_
|
||||
data Exp_
|
||||
type Exp = Tree Exp_
|
||||
data LetDef_
|
||||
type LetDef = Tree LetDef_
|
||||
data Case_
|
||||
type Case = Tree Case_
|
||||
data FieldType_
|
||||
type FieldType = Tree FieldType_
|
||||
data FieldValue_
|
||||
type FieldValue = Tree FieldValue_
|
||||
data TMeta_
|
||||
type TMeta = Tree TMeta_
|
||||
data CIdent_
|
||||
type CIdent = Tree CIdent_
|
||||
|
||||
data Tree :: * -> * where
|
||||
Module :: [Decl] -> Tree Module_
|
||||
DataDecl :: CIdent -> Exp -> [ConsDecl] -> Tree Decl_
|
||||
TypeDecl :: CIdent -> Exp -> Tree Decl_
|
||||
ValueDecl :: CIdent -> Exp -> Tree Decl_
|
||||
ConsDecl :: CIdent -> Exp -> Tree ConsDecl_
|
||||
PCons :: CIdent -> [Pattern] -> Tree Pattern_
|
||||
PVar :: PatternVariable -> Tree Pattern_
|
||||
PRec :: [FieldPattern] -> Tree Pattern_
|
||||
PStr :: String -> Tree Pattern_
|
||||
PInt :: Integer -> Tree Pattern_
|
||||
FieldPattern :: CIdent -> Pattern -> Tree FieldPattern_
|
||||
PVVar :: CIdent -> Tree PatternVariable_
|
||||
PVWild :: Tree PatternVariable_
|
||||
ELet :: [LetDef] -> Exp -> Tree Exp_
|
||||
ECase :: Exp -> [Case] -> Tree Exp_
|
||||
EAbs :: PatternVariable -> Exp -> Tree Exp_
|
||||
EPi :: PatternVariable -> Exp -> Exp -> Tree Exp_
|
||||
EApp :: Exp -> Exp -> Tree Exp_
|
||||
EProj :: Exp -> CIdent -> Tree Exp_
|
||||
ERecType :: [FieldType] -> Tree Exp_
|
||||
ERec :: [FieldValue] -> Tree Exp_
|
||||
EVar :: CIdent -> Tree Exp_
|
||||
EType :: Tree Exp_
|
||||
EStr :: String -> Tree Exp_
|
||||
EInteger :: Integer -> Tree Exp_
|
||||
EDouble :: Double -> Tree Exp_
|
||||
EMeta :: TMeta -> Tree Exp_
|
||||
LetDef :: CIdent -> Exp -> Tree LetDef_
|
||||
Case :: Pattern -> Exp -> Exp -> Tree Case_
|
||||
FieldType :: CIdent -> Exp -> Tree FieldType_
|
||||
FieldValue :: CIdent -> Exp -> Tree FieldValue_
|
||||
TMeta :: String -> Tree TMeta_
|
||||
CIdent :: String -> Tree CIdent_
|
||||
|
||||
composOp :: (forall a. Tree a -> Tree a) -> Tree c -> Tree c
|
||||
composOp f = runIdentity . composOpM (Identity . f)
|
||||
|
||||
composOpM :: Monad m => (forall a. Tree a -> m (Tree a)) -> Tree c -> m (Tree c)
|
||||
composOpM = compos return ap
|
||||
|
||||
composOpM_ :: Monad m => (forall a. Tree a -> m ()) -> Tree c -> m ()
|
||||
composOpM_ = composOpFold (return ()) (>>)
|
||||
|
||||
composOpMPlus :: MonadPlus m => (forall a. Tree a -> m b) -> Tree c -> m b
|
||||
composOpMPlus = composOpFold mzero mplus
|
||||
|
||||
composOpMonoid :: Monoid m => (forall a. Tree a -> m) -> Tree c -> m
|
||||
composOpMonoid = composOpFold mempty mappend
|
||||
|
||||
newtype C b a = C { unC :: b }
|
||||
composOpFold :: b -> (b -> b -> b) -> (forall a. Tree a -> b) -> Tree c -> b
|
||||
composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)
|
||||
|
||||
compos :: (forall a. a -> m a)
|
||||
-> (forall a b. m (a -> b) -> m a -> m b)
|
||||
-> (forall a. Tree a -> m (Tree a)) -> Tree c -> m (Tree c)
|
||||
compos r a f t = case t of
|
||||
Module decls -> r Module `a` foldr (a . a (r (:)) . f) (r []) decls
|
||||
DataDecl cident exp consdecls -> r DataDecl `a` f cident `a` f exp `a` foldr (a . a (r (:)) . f) (r []) consdecls
|
||||
TypeDecl cident exp -> r TypeDecl `a` f cident `a` f exp
|
||||
ValueDecl cident exp -> r ValueDecl `a` f cident `a` f exp
|
||||
ConsDecl cident exp -> r ConsDecl `a` f cident `a` f exp
|
||||
PCons cident patterns -> r PCons `a` f cident `a` foldr (a . a (r (:)) . f) (r []) patterns
|
||||
PVar patternvariable -> r PVar `a` f patternvariable
|
||||
PRec fieldpatterns -> r PRec `a` foldr (a . a (r (:)) . f) (r []) fieldpatterns
|
||||
FieldPattern cident pattern -> r FieldPattern `a` f cident `a` f pattern
|
||||
PVVar cident -> r PVVar `a` f cident
|
||||
ELet letdefs exp -> r ELet `a` foldr (a . a (r (:)) . f) (r []) letdefs `a` f exp
|
||||
ECase exp cases -> r ECase `a` f exp `a` foldr (a . a (r (:)) . f) (r []) cases
|
||||
EAbs patternvariable exp -> r EAbs `a` f patternvariable `a` f exp
|
||||
EPi patternvariable exp0 exp1 -> r EPi `a` f patternvariable `a` f exp0 `a` f exp1
|
||||
EApp exp0 exp1 -> r EApp `a` f exp0 `a` f exp1
|
||||
EProj exp cident -> r EProj `a` f exp `a` f cident
|
||||
ERecType fieldtypes -> r ERecType `a` foldr (a . a (r (:)) . f) (r []) fieldtypes
|
||||
ERec fieldvalues -> r ERec `a` foldr (a . a (r (:)) . f) (r []) fieldvalues
|
||||
EVar cident -> r EVar `a` f cident
|
||||
EMeta tmeta -> r EMeta `a` f tmeta
|
||||
LetDef cident exp -> r LetDef `a` f cident `a` f exp
|
||||
Case pattern exp0 exp1 -> r Case `a` f pattern `a` f exp0 `a` f exp1
|
||||
FieldType cident exp -> r FieldType `a` f cident `a` f exp
|
||||
FieldValue cident exp -> r FieldValue `a` f cident `a` f exp
|
||||
_ -> r t
|
||||
|
||||
instance Show (Tree c) where
|
||||
showsPrec n t = case t of
|
||||
Module decls -> opar n . showString "Module" . showChar ' ' . showsPrec 1 decls . cpar n
|
||||
DataDecl cident exp consdecls -> opar n . showString "DataDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 consdecls . cpar n
|
||||
TypeDecl cident exp -> opar n . showString "TypeDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
ValueDecl cident exp -> opar n . showString "ValueDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
ConsDecl cident exp -> opar n . showString "ConsDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
PCons cident patterns -> opar n . showString "PCons" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 patterns . cpar n
|
||||
PVar patternvariable -> opar n . showString "PVar" . showChar ' ' . showsPrec 1 patternvariable . cpar n
|
||||
PRec fieldpatterns -> opar n . showString "PRec" . showChar ' ' . showsPrec 1 fieldpatterns . cpar n
|
||||
PStr str -> opar n . showString "PStr" . showChar ' ' . showsPrec 1 str . cpar n
|
||||
PInt n -> opar n . showString "PInt" . showChar ' ' . showsPrec 1 n . cpar n
|
||||
FieldPattern cident pattern -> opar n . showString "FieldPattern" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 pattern . cpar n
|
||||
PVVar cident -> opar n . showString "PVVar" . showChar ' ' . showsPrec 1 cident . cpar n
|
||||
PVWild -> showString "PVWild"
|
||||
ELet letdefs exp -> opar n . showString "ELet" . showChar ' ' . showsPrec 1 letdefs . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
ECase exp cases -> opar n . showString "ECase" . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 cases . cpar n
|
||||
EAbs patternvariable exp -> opar n . showString "EAbs" . showChar ' ' . showsPrec 1 patternvariable . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
EPi patternvariable exp0 exp1 -> opar n . showString "EPi" . showChar ' ' . showsPrec 1 patternvariable . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
|
||||
EApp exp0 exp1 -> opar n . showString "EApp" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
|
||||
EProj exp cident -> opar n . showString "EProj" . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 cident . cpar n
|
||||
ERecType fieldtypes -> opar n . showString "ERecType" . showChar ' ' . showsPrec 1 fieldtypes . cpar n
|
||||
ERec fieldvalues -> opar n . showString "ERec" . showChar ' ' . showsPrec 1 fieldvalues . cpar n
|
||||
EVar cident -> opar n . showString "EVar" . showChar ' ' . showsPrec 1 cident . cpar n
|
||||
EType -> showString "EType"
|
||||
EStr str -> opar n . showString "EStr" . showChar ' ' . showsPrec 1 str . cpar n
|
||||
EInteger n -> opar n . showString "EInteger" . showChar ' ' . showsPrec 1 n . cpar n
|
||||
EDouble d -> opar n . showString "EDouble" . showChar ' ' . showsPrec 1 d . cpar n
|
||||
EMeta tmeta -> opar n . showString "EMeta" . showChar ' ' . showsPrec 1 tmeta . cpar n
|
||||
LetDef cident exp -> opar n . showString "LetDef" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
Case pattern exp0 exp1 -> opar n . showString "Case" . showChar ' ' . showsPrec 1 pattern . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
|
||||
FieldType cident exp -> opar n . showString "FieldType" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
FieldValue cident exp -> opar n . showString "FieldValue" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
TMeta str -> opar n . showString "TMeta" . showChar ' ' . showsPrec 1 str . cpar n
|
||||
CIdent str -> opar n . showString "CIdent" . showChar ' ' . showsPrec 1 str . cpar n
|
||||
where opar n = if n > 0 then showChar '(' else id
|
||||
cpar n = if n > 0 then showChar ')' else id
|
||||
|
||||
instance Eq (Tree c) where (==) = johnMajorEq
|
||||
|
||||
johnMajorEq :: Tree a -> Tree b -> Bool
|
||||
johnMajorEq (Module decls) (Module decls_) = decls == decls_
|
||||
johnMajorEq (DataDecl cident exp consdecls) (DataDecl cident_ exp_ consdecls_) = cident == cident_ && exp == exp_ && consdecls == consdecls_
|
||||
johnMajorEq (TypeDecl cident exp) (TypeDecl cident_ exp_) = cident == cident_ && exp == exp_
|
||||
johnMajorEq (ValueDecl cident exp) (ValueDecl cident_ exp_) = cident == cident_ && exp == exp_
|
||||
johnMajorEq (ConsDecl cident exp) (ConsDecl cident_ exp_) = cident == cident_ && exp == exp_
|
||||
johnMajorEq (PCons cident patterns) (PCons cident_ patterns_) = cident == cident_ && patterns == patterns_
|
||||
johnMajorEq (PVar patternvariable) (PVar patternvariable_) = patternvariable == patternvariable_
|
||||
johnMajorEq (PRec fieldpatterns) (PRec fieldpatterns_) = fieldpatterns == fieldpatterns_
|
||||
johnMajorEq (PStr str) (PStr str_) = str == str_
|
||||
johnMajorEq (PInt n) (PInt n_) = n == n_
|
||||
johnMajorEq (FieldPattern cident pattern) (FieldPattern cident_ pattern_) = cident == cident_ && pattern == pattern_
|
||||
johnMajorEq (PVVar cident) (PVVar cident_) = cident == cident_
|
||||
johnMajorEq PVWild PVWild = True
|
||||
johnMajorEq (ELet letdefs exp) (ELet letdefs_ exp_) = letdefs == letdefs_ && exp == exp_
|
||||
johnMajorEq (ECase exp cases) (ECase exp_ cases_) = exp == exp_ && cases == cases_
|
||||
johnMajorEq (EAbs patternvariable exp) (EAbs patternvariable_ exp_) = patternvariable == patternvariable_ && exp == exp_
|
||||
johnMajorEq (EPi patternvariable exp0 exp1) (EPi patternvariable_ exp0_ exp1_) = patternvariable == patternvariable_ && exp0 == exp0_ && exp1 == exp1_
|
||||
johnMajorEq (EApp exp0 exp1) (EApp exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
|
||||
johnMajorEq (EProj exp cident) (EProj exp_ cident_) = exp == exp_ && cident == cident_
|
||||
johnMajorEq (ERecType fieldtypes) (ERecType fieldtypes_) = fieldtypes == fieldtypes_
|
||||
johnMajorEq (ERec fieldvalues) (ERec fieldvalues_) = fieldvalues == fieldvalues_
|
||||
johnMajorEq (EVar cident) (EVar cident_) = cident == cident_
|
||||
johnMajorEq EType EType = True
|
||||
johnMajorEq (EStr str) (EStr str_) = str == str_
|
||||
johnMajorEq (EInteger n) (EInteger n_) = n == n_
|
||||
johnMajorEq (EDouble d) (EDouble d_) = d == d_
|
||||
johnMajorEq (EMeta tmeta) (EMeta tmeta_) = tmeta == tmeta_
|
||||
johnMajorEq (LetDef cident exp) (LetDef cident_ exp_) = cident == cident_ && exp == exp_
|
||||
johnMajorEq (Case pattern exp0 exp1) (Case pattern_ exp0_ exp1_) = pattern == pattern_ && exp0 == exp0_ && exp1 == exp1_
|
||||
johnMajorEq (FieldType cident exp) (FieldType cident_ exp_) = cident == cident_ && exp == exp_
|
||||
johnMajorEq (FieldValue cident exp) (FieldValue cident_ exp_) = cident == cident_ && exp == exp_
|
||||
johnMajorEq (TMeta str) (TMeta str_) = str == str_
|
||||
johnMajorEq (CIdent str) (CIdent str_) = str == str_
|
||||
johnMajorEq _ _ = False
|
||||
|
||||
instance Ord (Tree c) where
|
||||
compare x y = compare (index x) (index y) `mappend` compareSame x y
|
||||
index :: Tree c -> Int
|
||||
index (Module _) = 0
|
||||
index (DataDecl _ _ _) = 1
|
||||
index (TypeDecl _ _) = 2
|
||||
index (ValueDecl _ _) = 3
|
||||
index (ConsDecl _ _) = 4
|
||||
index (PCons _ _) = 5
|
||||
index (PVar _) = 6
|
||||
index (PRec _) = 7
|
||||
index (PStr _) = 8
|
||||
index (PInt _) = 9
|
||||
index (FieldPattern _ _) = 10
|
||||
index (PVVar _) = 11
|
||||
index (PVWild ) = 12
|
||||
index (ELet _ _) = 13
|
||||
index (ECase _ _) = 14
|
||||
index (EAbs _ _) = 15
|
||||
index (EPi _ _ _) = 16
|
||||
index (EApp _ _) = 17
|
||||
index (EProj _ _) = 18
|
||||
index (ERecType _) = 19
|
||||
index (ERec _) = 20
|
||||
index (EVar _) = 21
|
||||
index (EType ) = 22
|
||||
index (EStr _) = 23
|
||||
index (EInteger _) = 24
|
||||
index (EDouble _) = 25
|
||||
index (EMeta _) = 26
|
||||
index (LetDef _ _) = 27
|
||||
index (Case _ _ _) = 28
|
||||
index (FieldType _ _) = 29
|
||||
index (FieldValue _ _) = 30
|
||||
index (TMeta _) = 31
|
||||
index (CIdent _) = 32
|
||||
compareSame :: Tree c -> Tree c -> Ordering
|
||||
compareSame (Module decls) (Module decls_) = compare decls decls_
|
||||
compareSame (DataDecl cident exp consdecls) (DataDecl cident_ exp_ consdecls_) = mappend (compare cident cident_) (mappend (compare exp exp_) (compare consdecls consdecls_))
|
||||
compareSame (TypeDecl cident exp) (TypeDecl cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
|
||||
compareSame (ValueDecl cident exp) (ValueDecl cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
|
||||
compareSame (ConsDecl cident exp) (ConsDecl cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
|
||||
compareSame (PCons cident patterns) (PCons cident_ patterns_) = mappend (compare cident cident_) (compare patterns patterns_)
|
||||
compareSame (PVar patternvariable) (PVar patternvariable_) = compare patternvariable patternvariable_
|
||||
compareSame (PRec fieldpatterns) (PRec fieldpatterns_) = compare fieldpatterns fieldpatterns_
|
||||
compareSame (PStr str) (PStr str_) = compare str str_
|
||||
compareSame (PInt n) (PInt n_) = compare n n_
|
||||
compareSame (FieldPattern cident pattern) (FieldPattern cident_ pattern_) = mappend (compare cident cident_) (compare pattern pattern_)
|
||||
compareSame (PVVar cident) (PVVar cident_) = compare cident cident_
|
||||
compareSame PVWild PVWild = EQ
|
||||
compareSame (ELet letdefs exp) (ELet letdefs_ exp_) = mappend (compare letdefs letdefs_) (compare exp exp_)
|
||||
compareSame (ECase exp cases) (ECase exp_ cases_) = mappend (compare exp exp_) (compare cases cases_)
|
||||
compareSame (EAbs patternvariable exp) (EAbs patternvariable_ exp_) = mappend (compare patternvariable patternvariable_) (compare exp exp_)
|
||||
compareSame (EPi patternvariable exp0 exp1) (EPi patternvariable_ exp0_ exp1_) = mappend (compare patternvariable patternvariable_) (mappend (compare exp0 exp0_) (compare exp1 exp1_))
|
||||
compareSame (EApp exp0 exp1) (EApp exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
|
||||
compareSame (EProj exp cident) (EProj exp_ cident_) = mappend (compare exp exp_) (compare cident cident_)
|
||||
compareSame (ERecType fieldtypes) (ERecType fieldtypes_) = compare fieldtypes fieldtypes_
|
||||
compareSame (ERec fieldvalues) (ERec fieldvalues_) = compare fieldvalues fieldvalues_
|
||||
compareSame (EVar cident) (EVar cident_) = compare cident cident_
|
||||
compareSame EType EType = EQ
|
||||
compareSame (EStr str) (EStr str_) = compare str str_
|
||||
compareSame (EInteger n) (EInteger n_) = compare n n_
|
||||
compareSame (EDouble d) (EDouble d_) = compare d d_
|
||||
compareSame (EMeta tmeta) (EMeta tmeta_) = compare tmeta tmeta_
|
||||
compareSame (LetDef cident exp) (LetDef cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
|
||||
compareSame (Case pattern exp0 exp1) (Case pattern_ exp0_ exp1_) = mappend (compare pattern pattern_) (mappend (compare exp0 exp0_) (compare exp1 exp1_))
|
||||
compareSame (FieldType cident exp) (FieldType cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
|
||||
compareSame (FieldValue cident exp) (FieldValue cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
|
||||
compareSame (TMeta str) (TMeta str_) = compare str str_
|
||||
compareSame (CIdent str) (CIdent str_) = compare str str_
|
||||
compareSame x y = error "BNFC error:" compareSame
|
||||
@@ -1,93 +0,0 @@
|
||||
-- This is a subset of the front-end language
|
||||
|
||||
entrypoints Module, Exp ;
|
||||
|
||||
comment "--" ;
|
||||
comment "{-" "-}" ;
|
||||
|
||||
Module. Module ::= [Decl] ;
|
||||
separator Decl ";" ;
|
||||
|
||||
DataDecl. Decl ::= "data" CIdent ":" Exp "where" "{" [ConsDecl] "}" ;
|
||||
TypeDecl. Decl ::= CIdent ":" Exp ;
|
||||
ValueDecl. Decl ::= CIdent "=" Exp ;
|
||||
|
||||
ConsDecl. ConsDecl ::= CIdent ":" Exp ;
|
||||
separator ConsDecl ";" ;
|
||||
|
||||
separator Pattern "";
|
||||
|
||||
-- Constructor patterns.
|
||||
PCons. Pattern ::= "(" CIdent [Pattern] ")" ;
|
||||
|
||||
-- Variable patterns. Note that in the core language,
|
||||
-- constructor patterns must have parantheses.
|
||||
PVar. Pattern ::= PatternVariable ;
|
||||
-- Record patterns.
|
||||
PRec. Pattern ::= "rec" "{" [FieldPattern] "}";
|
||||
-- String literal patterns.
|
||||
PStr. Pattern ::= String ;
|
||||
-- Integer literal patterns.
|
||||
PInt. Pattern ::= Integer ;
|
||||
|
||||
FieldPattern. FieldPattern ::= CIdent "=" Pattern ;
|
||||
separator FieldPattern ";" ;
|
||||
|
||||
-- Variable patterns
|
||||
PVVar. PatternVariable ::= CIdent ;
|
||||
-- Wild card patterns
|
||||
PVWild. PatternVariable ::= "_" ;
|
||||
|
||||
-- Let expressions.
|
||||
ELet. Exp ::= "let" "{" [LetDef] "}" "in" Exp ;
|
||||
LetDef. LetDef ::= CIdent "=" Exp ;
|
||||
separator LetDef ";" ;
|
||||
|
||||
-- Case expressions.
|
||||
ECase. Exp ::= "case" Exp "of" "{" [Case] "}" ;
|
||||
Case. Case ::= Pattern "|" Exp "->" Exp ;
|
||||
separator Case ";" ;
|
||||
|
||||
-- Lambda abstractions.
|
||||
EAbs. Exp1 ::= "\\" PatternVariable "->" Exp ;
|
||||
-- Function types.
|
||||
EPi. Exp1 ::= "(" PatternVariable ":" Exp ")" "->" Exp ;
|
||||
|
||||
-- Function application.
|
||||
EApp. Exp3 ::= Exp3 Exp4 ;
|
||||
|
||||
-- Record field projection.
|
||||
EProj. Exp4 ::= Exp4 "." CIdent ;
|
||||
|
||||
-- Record types.
|
||||
ERecType. Exp5 ::= "sig" "{" [FieldType] "}" ;
|
||||
FieldType. FieldType ::= CIdent ":" Exp ;
|
||||
separator FieldType ";" ;
|
||||
|
||||
-- Record expressions.
|
||||
ERec. Exp5 ::= "rec" "{" [FieldValue] "}" ;
|
||||
FieldValue.FieldValue ::= CIdent "=" Exp ;
|
||||
separator FieldValue ";" ;
|
||||
|
||||
|
||||
-- Functions, constructors and local variables.
|
||||
EVar. Exp5 ::= CIdent ;
|
||||
-- The constant Type.
|
||||
EType. Exp5 ::= "Type" ;
|
||||
-- String literal expressions.
|
||||
EStr. Exp5 ::= String ;
|
||||
-- Integer literal expressions.
|
||||
EInteger. Exp5 ::= Integer ;
|
||||
-- Double literal expressions.
|
||||
EDouble. Exp5 ::= Double ;
|
||||
-- Meta variables
|
||||
EMeta. Exp5 ::= TMeta ;
|
||||
|
||||
token TMeta ('?' digit+) ;
|
||||
|
||||
coercions Exp 5 ;
|
||||
|
||||
|
||||
-- Identifiers in core can start with underscore to allow
|
||||
-- generating unique identifiers easily.
|
||||
token CIdent ((letter | '_') (letter | digit | '_' | '\'')*) ;
|
||||
@@ -1,215 +0,0 @@
|
||||
\batchmode
|
||||
%This Latex file is machine-generated by the BNF-converter
|
||||
|
||||
\documentclass[a4paper,11pt]{article}
|
||||
\author{BNF-converter}
|
||||
\title{The Language Core}
|
||||
\setlength{\parindent}{0mm}
|
||||
\setlength{\parskip}{1mm}
|
||||
\begin{document}
|
||||
|
||||
\maketitle
|
||||
|
||||
\newcommand{\emptyP}{\mbox{$\epsilon$}}
|
||||
\newcommand{\terminal}[1]{\mbox{{\texttt {#1}}}}
|
||||
\newcommand{\nonterminal}[1]{\mbox{$\langle \mbox{{\sl #1 }} \! \rangle$}}
|
||||
\newcommand{\arrow}{\mbox{::=}}
|
||||
\newcommand{\delimit}{\mbox{$|$}}
|
||||
\newcommand{\reserved}[1]{\mbox{{\texttt {#1}}}}
|
||||
\newcommand{\literal}[1]{\mbox{{\texttt {#1}}}}
|
||||
\newcommand{\symb}[1]{\mbox{{\texttt {#1}}}}
|
||||
|
||||
This document was automatically generated by the {\em BNF-Converter}. It was generated together with the lexer, the parser, and the abstract syntax module, which guarantees that the document matches with the implementation of the language (provided no hand-hacking has taken place).
|
||||
|
||||
\section*{The lexical structure of Core}
|
||||
|
||||
\subsection*{Literals}
|
||||
String literals \nonterminal{String}\ have the form
|
||||
\terminal{"}$x$\terminal{"}, where $x$ is any sequence of any characters
|
||||
except \terminal{"}\ unless preceded by \verb6\6.
|
||||
|
||||
|
||||
Integer literals \nonterminal{Int}\ are nonempty sequences of digits.
|
||||
|
||||
|
||||
Double-precision float literals \nonterminal{Double}\ have the structure
|
||||
indicated by the regular expression $\nonterminal{digit}+ \mbox{{\it `.'}} \nonterminal{digit}+ (\mbox{{\it `e'}} \mbox{{\it `-'}}? \nonterminal{digit}+)?$ i.e.\
|
||||
two sequences of digits separated by a decimal point, optionally
|
||||
followed by an unsigned or negative exponent.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
TMeta literals are recognized by the regular expression
|
||||
\(\mbox{`?'} {\nonterminal{digit}}+\)
|
||||
|
||||
CIdent literals are recognized by the regular expression
|
||||
\(({\nonterminal{letter}} \mid \mbox{`\_'}) ({\nonterminal{letter}} \mid {\nonterminal{digit}} \mid \mbox{`\_'} \mid \mbox{`''})*\)
|
||||
|
||||
|
||||
\subsection*{Reserved words and symbols}
|
||||
The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions.
|
||||
|
||||
The reserved words used in Core are the following: \\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\reserved{Type}} &{\reserved{case}} &{\reserved{data}} \\
|
||||
{\reserved{in}} &{\reserved{let}} &{\reserved{of}} \\
|
||||
{\reserved{rec}} &{\reserved{sig}} &{\reserved{where}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
The symbols used in Core are the following: \\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\symb{;}} &{\symb{:}} &{\symb{\{}} \\
|
||||
{\symb{\}}} &{\symb{{$=$}}} &{\symb{(}} \\
|
||||
{\symb{)}} &{\symb{\_}} &{\symb{{$|$}}} \\
|
||||
{\symb{{$-$}{$>$}}} &{\symb{$\backslash$}} &{\symb{.}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\subsection*{Comments}
|
||||
Single-line comments begin with {\symb{{$-$}{$-$}}}. \\Multiple-line comments are enclosed with {\symb{\{{$-$}}} and {\symb{{$-$}\}}}.
|
||||
|
||||
\section*{The syntactic structure of Core}
|
||||
Non-terminals are enclosed between $\langle$ and $\rangle$.
|
||||
The symbols {\arrow} (production), {\delimit} (union)
|
||||
and {\emptyP} (empty rule) belong to the BNF notation.
|
||||
All other symbols are terminals.\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Module}} & {\arrow} &{\nonterminal{ListDecl}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListDecl}} & {\arrow} &{\emptyP} \\
|
||||
& {\delimit} &{\nonterminal{Decl}} \\
|
||||
& {\delimit} &{\nonterminal{Decl}} {\terminal{;}} {\nonterminal{ListDecl}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Decl}} & {\arrow} &{\terminal{data}} {\nonterminal{CIdent}} {\terminal{:}} {\nonterminal{Exp}} {\terminal{where}} {\terminal{\{}} {\nonterminal{ListConsDecl}} {\terminal{\}}} \\
|
||||
& {\delimit} &{\nonterminal{CIdent}} {\terminal{:}} {\nonterminal{Exp}} \\
|
||||
& {\delimit} &{\nonterminal{CIdent}} {\terminal{{$=$}}} {\nonterminal{Exp}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ConsDecl}} & {\arrow} &{\nonterminal{CIdent}} {\terminal{:}} {\nonterminal{Exp}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListConsDecl}} & {\arrow} &{\emptyP} \\
|
||||
& {\delimit} &{\nonterminal{ConsDecl}} \\
|
||||
& {\delimit} &{\nonterminal{ConsDecl}} {\terminal{;}} {\nonterminal{ListConsDecl}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListPattern}} & {\arrow} &{\emptyP} \\
|
||||
& {\delimit} &{\nonterminal{Pattern}} {\nonterminal{ListPattern}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Pattern}} & {\arrow} &{\terminal{(}} {\nonterminal{CIdent}} {\nonterminal{ListPattern}} {\terminal{)}} \\
|
||||
& {\delimit} &{\nonterminal{PatternVariable}} \\
|
||||
& {\delimit} &{\terminal{rec}} {\terminal{\{}} {\nonterminal{ListFieldPattern}} {\terminal{\}}} \\
|
||||
& {\delimit} &{\nonterminal{String}} \\
|
||||
& {\delimit} &{\nonterminal{Integer}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{FieldPattern}} & {\arrow} &{\nonterminal{CIdent}} {\terminal{{$=$}}} {\nonterminal{Pattern}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListFieldPattern}} & {\arrow} &{\emptyP} \\
|
||||
& {\delimit} &{\nonterminal{FieldPattern}} \\
|
||||
& {\delimit} &{\nonterminal{FieldPattern}} {\terminal{;}} {\nonterminal{ListFieldPattern}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{PatternVariable}} & {\arrow} &{\nonterminal{CIdent}} \\
|
||||
& {\delimit} &{\terminal{\_}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp}} & {\arrow} &{\terminal{let}} {\terminal{\{}} {\nonterminal{ListLetDef}} {\terminal{\}}} {\terminal{in}} {\nonterminal{Exp}} \\
|
||||
& {\delimit} &{\terminal{case}} {\nonterminal{Exp}} {\terminal{of}} {\terminal{\{}} {\nonterminal{ListCase}} {\terminal{\}}} \\
|
||||
& {\delimit} &{\nonterminal{Exp1}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{LetDef}} & {\arrow} &{\nonterminal{CIdent}} {\terminal{{$=$}}} {\nonterminal{Exp}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListLetDef}} & {\arrow} &{\emptyP} \\
|
||||
& {\delimit} &{\nonterminal{LetDef}} \\
|
||||
& {\delimit} &{\nonterminal{LetDef}} {\terminal{;}} {\nonterminal{ListLetDef}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Case}} & {\arrow} &{\nonterminal{Pattern}} {\terminal{{$|$}}} {\nonterminal{Exp}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListCase}} & {\arrow} &{\emptyP} \\
|
||||
& {\delimit} &{\nonterminal{Case}} \\
|
||||
& {\delimit} &{\nonterminal{Case}} {\terminal{;}} {\nonterminal{ListCase}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp1}} & {\arrow} &{\terminal{$\backslash$}} {\nonterminal{PatternVariable}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}} \\
|
||||
& {\delimit} &{\terminal{(}} {\nonterminal{PatternVariable}} {\terminal{:}} {\nonterminal{Exp}} {\terminal{)}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}} \\
|
||||
& {\delimit} &{\nonterminal{Exp2}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp3}} & {\arrow} &{\nonterminal{Exp3}} {\nonterminal{Exp4}} \\
|
||||
& {\delimit} &{\nonterminal{Exp4}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp4}} & {\arrow} &{\nonterminal{Exp4}} {\terminal{.}} {\nonterminal{CIdent}} \\
|
||||
& {\delimit} &{\nonterminal{Exp5}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp5}} & {\arrow} &{\terminal{sig}} {\terminal{\{}} {\nonterminal{ListFieldType}} {\terminal{\}}} \\
|
||||
& {\delimit} &{\terminal{rec}} {\terminal{\{}} {\nonterminal{ListFieldValue}} {\terminal{\}}} \\
|
||||
& {\delimit} &{\nonterminal{CIdent}} \\
|
||||
& {\delimit} &{\terminal{Type}} \\
|
||||
& {\delimit} &{\nonterminal{String}} \\
|
||||
& {\delimit} &{\nonterminal{Integer}} \\
|
||||
& {\delimit} &{\nonterminal{Double}} \\
|
||||
& {\delimit} &{\nonterminal{TMeta}} \\
|
||||
& {\delimit} &{\terminal{(}} {\nonterminal{Exp}} {\terminal{)}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{FieldType}} & {\arrow} &{\nonterminal{CIdent}} {\terminal{:}} {\nonterminal{Exp}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListFieldType}} & {\arrow} &{\emptyP} \\
|
||||
& {\delimit} &{\nonterminal{FieldType}} \\
|
||||
& {\delimit} &{\nonterminal{FieldType}} {\terminal{;}} {\nonterminal{ListFieldType}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{FieldValue}} & {\arrow} &{\nonterminal{CIdent}} {\terminal{{$=$}}} {\nonterminal{Exp}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListFieldValue}} & {\arrow} &{\emptyP} \\
|
||||
& {\delimit} &{\nonterminal{FieldValue}} \\
|
||||
& {\delimit} &{\nonterminal{FieldValue}} {\terminal{;}} {\nonterminal{ListFieldValue}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp2}} & {\arrow} &{\nonterminal{Exp3}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
|
||||
|
||||
\end{document}
|
||||
|
||||
File diff suppressed because one or more lines are too long
@@ -1,140 +0,0 @@
|
||||
-- -*- haskell -*-
|
||||
-- This Alex file was machine-generated by the BNF converter
|
||||
{
|
||||
{-# OPTIONS -fno-warn-incomplete-patterns #-}
|
||||
module Transfer.Core.Lex where
|
||||
|
||||
|
||||
}
|
||||
|
||||
|
||||
$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
|
||||
$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
|
||||
$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
|
||||
$d = [0-9] -- digit
|
||||
$i = [$l $d _ '] -- identifier character
|
||||
$u = [\0-\255] -- universal: any character
|
||||
|
||||
@rsyms = -- symbols and non-identifier-like reserved words
|
||||
\; | \: | \{ | \} | \= | \( | \) | \_ | \| | \- \> | \\ | \.
|
||||
|
||||
:-
|
||||
"--" [.]* ; -- Toss single line comments
|
||||
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
|
||||
|
||||
$white+ ;
|
||||
@rsyms { tok (\p s -> PT p (TS $ share s)) }
|
||||
\? $d + { tok (\p s -> PT p (eitherResIdent (T_TMeta . share) s)) }
|
||||
($l | \_)($l | $d | \_ | \')* { tok (\p s -> PT p (eitherResIdent (T_CIdent . share) s)) }
|
||||
|
||||
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
|
||||
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
|
||||
|
||||
$d+ { tok (\p s -> PT p (TI $ share s)) }
|
||||
$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
|
||||
|
||||
{
|
||||
|
||||
tok f p s = f p s
|
||||
|
||||
share :: String -> String
|
||||
share = id
|
||||
|
||||
data Tok =
|
||||
TS !String -- reserved words and symbols
|
||||
| TL !String -- string literals
|
||||
| TI !String -- integer literals
|
||||
| TV !String -- identifiers
|
||||
| TD !String -- double precision float literals
|
||||
| TC !String -- character literals
|
||||
| T_TMeta !String
|
||||
| T_CIdent !String
|
||||
|
||||
deriving (Eq,Show,Ord)
|
||||
|
||||
data Token =
|
||||
PT Posn Tok
|
||||
| Err Posn
|
||||
deriving (Eq,Show,Ord)
|
||||
|
||||
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
|
||||
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
|
||||
tokenPos _ = "end of file"
|
||||
|
||||
posLineCol (Pn _ l c) = (l,c)
|
||||
mkPosToken t@(PT p _) = (posLineCol p, prToken t)
|
||||
|
||||
prToken t = case t of
|
||||
PT _ (TS s) -> s
|
||||
PT _ (TI s) -> s
|
||||
PT _ (TV s) -> s
|
||||
PT _ (TD s) -> s
|
||||
PT _ (TC s) -> s
|
||||
PT _ (T_TMeta s) -> s
|
||||
PT _ (T_CIdent s) -> s
|
||||
|
||||
_ -> show t
|
||||
|
||||
data BTree = N | B String Tok BTree BTree deriving (Show)
|
||||
|
||||
eitherResIdent :: (String -> Tok) -> String -> Tok
|
||||
eitherResIdent tv s = treeFind resWords
|
||||
where
|
||||
treeFind N = tv s
|
||||
treeFind (B a t left right) | s < a = treeFind left
|
||||
| s > a = treeFind right
|
||||
| s == a = t
|
||||
|
||||
resWords = b "let" (b "data" (b "case" (b "Type" N N) N) (b "in" N N)) (b "sig" (b "rec" (b "of" N N) N) (b "where" N N))
|
||||
where b s = B s (TS s)
|
||||
|
||||
unescapeInitTail :: String -> String
|
||||
unescapeInitTail = unesc . tail where
|
||||
unesc s = case s of
|
||||
'\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
|
||||
'\\':'n':cs -> '\n' : unesc cs
|
||||
'\\':'t':cs -> '\t' : unesc cs
|
||||
'"':[] -> []
|
||||
c:cs -> c : unesc cs
|
||||
_ -> []
|
||||
|
||||
-------------------------------------------------------------------
|
||||
-- Alex wrapper code.
|
||||
-- A modified "posn" wrapper.
|
||||
-------------------------------------------------------------------
|
||||
|
||||
data Posn = Pn !Int !Int !Int
|
||||
deriving (Eq, Show,Ord)
|
||||
|
||||
alexStartPos :: Posn
|
||||
alexStartPos = Pn 0 1 1
|
||||
|
||||
alexMove :: Posn -> Char -> Posn
|
||||
alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
|
||||
alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
|
||||
alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
|
||||
|
||||
type AlexInput = (Posn, -- current position,
|
||||
Char, -- previous char
|
||||
String) -- current input string
|
||||
|
||||
tokens :: String -> [Token]
|
||||
tokens str = go (alexStartPos, '\n', str)
|
||||
where
|
||||
go :: (Posn, Char, String) -> [Token]
|
||||
go inp@(pos, _, str) =
|
||||
case alexScan inp 0 of
|
||||
AlexEOF -> []
|
||||
AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error"
|
||||
AlexSkip inp' len -> go inp'
|
||||
AlexToken inp' len act -> act pos (take len str) : (go inp')
|
||||
|
||||
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
|
||||
alexGetChar (p, c, []) = Nothing
|
||||
alexGetChar (p, _, (c:s)) =
|
||||
let p' = alexMove p c
|
||||
in p' `seq` Just (c, (p', c, s))
|
||||
|
||||
alexInputPrevChar :: AlexInput -> Char
|
||||
alexInputPrevChar (p, c, s) = c
|
||||
}
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,203 +0,0 @@
|
||||
-- This Happy file was machine-generated by the BNF converter
|
||||
{
|
||||
{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
|
||||
module Transfer.Core.Par where
|
||||
import Transfer.Core.Abs
|
||||
import Transfer.Core.Lex
|
||||
import Transfer.ErrM
|
||||
}
|
||||
|
||||
%name pModule Module
|
||||
%name pExp Exp
|
||||
|
||||
-- no lexer declaration
|
||||
%monad { Err } { thenM } { returnM }
|
||||
%tokentype { Token }
|
||||
|
||||
%token
|
||||
';' { PT _ (TS ";") }
|
||||
':' { PT _ (TS ":") }
|
||||
'{' { PT _ (TS "{") }
|
||||
'}' { PT _ (TS "}") }
|
||||
'=' { PT _ (TS "=") }
|
||||
'(' { PT _ (TS "(") }
|
||||
')' { PT _ (TS ")") }
|
||||
'_' { PT _ (TS "_") }
|
||||
'|' { PT _ (TS "|") }
|
||||
'->' { PT _ (TS "->") }
|
||||
'\\' { PT _ (TS "\\") }
|
||||
'.' { PT _ (TS ".") }
|
||||
'Type' { PT _ (TS "Type") }
|
||||
'case' { PT _ (TS "case") }
|
||||
'data' { PT _ (TS "data") }
|
||||
'in' { PT _ (TS "in") }
|
||||
'let' { PT _ (TS "let") }
|
||||
'of' { PT _ (TS "of") }
|
||||
'rec' { PT _ (TS "rec") }
|
||||
'sig' { PT _ (TS "sig") }
|
||||
'where' { PT _ (TS "where") }
|
||||
|
||||
L_quoted { PT _ (TL $$) }
|
||||
L_integ { PT _ (TI $$) }
|
||||
L_doubl { PT _ (TD $$) }
|
||||
L_TMeta { PT _ (T_TMeta $$) }
|
||||
L_CIdent { PT _ (T_CIdent $$) }
|
||||
L_err { _ }
|
||||
|
||||
|
||||
%%
|
||||
|
||||
String :: { String } : L_quoted { $1 }
|
||||
Integer :: { Integer } : L_integ { (read $1) :: Integer }
|
||||
Double :: { Double } : L_doubl { (read $1) :: Double }
|
||||
TMeta :: { TMeta} : L_TMeta { TMeta ($1)}
|
||||
CIdent :: { CIdent} : L_CIdent { CIdent ($1)}
|
||||
|
||||
Module :: { Module }
|
||||
Module : ListDecl { Module $1 }
|
||||
|
||||
|
||||
ListDecl :: { [Decl] }
|
||||
ListDecl : {- empty -} { [] }
|
||||
| Decl { (:[]) $1 }
|
||||
| Decl ';' ListDecl { (:) $1 $3 }
|
||||
|
||||
|
||||
Decl :: { Decl }
|
||||
Decl : 'data' CIdent ':' Exp 'where' '{' ListConsDecl '}' { DataDecl $2 $4 $7 }
|
||||
| CIdent ':' Exp { TypeDecl $1 $3 }
|
||||
| CIdent '=' Exp { ValueDecl $1 $3 }
|
||||
|
||||
|
||||
ConsDecl :: { ConsDecl }
|
||||
ConsDecl : CIdent ':' Exp { ConsDecl $1 $3 }
|
||||
|
||||
|
||||
ListConsDecl :: { [ConsDecl] }
|
||||
ListConsDecl : {- empty -} { [] }
|
||||
| ConsDecl { (:[]) $1 }
|
||||
| ConsDecl ';' ListConsDecl { (:) $1 $3 }
|
||||
|
||||
|
||||
ListPattern :: { [Pattern] }
|
||||
ListPattern : {- empty -} { [] }
|
||||
| ListPattern Pattern { flip (:) $1 $2 }
|
||||
|
||||
|
||||
Pattern :: { Pattern }
|
||||
Pattern : '(' CIdent ListPattern ')' { PCons $2 (reverse $3) }
|
||||
| PatternVariable { PVar $1 }
|
||||
| 'rec' '{' ListFieldPattern '}' { PRec $3 }
|
||||
| String { PStr $1 }
|
||||
| Integer { PInt $1 }
|
||||
|
||||
|
||||
FieldPattern :: { FieldPattern }
|
||||
FieldPattern : CIdent '=' Pattern { FieldPattern $1 $3 }
|
||||
|
||||
|
||||
ListFieldPattern :: { [FieldPattern] }
|
||||
ListFieldPattern : {- empty -} { [] }
|
||||
| FieldPattern { (:[]) $1 }
|
||||
| FieldPattern ';' ListFieldPattern { (:) $1 $3 }
|
||||
|
||||
|
||||
PatternVariable :: { PatternVariable }
|
||||
PatternVariable : CIdent { PVVar $1 }
|
||||
| '_' { PVWild }
|
||||
|
||||
|
||||
Exp :: { Exp }
|
||||
Exp : 'let' '{' ListLetDef '}' 'in' Exp { ELet $3 $6 }
|
||||
| 'case' Exp 'of' '{' ListCase '}' { ECase $2 $5 }
|
||||
| Exp1 { $1 }
|
||||
|
||||
|
||||
LetDef :: { LetDef }
|
||||
LetDef : CIdent '=' Exp { LetDef $1 $3 }
|
||||
|
||||
|
||||
ListLetDef :: { [LetDef] }
|
||||
ListLetDef : {- empty -} { [] }
|
||||
| LetDef { (:[]) $1 }
|
||||
| LetDef ';' ListLetDef { (:) $1 $3 }
|
||||
|
||||
|
||||
Case :: { Case }
|
||||
Case : Pattern '|' Exp '->' Exp { Case $1 $3 $5 }
|
||||
|
||||
|
||||
ListCase :: { [Case] }
|
||||
ListCase : {- empty -} { [] }
|
||||
| Case { (:[]) $1 }
|
||||
| Case ';' ListCase { (:) $1 $3 }
|
||||
|
||||
|
||||
Exp1 :: { Exp }
|
||||
Exp1 : '\\' PatternVariable '->' Exp { EAbs $2 $4 }
|
||||
| '(' PatternVariable ':' Exp ')' '->' Exp { EPi $2 $4 $7 }
|
||||
| Exp2 { $1 }
|
||||
|
||||
|
||||
Exp3 :: { Exp }
|
||||
Exp3 : Exp3 Exp4 { EApp $1 $2 }
|
||||
| Exp4 { $1 }
|
||||
|
||||
|
||||
Exp4 :: { Exp }
|
||||
Exp4 : Exp4 '.' CIdent { EProj $1 $3 }
|
||||
| Exp5 { $1 }
|
||||
|
||||
|
||||
Exp5 :: { Exp }
|
||||
Exp5 : 'sig' '{' ListFieldType '}' { ERecType $3 }
|
||||
| 'rec' '{' ListFieldValue '}' { ERec $3 }
|
||||
| CIdent { EVar $1 }
|
||||
| 'Type' { EType }
|
||||
| String { EStr $1 }
|
||||
| Integer { EInteger $1 }
|
||||
| Double { EDouble $1 }
|
||||
| TMeta { EMeta $1 }
|
||||
| '(' Exp ')' { $2 }
|
||||
|
||||
|
||||
FieldType :: { FieldType }
|
||||
FieldType : CIdent ':' Exp { FieldType $1 $3 }
|
||||
|
||||
|
||||
ListFieldType :: { [FieldType] }
|
||||
ListFieldType : {- empty -} { [] }
|
||||
| FieldType { (:[]) $1 }
|
||||
| FieldType ';' ListFieldType { (:) $1 $3 }
|
||||
|
||||
|
||||
FieldValue :: { FieldValue }
|
||||
FieldValue : CIdent '=' Exp { FieldValue $1 $3 }
|
||||
|
||||
|
||||
ListFieldValue :: { [FieldValue] }
|
||||
ListFieldValue : {- empty -} { [] }
|
||||
| FieldValue { (:[]) $1 }
|
||||
| FieldValue ';' ListFieldValue { (:) $1 $3 }
|
||||
|
||||
|
||||
Exp2 :: { Exp }
|
||||
Exp2 : Exp3 { $1 }
|
||||
|
||||
|
||||
|
||||
{
|
||||
|
||||
returnM :: a -> Err a
|
||||
returnM = return
|
||||
|
||||
thenM :: Err a -> (a -> Err b) -> Err b
|
||||
thenM = (>>=)
|
||||
|
||||
happyError :: [Token] -> Err a
|
||||
happyError ts =
|
||||
Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts)))
|
||||
|
||||
myLexer = tokens
|
||||
}
|
||||
|
||||
@@ -1,155 +0,0 @@
|
||||
{-# OPTIONS_GHC -fglasgow-exts #-}
|
||||
module Transfer.Core.Print where
|
||||
|
||||
-- pretty-printer generated by the BNF converter
|
||||
|
||||
import Transfer.Core.Abs
|
||||
import Data.Char
|
||||
import Data.List (intersperse)
|
||||
|
||||
-- the top-level printing method
|
||||
printTree :: Print a => a -> String
|
||||
printTree = render . prt 0
|
||||
|
||||
type Doc = [ShowS] -> [ShowS]
|
||||
|
||||
doc :: ShowS -> Doc
|
||||
doc = (:)
|
||||
|
||||
render :: Doc -> String
|
||||
render d = rend 0 (map ($ "") $ d []) "" where
|
||||
rend i ss = case ss of
|
||||
"[" :ts -> showChar '[' . rend i ts
|
||||
"(" :ts -> showChar '(' . rend i ts
|
||||
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
|
||||
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
|
||||
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
|
||||
";" :ts -> showChar ';' . new i . rend i ts
|
||||
t : "," :ts -> showString t . space "," . rend i ts
|
||||
t : ")" :ts -> showString t . showChar ')' . rend i ts
|
||||
t : "]" :ts -> showString t . showChar ']' . rend i ts
|
||||
t :ts -> space t . rend i ts
|
||||
_ -> id
|
||||
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
|
||||
space t = showString t . (\s -> if null s then "" else (' ':s))
|
||||
|
||||
parenth :: Doc -> Doc
|
||||
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
|
||||
|
||||
concatS :: [ShowS] -> ShowS
|
||||
concatS = foldr (.) id
|
||||
|
||||
concatD :: [Doc] -> Doc
|
||||
concatD = foldr (.) id
|
||||
|
||||
unwordsD :: [Doc] -> Doc
|
||||
unwordsD = concatD . intersperse (doc (showChar ' '))
|
||||
|
||||
replicateS :: Int -> ShowS -> ShowS
|
||||
replicateS n f = concatS (replicate n f)
|
||||
|
||||
-- the printer class does the job
|
||||
class Print a where
|
||||
prt :: Int -> a -> Doc
|
||||
|
||||
instance Print Char where
|
||||
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
|
||||
|
||||
instance Print String where
|
||||
prt _ s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
|
||||
|
||||
mkEsc :: Char -> Char -> ShowS
|
||||
mkEsc q s = case s of
|
||||
_ | s == q -> showChar '\\' . showChar s
|
||||
'\\'-> showString "\\\\"
|
||||
'\n' -> showString "\\n"
|
||||
'\t' -> showString "\\t"
|
||||
_ -> showChar s
|
||||
|
||||
prPrec :: Int -> Int -> Doc -> Doc
|
||||
prPrec i j = if j<i then parenth else id
|
||||
|
||||
|
||||
instance Print Integer where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
|
||||
instance Print Double where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
|
||||
instance Print (Tree c) where
|
||||
prt _i e = case e of
|
||||
Module decls -> prPrec _i 0 (concatD [prt 0 decls])
|
||||
DataDecl cident exp consdecls -> prPrec _i 0 (concatD [doc (showString "data") , prt 0 cident , doc (showString ":") , prt 0 exp , doc (showString "where") , doc (showString "{") , prt 0 consdecls , doc (showString "}")])
|
||||
TypeDecl cident exp -> prPrec _i 0 (concatD [prt 0 cident , doc (showString ":") , prt 0 exp])
|
||||
ValueDecl cident exp -> prPrec _i 0 (concatD [prt 0 cident , doc (showString "=") , prt 0 exp])
|
||||
ConsDecl cident exp -> prPrec _i 0 (concatD [prt 0 cident , doc (showString ":") , prt 0 exp])
|
||||
PCons cident patterns -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 cident , prt 0 patterns , doc (showString ")")])
|
||||
PVar patternvariable -> prPrec _i 0 (concatD [prt 0 patternvariable])
|
||||
PRec fieldpatterns -> prPrec _i 0 (concatD [doc (showString "rec") , doc (showString "{") , prt 0 fieldpatterns , doc (showString "}")])
|
||||
PStr str -> prPrec _i 0 (concatD [prt 0 str])
|
||||
PInt n -> prPrec _i 0 (concatD [prt 0 n])
|
||||
FieldPattern cident pattern -> prPrec _i 0 (concatD [prt 0 cident , doc (showString "=") , prt 0 pattern])
|
||||
PVVar cident -> prPrec _i 0 (concatD [prt 0 cident])
|
||||
PVWild -> prPrec _i 0 (concatD [doc (showString "_")])
|
||||
ELet letdefs exp -> prPrec _i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 letdefs , doc (showString "}") , doc (showString "in") , prt 0 exp])
|
||||
ECase exp cases -> prPrec _i 0 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
|
||||
EAbs patternvariable exp -> prPrec _i 1 (concatD [doc (showString "\\") , prt 0 patternvariable , doc (showString "->") , prt 0 exp])
|
||||
EPi patternvariable exp0 exp1 -> prPrec _i 1 (concatD [doc (showString "(") , prt 0 patternvariable , doc (showString ":") , prt 0 exp0 , doc (showString ")") , doc (showString "->") , prt 0 exp1])
|
||||
EApp exp0 exp1 -> prPrec _i 3 (concatD [prt 3 exp0 , prt 4 exp1])
|
||||
EProj exp cident -> prPrec _i 4 (concatD [prt 4 exp , doc (showString ".") , prt 0 cident])
|
||||
ERecType fieldtypes -> prPrec _i 5 (concatD [doc (showString "sig") , doc (showString "{") , prt 0 fieldtypes , doc (showString "}")])
|
||||
ERec fieldvalues -> prPrec _i 5 (concatD [doc (showString "rec") , doc (showString "{") , prt 0 fieldvalues , doc (showString "}")])
|
||||
EVar cident -> prPrec _i 5 (concatD [prt 0 cident])
|
||||
EType -> prPrec _i 5 (concatD [doc (showString "Type")])
|
||||
EStr str -> prPrec _i 5 (concatD [prt 0 str])
|
||||
EInteger n -> prPrec _i 5 (concatD [prt 0 n])
|
||||
EDouble d -> prPrec _i 5 (concatD [prt 0 d])
|
||||
EMeta tmeta -> prPrec _i 5 (concatD [prt 0 tmeta])
|
||||
LetDef cident exp -> prPrec _i 0 (concatD [prt 0 cident , doc (showString "=") , prt 0 exp])
|
||||
Case pattern exp0 exp1 -> prPrec _i 0 (concatD [prt 0 pattern , doc (showString "|") , prt 0 exp0 , doc (showString "->") , prt 0 exp1])
|
||||
FieldType cident exp -> prPrec _i 0 (concatD [prt 0 cident , doc (showString ":") , prt 0 exp])
|
||||
FieldValue cident exp -> prPrec _i 0 (concatD [prt 0 cident , doc (showString "=") , prt 0 exp])
|
||||
TMeta str -> prPrec _i 0 (doc (showString str))
|
||||
CIdent str -> prPrec _i 0 (doc (showString str))
|
||||
|
||||
instance Print [Decl] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [ConsDecl] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [Pattern] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , prt 0 xs])
|
||||
instance Print [FieldPattern] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [LetDef] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [Case] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [FieldType] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [FieldValue] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
@@ -1,119 +0,0 @@
|
||||
module Transfer.Core.Skel where
|
||||
|
||||
-- Haskell module generated by the BNF converter
|
||||
|
||||
import Transfer.Core.Abs
|
||||
import Transfer.ErrM
|
||||
type Result = Err String
|
||||
|
||||
failure :: Show a => a -> Result
|
||||
failure x = Bad $ "Undefined case: " ++ show x
|
||||
|
||||
transTree :: Tree c -> Result
|
||||
transTree t = case t of
|
||||
Module decls -> failure t
|
||||
DataDecl cident exp consdecls -> failure t
|
||||
TypeDecl cident exp -> failure t
|
||||
ValueDecl cident exp -> failure t
|
||||
ConsDecl cident exp -> failure t
|
||||
PCons cident patterns -> failure t
|
||||
PVar patternvariable -> failure t
|
||||
PRec fieldpatterns -> failure t
|
||||
PStr str -> failure t
|
||||
PInt n -> failure t
|
||||
FieldPattern cident pattern -> failure t
|
||||
PVVar cident -> failure t
|
||||
PVWild -> failure t
|
||||
ELet letdefs exp -> failure t
|
||||
ECase exp cases -> failure t
|
||||
EAbs patternvariable exp -> failure t
|
||||
EPi patternvariable exp0 exp1 -> failure t
|
||||
EApp exp0 exp1 -> failure t
|
||||
EProj exp cident -> failure t
|
||||
ERecType fieldtypes -> failure t
|
||||
ERec fieldvalues -> failure t
|
||||
EVar cident -> failure t
|
||||
EType -> failure t
|
||||
EStr str -> failure t
|
||||
EInteger n -> failure t
|
||||
EDouble d -> failure t
|
||||
EMeta tmeta -> failure t
|
||||
LetDef cident exp -> failure t
|
||||
Case pattern exp0 exp1 -> failure t
|
||||
FieldType cident exp -> failure t
|
||||
FieldValue cident exp -> failure t
|
||||
TMeta str -> failure t
|
||||
CIdent str -> failure t
|
||||
|
||||
transModule :: Module -> Result
|
||||
transModule t = case t of
|
||||
Module decls -> failure t
|
||||
|
||||
transDecl :: Decl -> Result
|
||||
transDecl t = case t of
|
||||
DataDecl cident exp consdecls -> failure t
|
||||
TypeDecl cident exp -> failure t
|
||||
ValueDecl cident exp -> failure t
|
||||
|
||||
transConsDecl :: ConsDecl -> Result
|
||||
transConsDecl t = case t of
|
||||
ConsDecl cident exp -> failure t
|
||||
|
||||
transPattern :: Pattern -> Result
|
||||
transPattern t = case t of
|
||||
PCons cident patterns -> failure t
|
||||
PVar patternvariable -> failure t
|
||||
PRec fieldpatterns -> failure t
|
||||
PStr str -> failure t
|
||||
PInt n -> failure t
|
||||
|
||||
transFieldPattern :: FieldPattern -> Result
|
||||
transFieldPattern t = case t of
|
||||
FieldPattern cident pattern -> failure t
|
||||
|
||||
transPatternVariable :: PatternVariable -> Result
|
||||
transPatternVariable t = case t of
|
||||
PVVar cident -> failure t
|
||||
PVWild -> failure t
|
||||
|
||||
transExp :: Exp -> Result
|
||||
transExp t = case t of
|
||||
ELet letdefs exp -> failure t
|
||||
ECase exp cases -> failure t
|
||||
EAbs patternvariable exp -> failure t
|
||||
EPi patternvariable exp0 exp1 -> failure t
|
||||
EApp exp0 exp1 -> failure t
|
||||
EProj exp cident -> failure t
|
||||
ERecType fieldtypes -> failure t
|
||||
ERec fieldvalues -> failure t
|
||||
EVar cident -> failure t
|
||||
EType -> failure t
|
||||
EStr str -> failure t
|
||||
EInteger n -> failure t
|
||||
EDouble d -> failure t
|
||||
EMeta tmeta -> failure t
|
||||
|
||||
transLetDef :: LetDef -> Result
|
||||
transLetDef t = case t of
|
||||
LetDef cident exp -> failure t
|
||||
|
||||
transCase :: Case -> Result
|
||||
transCase t = case t of
|
||||
Case pattern exp0 exp1 -> failure t
|
||||
|
||||
transFieldType :: FieldType -> Result
|
||||
transFieldType t = case t of
|
||||
FieldType cident exp -> failure t
|
||||
|
||||
transFieldValue :: FieldValue -> Result
|
||||
transFieldValue t = case t of
|
||||
FieldValue cident exp -> failure t
|
||||
|
||||
transTMeta :: TMeta -> Result
|
||||
transTMeta t = case t of
|
||||
TMeta str -> failure t
|
||||
|
||||
transCIdent :: CIdent -> Result
|
||||
transCIdent t = case t of
|
||||
CIdent str -> failure t
|
||||
|
||||
@@ -1,58 +0,0 @@
|
||||
-- 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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -1,16 +0,0 @@
|
||||
-- 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
|
||||
@@ -1,240 +0,0 @@
|
||||
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
|
||||
| VDbl Double
|
||||
| VType
|
||||
| VRec [(CIdent,Value)]
|
||||
| VClos Env Exp
|
||||
| VCons CIdent [Value]
|
||||
| VPrim (Value -> Value)
|
||||
| VMeta Integer
|
||||
deriving (Show)
|
||||
|
||||
instance Show (a -> b) where
|
||||
show _ = "<<function>>"
|
||||
|
||||
--
|
||||
-- * Environment
|
||||
--
|
||||
|
||||
newtype Env = Env [(CIdent,Value)]
|
||||
deriving Show
|
||||
|
||||
mkEnv :: [(CIdent,Value)] -> Env
|
||||
mkEnv = Env
|
||||
|
||||
addToEnv :: [(CIdent,Value)] -> Env -> Env
|
||||
addToEnv bs (Env e) = Env (bs ++ e)
|
||||
|
||||
lookupEnv :: Env -> CIdent -> Value
|
||||
lookupEnv (Env e) id =
|
||||
case lookup id e of
|
||||
Just x -> x
|
||||
Nothing -> error $ "Variable " ++ printTree id ++ " not in environment."
|
||||
++ " Environment contains: " ++ show (map (printTree . fst) e)
|
||||
|
||||
prEnv :: Env -> String
|
||||
prEnv (Env e) = unlines [ printTree id ++ ": " ++ printValue v | (id,v) <- e ]
|
||||
|
||||
seqEnv :: Env -> Env
|
||||
seqEnv (Env e) = Env $! deepSeqList [ fst p `seq` p | p <- e ]
|
||||
|
||||
-- | The built-in types and functions.
|
||||
builtin :: Env
|
||||
builtin =
|
||||
mkEnv [(CIdent "Integer",VType),
|
||||
(CIdent "Double",VType),
|
||||
(CIdent "String",VType),
|
||||
mkIntUn "neg" negate toInt,
|
||||
mkIntBin "add" (+) toInt,
|
||||
mkIntBin "sub" (-) toInt,
|
||||
mkIntBin "mul" (*) toInt,
|
||||
mkIntBin "div" div toInt,
|
||||
mkIntBin "mod" mod toInt,
|
||||
mkIntBin "eq" (==) toBool,
|
||||
mkIntBin "cmp" compare toOrd,
|
||||
mkIntUn "show" show toStr,
|
||||
mkDblUn "neg" negate toDbl,
|
||||
mkDblBin "add" (+) toDbl,
|
||||
mkDblBin "sub" (-) toDbl,
|
||||
mkDblBin "mul" (*) toDbl,
|
||||
mkDblBin "div" (/) toDbl,
|
||||
mkDblBin "mod" (\_ _ -> 0.0) toDbl,
|
||||
mkDblBin "eq" (==) toBool,
|
||||
mkDblBin "cmp" compare toOrd,
|
||||
mkDblUn "show" show toStr,
|
||||
mkStrBin "add" (++) toStr,
|
||||
mkStrBin "eq" (==) toBool,
|
||||
mkStrBin "cmp" compare toOrd,
|
||||
mkStrUn "show" show toStr
|
||||
]
|
||||
where
|
||||
toInt i = VInt i
|
||||
toDbl i = VDbl i
|
||||
toBool b = VCons (CIdent (show b)) []
|
||||
toOrd o = VCons (CIdent (show o)) []
|
||||
toStr s = VStr s
|
||||
mkUn t a x f g = let c = CIdent ("prim_" ++ x ++ "_" ++ t)
|
||||
in (c, VPrim (\n -> a f g n))
|
||||
mkBin t a x f g = let c = CIdent ("prim_" ++ x ++ "_" ++ t)
|
||||
in (c, VPrim (\n -> VPrim (\m -> a f g n m )))
|
||||
mkIntUn = mkUn "Integer" $ \ f g x ->
|
||||
case x of
|
||||
VInt n -> g (f n)
|
||||
_ -> error $ printValue x ++ " is not an integer"
|
||||
mkIntBin = mkBin "Integer" $ \ f g x y ->
|
||||
case (x,y) of
|
||||
(VInt n,VInt m) -> g (f n m)
|
||||
_ -> error $ printValue x ++ " and " ++ printValue y
|
||||
++ " are not both integers"
|
||||
mkDblUn = mkUn "Double" $ \ f g x ->
|
||||
case x of
|
||||
VDbl n -> g (f n)
|
||||
_ -> error $ printValue x ++ " is not a double"
|
||||
mkDblBin = mkBin "Double" $ \ f g x y ->
|
||||
case (x,y) of
|
||||
(VDbl n,VDbl m) -> g (f n m)
|
||||
_ -> error $ printValue x ++ " and " ++ printValue y
|
||||
++ " are not both doubles"
|
||||
mkStrUn = mkUn "String" $ \ f g x ->
|
||||
case x of
|
||||
VStr n -> g (f n)
|
||||
_ -> error $ printValue x ++ " is not a string"
|
||||
mkStrBin = mkBin "String" $ \ f g x y ->
|
||||
case (x,y) of
|
||||
(VStr n,VStr m) -> g (f n m)
|
||||
_ -> error $ printValue x ++ " and " ++ printValue y
|
||||
++ " are not both strings"
|
||||
|
||||
addModuleEnv :: Env -> Module -> Env
|
||||
addModuleEnv env (Module ds) =
|
||||
let bs = [ (c,VCons c []) | DataDecl _ _ cs <- ds, ConsDecl c _ <- cs ]
|
||||
++ [ (t,VCons t []) | DataDecl t _ _ <- ds ]
|
||||
++ [ (x,eval env' e) | ValueDecl x e <- ds]
|
||||
env' = addToEnv bs env
|
||||
in env'
|
||||
|
||||
--
|
||||
-- * Evaluation.
|
||||
--
|
||||
|
||||
eval :: Env -> Exp -> Value
|
||||
eval env x = case x of
|
||||
ELet defs exp2 ->
|
||||
let env' = [ (id, v) | LetDef id e <- defs,
|
||||
let v = eval env' e]
|
||||
`addToEnv` env
|
||||
in eval (seqEnv env') exp2
|
||||
ECase exp cases ->
|
||||
let v = eval env exp
|
||||
r = case firstMatch env v cases of
|
||||
Nothing -> error $ "No pattern matched " ++ printValue v
|
||||
Just (e,env') -> eval env' e
|
||||
in v `seq` r
|
||||
EAbs _ _ -> VClos env x
|
||||
EPi _ _ _ -> VClos env x
|
||||
EApp exp1 exp2 ->
|
||||
let v1 = eval env exp1
|
||||
v2 = eval env exp2
|
||||
in case v1 of
|
||||
VClos env' (EAbs id e) -> eval (bind id v2 `addToEnv` env') e
|
||||
VPrim 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
|
||||
|
||||
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 -> lookupEnv env id
|
||||
EType -> VType
|
||||
EStr str -> VStr str
|
||||
EInteger n -> VInt n
|
||||
EDouble n -> VDbl n
|
||||
EMeta (TMeta t) -> VMeta (read $ drop 1 t)
|
||||
|
||||
firstMatch :: Env -> Value -> [Case] -> Maybe (Exp,Env)
|
||||
firstMatch _ _ [] = Nothing
|
||||
firstMatch env v (Case p g e:cs) =
|
||||
case match p v of
|
||||
Nothing -> firstMatch env v cs
|
||||
Just bs -> let env' = bs `addToEnv` env
|
||||
in case eval env' g of
|
||||
VCons (CIdent "True") [] -> Just (e,env')
|
||||
VCons (CIdent "False") [] -> firstMatch env v cs
|
||||
x -> error $ "Error in guard: " ++ printValue x
|
||||
++ " is not a Bool"
|
||||
|
||||
bind :: PatternVariable -> Value -> [(CIdent,Value)]
|
||||
bind (PVVar x) v = [(x,v)]
|
||||
bind PVWild _ = []
|
||||
|
||||
match :: Pattern -> Value -> Maybe [(CIdent,Value)]
|
||||
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 (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)) []
|
||||
|
||||
--
|
||||
-- * Convert values to expressions
|
||||
--
|
||||
|
||||
valueToExp :: Value -> Exp
|
||||
valueToExp v =
|
||||
case v of
|
||||
VStr s -> EStr s
|
||||
VInt i -> EInteger i
|
||||
VDbl i -> EDouble i
|
||||
VType -> EType
|
||||
VRec fs -> ERec [ FieldValue f (valueToExp v) | (f,v) <- fs]
|
||||
VClos env e -> e
|
||||
VCons c vs -> foldl EApp (EVar c) (map valueToExp vs)
|
||||
VPrim _ -> EVar (CIdent "<<primitive>>") -- FIXME: what to return here?
|
||||
VMeta n -> EMeta $ TMeta $ "?" ++ show n
|
||||
|
||||
--
|
||||
-- * Pretty printing of values
|
||||
--
|
||||
|
||||
printValue :: Value -> String
|
||||
printValue v = printTree (valueToExp v)
|
||||
@@ -1,39 +0,0 @@
|
||||
module Transfer.InterpreterAPI (Env, builtin,
|
||||
load, loadFile,
|
||||
evaluateString, evaluateExp
|
||||
) 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.
|
||||
-- Fails in the IO monad if there is a problem loading the 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
|
||||
|
||||
-- | Evaluate an expression in the given environment.
|
||||
evaluateExp :: Env -> Exp -> Exp
|
||||
evaluateExp env exp = valueToExp $ eval env exp
|
||||
@@ -1,110 +0,0 @@
|
||||
{-# 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
|
||||
@@ -1,485 +0,0 @@
|
||||
{-# OPTIONS_GHC -fglasgow-exts #-}
|
||||
module Transfer.Syntax.Abs (Tree(..), Module, Import, Decl, ConsDecl, Guard, Pattern, CommaPattern, FieldPattern, Exp, VarOrWild, LetDef, Case, Bind, FieldType, FieldValue, Ident, composOp, composOpM, composOpM_, composOpMPlus, composOpMonoid, composOpFold, compos, johnMajorEq) where
|
||||
|
||||
import Control.Monad (ap,MonadPlus,msum,mplus,mzero)
|
||||
import Control.Monad.Identity
|
||||
import Data.Monoid
|
||||
|
||||
-- Haskell module generated by the BNF converter
|
||||
|
||||
data Module_
|
||||
type Module = Tree Module_
|
||||
data Import_
|
||||
type Import = Tree Import_
|
||||
data Decl_
|
||||
type Decl = Tree Decl_
|
||||
data ConsDecl_
|
||||
type ConsDecl = Tree ConsDecl_
|
||||
data Guard_
|
||||
type Guard = Tree Guard_
|
||||
data Pattern_
|
||||
type Pattern = Tree Pattern_
|
||||
data CommaPattern_
|
||||
type CommaPattern = Tree CommaPattern_
|
||||
data FieldPattern_
|
||||
type FieldPattern = Tree FieldPattern_
|
||||
data Exp_
|
||||
type Exp = Tree Exp_
|
||||
data VarOrWild_
|
||||
type VarOrWild = Tree VarOrWild_
|
||||
data LetDef_
|
||||
type LetDef = Tree LetDef_
|
||||
data Case_
|
||||
type Case = Tree Case_
|
||||
data Bind_
|
||||
type Bind = Tree Bind_
|
||||
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] -> Guard -> Exp -> Tree Decl_
|
||||
DeriveDecl :: Ident -> Ident -> Tree Decl_
|
||||
ConsDecl :: Ident -> Exp -> Tree ConsDecl_
|
||||
GuardExp :: Exp -> Tree Guard_
|
||||
GuardNo :: Tree Guard_
|
||||
POr :: Pattern -> Pattern -> Tree Pattern_
|
||||
PListCons :: Pattern -> Pattern -> Tree Pattern_
|
||||
PConsTop :: Ident -> Pattern -> [Pattern] -> Tree Pattern_
|
||||
PCons :: Ident -> [Pattern] -> Tree Pattern_
|
||||
PRec :: [FieldPattern] -> Tree Pattern_
|
||||
PEmptyList :: Tree Pattern_
|
||||
PList :: [CommaPattern] -> Tree Pattern_
|
||||
PTuple :: CommaPattern -> [CommaPattern] -> Tree Pattern_
|
||||
PStr :: String -> Tree Pattern_
|
||||
PInt :: Integer -> Tree Pattern_
|
||||
PVar :: Ident -> Tree Pattern_
|
||||
PWild :: Tree Pattern_
|
||||
CommaPattern :: Pattern -> Tree CommaPattern_
|
||||
FieldPattern :: Ident -> Pattern -> Tree FieldPattern_
|
||||
EPi :: VarOrWild -> Exp -> Exp -> Tree Exp_
|
||||
EPiNoVar :: Exp -> Exp -> Tree Exp_
|
||||
EAbs :: VarOrWild -> Exp -> Tree Exp_
|
||||
ELet :: [LetDef] -> Exp -> Tree Exp_
|
||||
ECase :: Exp -> [Case] -> Tree Exp_
|
||||
EIf :: Exp -> Exp -> Exp -> Tree Exp_
|
||||
EDo :: [Bind] -> Exp -> Tree Exp_
|
||||
EBind :: Exp -> Exp -> Tree Exp_
|
||||
EBindC :: 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_
|
||||
EListCons :: 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_
|
||||
ENeg :: Exp -> Tree Exp_
|
||||
EApp :: Exp -> Exp -> Tree Exp_
|
||||
EProj :: Exp -> Ident -> Tree Exp_
|
||||
ERecType :: [FieldType] -> Tree Exp_
|
||||
ERec :: [FieldValue] -> Tree Exp_
|
||||
EEmptyList :: Tree Exp_
|
||||
EList :: [Exp] -> Tree Exp_
|
||||
ETuple :: Exp -> [Exp] -> Tree Exp_
|
||||
EVar :: Ident -> Tree Exp_
|
||||
EType :: Tree Exp_
|
||||
EStr :: String -> Tree Exp_
|
||||
EInteger :: Integer -> Tree Exp_
|
||||
EDouble :: Double -> Tree Exp_
|
||||
EMeta :: Tree Exp_
|
||||
VVar :: Ident -> Tree VarOrWild_
|
||||
VWild :: Tree VarOrWild_
|
||||
LetDef :: Ident -> Exp -> Tree LetDef_
|
||||
Case :: Pattern -> Guard -> Exp -> Tree Case_
|
||||
BindVar :: VarOrWild -> Exp -> Tree Bind_
|
||||
BindNoVar :: Exp -> Tree Bind_
|
||||
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 = runIdentity . composOpM (Identity . f)
|
||||
|
||||
composOpM :: Monad m => (forall a. Tree a -> m (Tree a)) -> Tree c -> m (Tree c)
|
||||
composOpM = compos return ap
|
||||
|
||||
composOpM_ :: Monad m => (forall a. Tree a -> m ()) -> Tree c -> m ()
|
||||
composOpM_ = composOpFold (return ()) (>>)
|
||||
|
||||
composOpMPlus :: MonadPlus m => (forall a. Tree a -> m b) -> Tree c -> m b
|
||||
composOpMPlus = composOpFold mzero mplus
|
||||
|
||||
composOpMonoid :: Monoid m => (forall a. Tree a -> m) -> Tree c -> m
|
||||
composOpMonoid = composOpFold mempty mappend
|
||||
|
||||
newtype C b a = C { unC :: b }
|
||||
composOpFold :: b -> (b -> b -> b) -> (forall a. Tree a -> b) -> Tree c -> b
|
||||
composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)
|
||||
|
||||
compos :: (forall a. a -> m a)
|
||||
-> (forall a b. m (a -> b) -> m a -> m b)
|
||||
-> (forall a. Tree a -> m (Tree a)) -> Tree c -> m (Tree c)
|
||||
compos r a f t = case t of
|
||||
Module imports decls -> r Module `a` foldr (a . a (r (:)) . f) (r []) imports `a` foldr (a . a (r (:)) . f) (r []) decls
|
||||
Import i -> r Import `a` f i
|
||||
DataDecl i exp consdecls -> r DataDecl `a` f i `a` f exp `a` foldr (a . a (r (:)) . f) (r []) consdecls
|
||||
TypeDecl i exp -> r TypeDecl `a` f i `a` f exp
|
||||
ValueDecl i patterns guard exp -> r ValueDecl `a` f i `a` foldr (a . a (r (:)) . f) (r []) patterns `a` f guard `a` f exp
|
||||
DeriveDecl i0 i1 -> r DeriveDecl `a` f i0 `a` f i1
|
||||
ConsDecl i exp -> r ConsDecl `a` f i `a` f exp
|
||||
GuardExp exp -> r GuardExp `a` f exp
|
||||
POr pattern0 pattern1 -> r POr `a` f pattern0 `a` f pattern1
|
||||
PListCons pattern0 pattern1 -> r PListCons `a` f pattern0 `a` f pattern1
|
||||
PConsTop i pattern patterns -> r PConsTop `a` f i `a` f pattern `a` foldr (a . a (r (:)) . f) (r []) patterns
|
||||
PCons i patterns -> r PCons `a` f i `a` foldr (a . a (r (:)) . f) (r []) patterns
|
||||
PRec fieldpatterns -> r PRec `a` foldr (a . a (r (:)) . f) (r []) fieldpatterns
|
||||
PList commapatterns -> r PList `a` foldr (a . a (r (:)) . f) (r []) commapatterns
|
||||
PTuple commapattern commapatterns -> r PTuple `a` f commapattern `a` foldr (a . a (r (:)) . f) (r []) commapatterns
|
||||
PVar i -> r PVar `a` f i
|
||||
CommaPattern pattern -> r CommaPattern `a` f pattern
|
||||
FieldPattern i pattern -> r FieldPattern `a` f i `a` f pattern
|
||||
EPi varorwild exp0 exp1 -> r EPi `a` f varorwild `a` f exp0 `a` f exp1
|
||||
EPiNoVar exp0 exp1 -> r EPiNoVar `a` f exp0 `a` f exp1
|
||||
EAbs varorwild exp -> r EAbs `a` f varorwild `a` f exp
|
||||
ELet letdefs exp -> r ELet `a` foldr (a . a (r (:)) . f) (r []) letdefs `a` f exp
|
||||
ECase exp cases -> r ECase `a` f exp `a` foldr (a . a (r (:)) . f) (r []) cases
|
||||
EIf exp0 exp1 exp2 -> r EIf `a` f exp0 `a` f exp1 `a` f exp2
|
||||
EDo binds exp -> r EDo `a` foldr (a . a (r (:)) . f) (r []) binds `a` f exp
|
||||
EBind exp0 exp1 -> r EBind `a` f exp0 `a` f exp1
|
||||
EBindC exp0 exp1 -> r EBindC `a` f exp0 `a` f exp1
|
||||
EOr exp0 exp1 -> r EOr `a` f exp0 `a` f exp1
|
||||
EAnd exp0 exp1 -> r EAnd `a` f exp0 `a` f exp1
|
||||
EEq exp0 exp1 -> r EEq `a` f exp0 `a` f exp1
|
||||
ENe exp0 exp1 -> r ENe `a` f exp0 `a` f exp1
|
||||
ELt exp0 exp1 -> r ELt `a` f exp0 `a` f exp1
|
||||
ELe exp0 exp1 -> r ELe `a` f exp0 `a` f exp1
|
||||
EGt exp0 exp1 -> r EGt `a` f exp0 `a` f exp1
|
||||
EGe exp0 exp1 -> r EGe `a` f exp0 `a` f exp1
|
||||
EListCons exp0 exp1 -> r EListCons `a` f exp0 `a` f exp1
|
||||
EAdd exp0 exp1 -> r EAdd `a` f exp0 `a` f exp1
|
||||
ESub exp0 exp1 -> r ESub `a` f exp0 `a` f exp1
|
||||
EMul exp0 exp1 -> r EMul `a` f exp0 `a` f exp1
|
||||
EDiv exp0 exp1 -> r EDiv `a` f exp0 `a` f exp1
|
||||
EMod exp0 exp1 -> r EMod `a` f exp0 `a` f exp1
|
||||
ENeg exp -> r ENeg `a` f exp
|
||||
EApp exp0 exp1 -> r EApp `a` f exp0 `a` f exp1
|
||||
EProj exp i -> r EProj `a` f exp `a` f i
|
||||
ERecType fieldtypes -> r ERecType `a` foldr (a . a (r (:)) . f) (r []) fieldtypes
|
||||
ERec fieldvalues -> r ERec `a` foldr (a . a (r (:)) . f) (r []) fieldvalues
|
||||
EList exps -> r EList `a` foldr (a . a (r (:)) . f) (r []) exps
|
||||
ETuple exp exps -> r ETuple `a` f exp `a` foldr (a . a (r (:)) . f) (r []) exps
|
||||
EVar i -> r EVar `a` f i
|
||||
VVar i -> r VVar `a` f i
|
||||
LetDef i exp -> r LetDef `a` f i `a` f exp
|
||||
Case pattern guard exp -> r Case `a` f pattern `a` f guard `a` f exp
|
||||
BindVar varorwild exp -> r BindVar `a` f varorwild `a` f exp
|
||||
BindNoVar exp -> r BindNoVar `a` f exp
|
||||
FieldType i exp -> r FieldType `a` f i `a` f exp
|
||||
FieldValue i exp -> r FieldValue `a` f i `a` f exp
|
||||
_ -> r t
|
||||
|
||||
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 guard exp -> opar n . showString "ValueDecl" . showChar ' ' . showsPrec 1 i . showChar ' ' . showsPrec 1 patterns . showChar ' ' . showsPrec 1 guard . 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
|
||||
GuardExp exp -> opar n . showString "GuardExp" . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
GuardNo -> showString "GuardNo"
|
||||
POr pattern0 pattern1 -> opar n . showString "POr" . showChar ' ' . showsPrec 1 pattern0 . showChar ' ' . showsPrec 1 pattern1 . cpar n
|
||||
PListCons pattern0 pattern1 -> opar n . showString "PListCons" . showChar ' ' . showsPrec 1 pattern0 . showChar ' ' . showsPrec 1 pattern1 . 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
|
||||
PEmptyList -> showString "PEmptyList"
|
||||
PList commapatterns -> opar n . showString "PList" . showChar ' ' . showsPrec 1 commapatterns . cpar n
|
||||
PTuple commapattern commapatterns -> opar n . showString "PTuple" . showChar ' ' . showsPrec 1 commapattern . showChar ' ' . showsPrec 1 commapatterns . cpar n
|
||||
PStr str -> opar n . showString "PStr" . showChar ' ' . showsPrec 1 str . cpar n
|
||||
PInt n -> opar n . showString "PInt" . showChar ' ' . showsPrec 1 n . cpar n
|
||||
PVar i -> opar n . showString "PVar" . showChar ' ' . showsPrec 1 i . cpar n
|
||||
PWild -> showString "PWild"
|
||||
CommaPattern pattern -> opar n . showString "CommaPattern" . showChar ' ' . showsPrec 1 pattern . cpar n
|
||||
FieldPattern i pattern -> opar n . showString "FieldPattern" . showChar ' ' . showsPrec 1 i . showChar ' ' . showsPrec 1 pattern . 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
|
||||
EAbs varorwild exp -> opar n . showString "EAbs" . showChar ' ' . showsPrec 1 varorwild . showChar ' ' . showsPrec 1 exp . 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
|
||||
EDo binds exp -> opar n . showString "EDo" . showChar ' ' . showsPrec 1 binds . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
EBind exp0 exp1 -> opar n . showString "EBind" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
|
||||
EBindC exp0 exp1 -> opar n . showString "EBindC" . 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
|
||||
EListCons exp0 exp1 -> opar n . showString "EListCons" . 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
|
||||
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
|
||||
EProj exp i -> opar n . showString "EProj" . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 i . cpar n
|
||||
ERecType fieldtypes -> opar n . showString "ERecType" . showChar ' ' . showsPrec 1 fieldtypes . cpar n
|
||||
ERec fieldvalues -> opar n . showString "ERec" . showChar ' ' . showsPrec 1 fieldvalues . cpar n
|
||||
EEmptyList -> showString "EEmptyList"
|
||||
EList exps -> opar n . showString "EList" . showChar ' ' . showsPrec 1 exps . cpar n
|
||||
ETuple exp exps -> opar n . showString "ETuple" . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 exps . 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
|
||||
EInteger n -> opar n . showString "EInteger" . showChar ' ' . showsPrec 1 n . cpar n
|
||||
EDouble d -> opar n . showString "EDouble" . showChar ' ' . showsPrec 1 d . cpar n
|
||||
EMeta -> showString "EMeta"
|
||||
VVar i -> opar n . showString "VVar" . showChar ' ' . showsPrec 1 i . cpar n
|
||||
VWild -> showString "VWild"
|
||||
LetDef i exp -> opar n . showString "LetDef" . showChar ' ' . showsPrec 1 i . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
Case pattern guard exp -> opar n . showString "Case" . showChar ' ' . showsPrec 1 pattern . showChar ' ' . showsPrec 1 guard . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
BindVar varorwild exp -> opar n . showString "BindVar" . showChar ' ' . showsPrec 1 varorwild . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
BindNoVar exp -> opar n . showString "BindNoVar" . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
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 guard exp) (ValueDecl i_ patterns_ guard_ exp_) = i == i_ && patterns == patterns_ && guard == guard_ && 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 (GuardExp exp) (GuardExp exp_) = exp == exp_
|
||||
johnMajorEq GuardNo GuardNo = True
|
||||
johnMajorEq (POr pattern0 pattern1) (POr pattern0_ pattern1_) = pattern0 == pattern0_ && pattern1 == pattern1_
|
||||
johnMajorEq (PListCons pattern0 pattern1) (PListCons pattern0_ pattern1_) = pattern0 == pattern0_ && pattern1 == pattern1_
|
||||
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 PEmptyList PEmptyList = True
|
||||
johnMajorEq (PList commapatterns) (PList commapatterns_) = commapatterns == commapatterns_
|
||||
johnMajorEq (PTuple commapattern commapatterns) (PTuple commapattern_ commapatterns_) = commapattern == commapattern_ && commapatterns == commapatterns_
|
||||
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 (CommaPattern pattern) (CommaPattern pattern_) = pattern == pattern_
|
||||
johnMajorEq (FieldPattern i pattern) (FieldPattern i_ pattern_) = i == i_ && pattern == pattern_
|
||||
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 (EAbs varorwild exp) (EAbs varorwild_ exp_) = varorwild == varorwild_ && exp == exp_
|
||||
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 (EDo binds exp) (EDo binds_ exp_) = binds == binds_ && exp == exp_
|
||||
johnMajorEq (EBind exp0 exp1) (EBind exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
|
||||
johnMajorEq (EBindC exp0 exp1) (EBindC 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 (EListCons exp0 exp1) (EListCons 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 (ENeg exp) (ENeg exp_) = exp == exp_
|
||||
johnMajorEq (EApp exp0 exp1) (EApp exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
|
||||
johnMajorEq (EProj exp i) (EProj exp_ i_) = exp == exp_ && i == i_
|
||||
johnMajorEq (ERecType fieldtypes) (ERecType fieldtypes_) = fieldtypes == fieldtypes_
|
||||
johnMajorEq (ERec fieldvalues) (ERec fieldvalues_) = fieldvalues == fieldvalues_
|
||||
johnMajorEq EEmptyList EEmptyList = True
|
||||
johnMajorEq (EList exps) (EList exps_) = exps == exps_
|
||||
johnMajorEq (ETuple exp exps) (ETuple exp_ exps_) = exp == exp_ && exps == exps_
|
||||
johnMajorEq (EVar i) (EVar i_) = i == i_
|
||||
johnMajorEq EType EType = True
|
||||
johnMajorEq (EStr str) (EStr str_) = str == str_
|
||||
johnMajorEq (EInteger n) (EInteger n_) = n == n_
|
||||
johnMajorEq (EDouble d) (EDouble d_) = d == d_
|
||||
johnMajorEq EMeta EMeta = True
|
||||
johnMajorEq (VVar i) (VVar i_) = i == i_
|
||||
johnMajorEq VWild VWild = True
|
||||
johnMajorEq (LetDef i exp) (LetDef i_ exp_) = i == i_ && exp == exp_
|
||||
johnMajorEq (Case pattern guard exp) (Case pattern_ guard_ exp_) = pattern == pattern_ && guard == guard_ && exp == exp_
|
||||
johnMajorEq (BindVar varorwild exp) (BindVar varorwild_ exp_) = varorwild == varorwild_ && exp == exp_
|
||||
johnMajorEq (BindNoVar exp) (BindNoVar exp_) = exp == exp_
|
||||
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
|
||||
index :: Tree c -> Int
|
||||
index (Module _ _) = 0
|
||||
index (Import _) = 1
|
||||
index (DataDecl _ _ _) = 2
|
||||
index (TypeDecl _ _) = 3
|
||||
index (ValueDecl _ _ _ _) = 4
|
||||
index (DeriveDecl _ _) = 5
|
||||
index (ConsDecl _ _) = 6
|
||||
index (GuardExp _) = 7
|
||||
index (GuardNo ) = 8
|
||||
index (POr _ _) = 9
|
||||
index (PListCons _ _) = 10
|
||||
index (PConsTop _ _ _) = 11
|
||||
index (PCons _ _) = 12
|
||||
index (PRec _) = 13
|
||||
index (PEmptyList ) = 14
|
||||
index (PList _) = 15
|
||||
index (PTuple _ _) = 16
|
||||
index (PStr _) = 17
|
||||
index (PInt _) = 18
|
||||
index (PVar _) = 19
|
||||
index (PWild ) = 20
|
||||
index (CommaPattern _) = 21
|
||||
index (FieldPattern _ _) = 22
|
||||
index (EPi _ _ _) = 23
|
||||
index (EPiNoVar _ _) = 24
|
||||
index (EAbs _ _) = 25
|
||||
index (ELet _ _) = 26
|
||||
index (ECase _ _) = 27
|
||||
index (EIf _ _ _) = 28
|
||||
index (EDo _ _) = 29
|
||||
index (EBind _ _) = 30
|
||||
index (EBindC _ _) = 31
|
||||
index (EOr _ _) = 32
|
||||
index (EAnd _ _) = 33
|
||||
index (EEq _ _) = 34
|
||||
index (ENe _ _) = 35
|
||||
index (ELt _ _) = 36
|
||||
index (ELe _ _) = 37
|
||||
index (EGt _ _) = 38
|
||||
index (EGe _ _) = 39
|
||||
index (EListCons _ _) = 40
|
||||
index (EAdd _ _) = 41
|
||||
index (ESub _ _) = 42
|
||||
index (EMul _ _) = 43
|
||||
index (EDiv _ _) = 44
|
||||
index (EMod _ _) = 45
|
||||
index (ENeg _) = 46
|
||||
index (EApp _ _) = 47
|
||||
index (EProj _ _) = 48
|
||||
index (ERecType _) = 49
|
||||
index (ERec _) = 50
|
||||
index (EEmptyList ) = 51
|
||||
index (EList _) = 52
|
||||
index (ETuple _ _) = 53
|
||||
index (EVar _) = 54
|
||||
index (EType ) = 55
|
||||
index (EStr _) = 56
|
||||
index (EInteger _) = 57
|
||||
index (EDouble _) = 58
|
||||
index (EMeta ) = 59
|
||||
index (VVar _) = 60
|
||||
index (VWild ) = 61
|
||||
index (LetDef _ _) = 62
|
||||
index (Case _ _ _) = 63
|
||||
index (BindVar _ _) = 64
|
||||
index (BindNoVar _) = 65
|
||||
index (FieldType _ _) = 66
|
||||
index (FieldValue _ _) = 67
|
||||
index (Ident _) = 68
|
||||
compareSame :: Tree c -> Tree c -> Ordering
|
||||
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 guard exp) (ValueDecl i_ patterns_ guard_ exp_) = mappend (compare i i_) (mappend (compare patterns patterns_) (mappend (compare guard guard_) (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 (GuardExp exp) (GuardExp exp_) = compare exp exp_
|
||||
compareSame GuardNo GuardNo = EQ
|
||||
compareSame (POr pattern0 pattern1) (POr pattern0_ pattern1_) = mappend (compare pattern0 pattern0_) (compare pattern1 pattern1_)
|
||||
compareSame (PListCons pattern0 pattern1) (PListCons pattern0_ pattern1_) = mappend (compare pattern0 pattern0_) (compare pattern1 pattern1_)
|
||||
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 PEmptyList PEmptyList = EQ
|
||||
compareSame (PList commapatterns) (PList commapatterns_) = compare commapatterns commapatterns_
|
||||
compareSame (PTuple commapattern commapatterns) (PTuple commapattern_ commapatterns_) = mappend (compare commapattern commapattern_) (compare commapatterns commapatterns_)
|
||||
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 (CommaPattern pattern) (CommaPattern pattern_) = compare pattern pattern_
|
||||
compareSame (FieldPattern i pattern) (FieldPattern i_ pattern_) = mappend (compare i i_) (compare pattern pattern_)
|
||||
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 (EAbs varorwild exp) (EAbs varorwild_ exp_) = mappend (compare varorwild varorwild_) (compare exp exp_)
|
||||
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 (EDo binds exp) (EDo binds_ exp_) = mappend (compare binds binds_) (compare exp exp_)
|
||||
compareSame (EBind exp0 exp1) (EBind exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
|
||||
compareSame (EBindC exp0 exp1) (EBindC 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 (EListCons exp0 exp1) (EListCons 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 (ENeg exp) (ENeg exp_) = compare exp exp_
|
||||
compareSame (EApp exp0 exp1) (EApp exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
|
||||
compareSame (EProj exp i) (EProj exp_ i_) = mappend (compare exp exp_) (compare i i_)
|
||||
compareSame (ERecType fieldtypes) (ERecType fieldtypes_) = compare fieldtypes fieldtypes_
|
||||
compareSame (ERec fieldvalues) (ERec fieldvalues_) = compare fieldvalues fieldvalues_
|
||||
compareSame EEmptyList EEmptyList = EQ
|
||||
compareSame (EList exps) (EList exps_) = compare exps exps_
|
||||
compareSame (ETuple exp exps) (ETuple exp_ exps_) = mappend (compare exp exp_) (compare exps exps_)
|
||||
compareSame (EVar i) (EVar i_) = compare i i_
|
||||
compareSame EType EType = EQ
|
||||
compareSame (EStr str) (EStr str_) = compare str str_
|
||||
compareSame (EInteger n) (EInteger n_) = compare n n_
|
||||
compareSame (EDouble d) (EDouble d_) = compare d d_
|
||||
compareSame EMeta EMeta = EQ
|
||||
compareSame (VVar i) (VVar i_) = compare i i_
|
||||
compareSame VWild VWild = EQ
|
||||
compareSame (LetDef i exp) (LetDef i_ exp_) = mappend (compare i i_) (compare exp exp_)
|
||||
compareSame (Case pattern guard exp) (Case pattern_ guard_ exp_) = mappend (compare pattern pattern_) (mappend (compare guard guard_) (compare exp exp_))
|
||||
compareSame (BindVar varorwild exp) (BindVar varorwild_ exp_) = mappend (compare varorwild varorwild_) (compare exp exp_)
|
||||
compareSame (BindNoVar exp) (BindNoVar exp_) = compare exp exp_
|
||||
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
|
||||
@@ -1,333 +0,0 @@
|
||||
\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.
|
||||
|
||||
|
||||
Double-precision float literals \nonterminal{Double}\ have the structure
|
||||
indicated by the regular expression $\nonterminal{digit}+ \mbox{{\it `.'}} \nonterminal{digit}+ (\mbox{{\it `e'}} \mbox{{\it `-'}}? \nonterminal{digit}+)?$ i.e.\
|
||||
two sequences of digits separated by a decimal point, optionally
|
||||
followed by an unsigned or negative exponent.
|
||||
|
||||
|
||||
|
||||
|
||||
\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{do}} &{\reserved{else}} \\
|
||||
{\reserved{if}} &{\reserved{import}} &{\reserved{in}} \\
|
||||
{\reserved{let}} &{\reserved{of}} &{\reserved{rec}} \\
|
||||
{\reserved{sig}} &{\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{)}} &{\symb{[}} &{\symb{]}} \\
|
||||
{\symb{,}} &{\symb{\_}} &{\symb{{$-$}{$>$}}} \\
|
||||
{\symb{$\backslash$}} &{\symb{{$<$}{$-$}}} &{\symb{{$>$}{$>$}{$=$}}} \\
|
||||
{\symb{{$>$}{$>$}}} &{\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}} {\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}} {\nonterminal{Guard}} {\terminal{{$=$}}} {\nonterminal{Exp}} \\
|
||||
& {\delimit} &{\terminal{derive}} {\nonterminal{Ident}} {\nonterminal{Ident}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListDecl}} & {\arrow} &{\emptyP} \\
|
||||
& {\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{Guard}} & {\arrow} &{\terminal{{$|$}}} {\nonterminal{Exp1}} \\
|
||||
& {\delimit} &{\emptyP} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Pattern}} & {\arrow} &{\nonterminal{Pattern1}} {\terminal{{$|$}{$|$}}} {\nonterminal{Pattern}} \\
|
||||
& {\delimit} &{\nonterminal{Pattern1}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Pattern1}} & {\arrow} &{\nonterminal{Pattern2}} {\terminal{::}} {\nonterminal{Pattern1}} \\
|
||||
& {\delimit} &{\nonterminal{Pattern2}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Pattern2}} & {\arrow} &{\nonterminal{Ident}} {\nonterminal{Pattern3}} {\nonterminal{ListPattern}} \\
|
||||
& {\delimit} &{\nonterminal{Pattern3}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Pattern3}} & {\arrow} &{\terminal{rec}} {\terminal{\{}} {\nonterminal{ListFieldPattern}} {\terminal{\}}} \\
|
||||
& {\delimit} &{\terminal{[}} {\terminal{]}} \\
|
||||
& {\delimit} &{\terminal{[}} {\nonterminal{ListCommaPattern}} {\terminal{]}} \\
|
||||
& {\delimit} &{\terminal{(}} {\nonterminal{CommaPattern}} {\terminal{,}} {\nonterminal{ListCommaPattern}} {\terminal{)}} \\
|
||||
& {\delimit} &{\nonterminal{String}} \\
|
||||
& {\delimit} &{\nonterminal{Integer}} \\
|
||||
& {\delimit} &{\nonterminal{Ident}} \\
|
||||
& {\delimit} &{\terminal{\_}} \\
|
||||
& {\delimit} &{\terminal{(}} {\nonterminal{Pattern}} {\terminal{)}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{CommaPattern}} & {\arrow} &{\nonterminal{Pattern}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListCommaPattern}} & {\arrow} &{\nonterminal{CommaPattern}} \\
|
||||
& {\delimit} &{\nonterminal{CommaPattern}} {\terminal{,}} {\nonterminal{ListCommaPattern}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListPattern}} & {\arrow} &{\emptyP} \\
|
||||
& {\delimit} &{\nonterminal{Pattern3}} {\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{(}} {\nonterminal{VarOrWild}} {\terminal{:}} {\nonterminal{Exp}} {\terminal{)}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}} \\
|
||||
& {\delimit} &{\nonterminal{Exp1}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp}} \\
|
||||
& {\delimit} &{\nonterminal{Exp1}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{VarOrWild}} & {\arrow} &{\nonterminal{Ident}} \\
|
||||
& {\delimit} &{\terminal{\_}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp1}} & {\arrow} &{\terminal{$\backslash$}} {\nonterminal{VarOrWild}} {\terminal{{$-$}{$>$}}} {\nonterminal{Exp1}} \\
|
||||
& {\delimit} &{\terminal{let}} {\terminal{\{}} {\nonterminal{ListLetDef}} {\terminal{\}}} {\terminal{in}} {\nonterminal{Exp1}} \\
|
||||
& {\delimit} &{\terminal{case}} {\nonterminal{Exp}} {\terminal{of}} {\terminal{\{}} {\nonterminal{ListCase}} {\terminal{\}}} \\
|
||||
& {\delimit} &{\terminal{if}} {\nonterminal{Exp}} {\terminal{then}} {\nonterminal{Exp}} {\terminal{else}} {\nonterminal{Exp1}} \\
|
||||
& {\delimit} &{\terminal{do}} {\terminal{\{}} {\nonterminal{ListBind}} {\nonterminal{Exp}} {\terminal{\}}} \\
|
||||
& {\delimit} &{\nonterminal{Exp2}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{LetDef}} & {\arrow} &{\nonterminal{Ident}} {\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}} {\nonterminal{Guard}} {\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{Bind}} & {\arrow} &{\nonterminal{VarOrWild}} {\terminal{{$<$}{$-$}}} {\nonterminal{Exp}} \\
|
||||
& {\delimit} &{\nonterminal{Exp}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListBind}} & {\arrow} &{\emptyP} \\
|
||||
& {\delimit} &{\nonterminal{Bind}} {\terminal{;}} {\nonterminal{ListBind}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp3}} & {\arrow} &{\nonterminal{Exp3}} {\terminal{{$>$}{$>$}{$=$}}} {\nonterminal{Exp4}} \\
|
||||
& {\delimit} &{\nonterminal{Exp3}} {\terminal{{$>$}{$>$}}} {\nonterminal{Exp4}} \\
|
||||
& {\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{Exp5}} \\
|
||||
& {\delimit} &{\nonterminal{Exp6}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp6}} & {\arrow} &{\nonterminal{Exp7}} {\terminal{{$=$}{$=$}}} {\nonterminal{Exp7}} \\
|
||||
& {\delimit} &{\nonterminal{Exp7}} {\terminal{/{$=$}}} {\nonterminal{Exp7}} \\
|
||||
& {\delimit} &{\nonterminal{Exp7}} {\terminal{{$<$}}} {\nonterminal{Exp7}} \\
|
||||
& {\delimit} &{\nonterminal{Exp7}} {\terminal{{$<$}{$=$}}} {\nonterminal{Exp7}} \\
|
||||
& {\delimit} &{\nonterminal{Exp7}} {\terminal{{$>$}}} {\nonterminal{Exp7}} \\
|
||||
& {\delimit} &{\nonterminal{Exp7}} {\terminal{{$>$}{$=$}}} {\nonterminal{Exp7}} \\
|
||||
& {\delimit} &{\nonterminal{Exp7}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp7}} & {\arrow} &{\nonterminal{Exp8}} {\terminal{::}} {\nonterminal{Exp7}} \\
|
||||
& {\delimit} &{\nonterminal{Exp8}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp8}} & {\arrow} &{\nonterminal{Exp8}} {\terminal{{$+$}}} {\nonterminal{Exp9}} \\
|
||||
& {\delimit} &{\nonterminal{Exp8}} {\terminal{{$-$}}} {\nonterminal{Exp9}} \\
|
||||
& {\delimit} &{\nonterminal{Exp9}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp9}} & {\arrow} &{\nonterminal{Exp9}} {\terminal{*}} {\nonterminal{Exp10}} \\
|
||||
& {\delimit} &{\nonterminal{Exp9}} {\terminal{/}} {\nonterminal{Exp10}} \\
|
||||
& {\delimit} &{\nonterminal{Exp9}} {\terminal{\%}} {\nonterminal{Exp10}} \\
|
||||
& {\delimit} &{\nonterminal{Exp10}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp10}} & {\arrow} &{\terminal{{$-$}}} {\nonterminal{Exp10}} \\
|
||||
& {\delimit} &{\nonterminal{Exp11}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp11}} & {\arrow} &{\nonterminal{Exp11}} {\nonterminal{Exp12}} \\
|
||||
& {\delimit} &{\nonterminal{Exp12}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp12}} & {\arrow} &{\nonterminal{Exp12}} {\terminal{.}} {\nonterminal{Ident}} \\
|
||||
& {\delimit} &{\nonterminal{Exp13}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp13}} & {\arrow} &{\terminal{sig}} {\terminal{\{}} {\nonterminal{ListFieldType}} {\terminal{\}}} \\
|
||||
& {\delimit} &{\terminal{rec}} {\terminal{\{}} {\nonterminal{ListFieldValue}} {\terminal{\}}} \\
|
||||
& {\delimit} &{\terminal{[}} {\terminal{]}} \\
|
||||
& {\delimit} &{\terminal{[}} {\nonterminal{ListExp}} {\terminal{]}} \\
|
||||
& {\delimit} &{\terminal{(}} {\nonterminal{Exp}} {\terminal{,}} {\nonterminal{ListExp}} {\terminal{)}} \\
|
||||
& {\delimit} &{\nonterminal{Ident}} \\
|
||||
& {\delimit} &{\terminal{Type}} \\
|
||||
& {\delimit} &{\nonterminal{String}} \\
|
||||
& {\delimit} &{\nonterminal{Integer}} \\
|
||||
& {\delimit} &{\nonterminal{Double}} \\
|
||||
& {\delimit} &{\terminal{?}} \\
|
||||
& {\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} &{\emptyP} \\
|
||||
& {\delimit} &{\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} &{\emptyP} \\
|
||||
& {\delimit} &{\nonterminal{FieldValue}} \\
|
||||
& {\delimit} &{\nonterminal{FieldValue}} {\terminal{;}} {\nonterminal{ListFieldValue}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{Exp2}} & {\arrow} &{\nonterminal{Exp3}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
\begin{tabular}{lll}
|
||||
{\nonterminal{ListExp}} & {\arrow} &{\nonterminal{Exp}} \\
|
||||
& {\delimit} &{\nonterminal{Exp}} {\terminal{,}} {\nonterminal{ListExp}} \\
|
||||
\end{tabular}\\
|
||||
|
||||
|
||||
|
||||
\end{document}
|
||||
|
||||
@@ -1,227 +0,0 @@
|
||||
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","rec","sig","do"]
|
||||
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 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 implicit block by a layout stop word
|
||||
| isStop t0 =
|
||||
-- Exit the current block and all implicit blocks
|
||||
-- more indented than the current token
|
||||
let (ebs,ns') = span (`moreIndent` column t0) ns
|
||||
moreIndent (Implicit x) y = x > y
|
||||
moreIndent Explicit _ = False
|
||||
-- the number of blocks exited
|
||||
b = 1 + length ebs
|
||||
bs = replicate b layoutClose
|
||||
-- Insert closing braces after the previous token.
|
||||
(ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)
|
||||
in moveAlong ns' ts1 ts2
|
||||
|
||||
-- End of an implicit layout block
|
||||
| newLine && column t0 < n =
|
||||
-- Insert a closing brace after the previous token.
|
||||
let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)
|
||||
-- Repeat, with the current block removed from the stack
|
||||
in moveAlong ns [b] (t0':ts')
|
||||
|
||||
-- Encounted a new line in an implicit layout block.
|
||||
| newLine && column t0 == n =
|
||||
-- Insert a semicolon after the previous token.
|
||||
-- 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 (afterPrev pt) layoutSep (t0:ts)
|
||||
in moveAlong st [b,t0'] ts'
|
||||
where newLine = case pt of
|
||||
Nothing -> True
|
||||
Just t -> line t /= line t0
|
||||
|
||||
-- Nothing to see here, move along.
|
||||
res _ st (t:ts) = moveAlong st [t] ts
|
||||
|
||||
-- At EOF: skip explicit blocks.
|
||||
res (Just t) (Explicit:bs) [] | null bs = []
|
||||
| otherwise = res (Just t) bs []
|
||||
|
||||
-- If we are using top-level layout, insert a semicolon after
|
||||
-- the last token, if there isn't one already
|
||||
res (Just t) [Implicit n] []
|
||||
| isTokenIn [layoutSep] t = []
|
||||
| otherwise = addToken (nextPos t) layoutSep []
|
||||
|
||||
-- At EOF in an implicit, non-top-level block: close the block
|
||||
res (Just t) (Implicit n:bs) [] =
|
||||
let c = addToken (nextPos t) layoutClose []
|
||||
in moveAlong bs c []
|
||||
|
||||
-- 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
|
||||
|
||||
-- | 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.
|
||||
-- If no token is given, gets the first position in the file.
|
||||
afterPrev :: Maybe Token -> Position
|
||||
afterPrev = maybe (Pn 0 1 1) nextPos
|
||||
|
||||
-- | 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
|
||||
|
||||
File diff suppressed because one or more lines are too long
@@ -1,134 +0,0 @@
|
||||
-- -*- haskell -*-
|
||||
-- This Alex file was machine-generated by the BNF converter
|
||||
{
|
||||
{-# OPTIONS -fno-warn-incomplete-patterns #-}
|
||||
module Transfer.Syntax.Lex where
|
||||
|
||||
|
||||
}
|
||||
|
||||
|
||||
$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
|
||||
$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
|
||||
$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
|
||||
$d = [0-9] -- digit
|
||||
$i = [$l $d _ '] -- identifier character
|
||||
$u = [\0-\255] -- universal: any character
|
||||
|
||||
@rsyms = -- symbols and non-identifier-like reserved words
|
||||
\; | \: | \{ | \} | \= | \| | \| \| | \: \: | \( | \) | \[ | \] | \, | \_ | \- \> | \\ | \< \- | \> \> \= | \> \> | \& \& | \= \= | \/ \= | \< | \< \= | \> | \> \= | \+ | \- | \* | \/ | \% | \. | \?
|
||||
|
||||
:-
|
||||
"--" [.]* ; -- Toss single line comments
|
||||
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
|
||||
|
||||
$white+ ;
|
||||
@rsyms { tok (\p s -> PT p (TS $ share s)) }
|
||||
|
||||
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
|
||||
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
|
||||
|
||||
$d+ { tok (\p s -> PT p (TI $ share s)) }
|
||||
$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
|
||||
|
||||
{
|
||||
|
||||
tok f p s = f p s
|
||||
|
||||
share :: String -> String
|
||||
share = id
|
||||
|
||||
data Tok =
|
||||
TS !String -- reserved words and symbols
|
||||
| TL !String -- string literals
|
||||
| TI !String -- integer literals
|
||||
| TV !String -- identifiers
|
||||
| TD !String -- double precision float literals
|
||||
| TC !String -- character literals
|
||||
|
||||
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 "else" (b "do" N N) (b "if" N N))) (b "rec" (b "let" (b "in" N N) (b "of" N N)) (b "then" (b "sig" 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
|
||||
}
|
||||
File diff suppressed because one or more lines are too long
@@ -1,340 +0,0 @@
|
||||
-- This Happy file was machine-generated by the BNF converter
|
||||
{
|
||||
{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
|
||||
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 "<=") }
|
||||
'>' { 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") }
|
||||
'do' { PT _ (TS "do") }
|
||||
'else' { PT _ (TS "else") }
|
||||
'if' { PT _ (TS "if") }
|
||||
'import' { PT _ (TS "import") }
|
||||
'in' { PT _ (TS "in") }
|
||||
'let' { PT _ (TS "let") }
|
||||
'of' { PT _ (TS "of") }
|
||||
'rec' { PT _ (TS "rec") }
|
||||
'sig' { PT _ (TS "sig") }
|
||||
'then' { PT _ (TS "then") }
|
||||
'where' { PT _ (TS "where") }
|
||||
|
||||
L_ident { PT _ (TV $$) }
|
||||
L_quoted { PT _ (TL $$) }
|
||||
L_integ { PT _ (TI $$) }
|
||||
L_doubl { PT _ (TD $$) }
|
||||
L_err { _ }
|
||||
|
||||
|
||||
%%
|
||||
|
||||
Ident :: { Ident } : L_ident { Ident $1 }
|
||||
String :: { String } : L_quoted { $1 }
|
||||
Integer :: { Integer } : L_integ { (read $1) :: Integer }
|
||||
Double :: { Double } : L_doubl { (read $1) :: Double }
|
||||
|
||||
Module :: { Module }
|
||||
Module : ListImport ListDecl { Module (reverse $1) (reverse $2) }
|
||||
|
||||
|
||||
Import :: { Import }
|
||||
Import : 'import' Ident { Import $2 }
|
||||
|
||||
|
||||
ListImport :: { [Import] }
|
||||
ListImport : {- empty -} { [] }
|
||||
| ListImport Import ';' { flip (:) $1 $2 }
|
||||
|
||||
|
||||
Decl :: { Decl }
|
||||
Decl : 'data' Ident ':' Exp 'where' '{' ListConsDecl '}' { DataDecl $2 $4 $7 }
|
||||
| Ident ':' Exp { TypeDecl $1 $3 }
|
||||
| Ident ListPattern Guard '=' Exp { ValueDecl $1 (reverse $2) $3 $5 }
|
||||
| 'derive' Ident Ident { DeriveDecl $2 $3 }
|
||||
|
||||
|
||||
ListDecl :: { [Decl] }
|
||||
ListDecl : {- empty -} { [] }
|
||||
| ListDecl Decl ';' { flip (:) $1 $2 }
|
||||
|
||||
|
||||
ConsDecl :: { ConsDecl }
|
||||
ConsDecl : Ident ':' Exp { ConsDecl $1 $3 }
|
||||
|
||||
|
||||
ListConsDecl :: { [ConsDecl] }
|
||||
ListConsDecl : {- empty -} { [] }
|
||||
| ConsDecl { (:[]) $1 }
|
||||
| ConsDecl ';' ListConsDecl { (:) $1 $3 }
|
||||
|
||||
|
||||
Guard :: { Guard }
|
||||
Guard : '|' Exp1 { GuardExp $2 }
|
||||
| {- empty -} { GuardNo }
|
||||
|
||||
|
||||
Pattern :: { Pattern }
|
||||
Pattern : Pattern1 '||' Pattern { POr $1 $3 }
|
||||
| Pattern1 { $1 }
|
||||
|
||||
|
||||
Pattern1 :: { Pattern }
|
||||
Pattern1 : Pattern2 '::' Pattern1 { PListCons $1 $3 }
|
||||
| Pattern2 { $1 }
|
||||
|
||||
|
||||
Pattern2 :: { Pattern }
|
||||
Pattern2 : Ident Pattern3 ListPattern { PConsTop $1 $2 (reverse $3) }
|
||||
| Pattern3 { $1 }
|
||||
|
||||
|
||||
Pattern3 :: { Pattern }
|
||||
Pattern3 : 'rec' '{' ListFieldPattern '}' { PRec $3 }
|
||||
| '[' ']' { PEmptyList }
|
||||
| '[' ListCommaPattern ']' { PList $2 }
|
||||
| '(' CommaPattern ',' ListCommaPattern ')' { PTuple $2 $4 }
|
||||
| String { PStr $1 }
|
||||
| Integer { PInt $1 }
|
||||
| Ident { PVar $1 }
|
||||
| '_' { PWild }
|
||||
| '(' Pattern ')' { $2 }
|
||||
|
||||
|
||||
CommaPattern :: { CommaPattern }
|
||||
CommaPattern : Pattern { CommaPattern $1 }
|
||||
|
||||
|
||||
ListCommaPattern :: { [CommaPattern] }
|
||||
ListCommaPattern : CommaPattern { (:[]) $1 }
|
||||
| CommaPattern ',' ListCommaPattern { (:) $1 $3 }
|
||||
|
||||
|
||||
ListPattern :: { [Pattern] }
|
||||
ListPattern : {- empty -} { [] }
|
||||
| ListPattern Pattern3 { flip (:) $1 $2 }
|
||||
|
||||
|
||||
FieldPattern :: { FieldPattern }
|
||||
FieldPattern : Ident '=' Pattern { FieldPattern $1 $3 }
|
||||
|
||||
|
||||
ListFieldPattern :: { [FieldPattern] }
|
||||
ListFieldPattern : {- empty -} { [] }
|
||||
| FieldPattern { (:[]) $1 }
|
||||
| FieldPattern ';' ListFieldPattern { (:) $1 $3 }
|
||||
|
||||
|
||||
Exp :: { Exp }
|
||||
Exp : '(' VarOrWild ':' Exp ')' '->' Exp { EPi $2 $4 $7 }
|
||||
| Exp1 '->' Exp { EPiNoVar $1 $3 }
|
||||
| Exp1 { $1 }
|
||||
|
||||
|
||||
VarOrWild :: { VarOrWild }
|
||||
VarOrWild : Ident { VVar $1 }
|
||||
| '_' { VWild }
|
||||
|
||||
|
||||
Exp1 :: { Exp }
|
||||
Exp1 : '\\' VarOrWild '->' Exp1 { EAbs $2 $4 }
|
||||
| 'let' '{' ListLetDef '}' 'in' Exp1 { ELet $3 $6 }
|
||||
| 'case' Exp 'of' '{' ListCase '}' { ECase $2 $5 }
|
||||
| 'if' Exp 'then' Exp 'else' Exp1 { EIf $2 $4 $6 }
|
||||
| 'do' '{' ListBind Exp '}' { EDo (reverse $3) $4 }
|
||||
| Exp2 { $1 }
|
||||
|
||||
|
||||
LetDef :: { LetDef }
|
||||
LetDef : Ident '=' Exp { LetDef $1 $3 }
|
||||
|
||||
|
||||
ListLetDef :: { [LetDef] }
|
||||
ListLetDef : {- empty -} { [] }
|
||||
| LetDef { (:[]) $1 }
|
||||
| LetDef ';' ListLetDef { (:) $1 $3 }
|
||||
|
||||
|
||||
Case :: { Case }
|
||||
Case : Pattern Guard '->' Exp { Case $1 $2 $4 }
|
||||
|
||||
|
||||
ListCase :: { [Case] }
|
||||
ListCase : {- empty -} { [] }
|
||||
| Case { (:[]) $1 }
|
||||
| Case ';' ListCase { (:) $1 $3 }
|
||||
|
||||
|
||||
Bind :: { Bind }
|
||||
Bind : VarOrWild '<-' Exp { BindVar $1 $3 }
|
||||
| Exp { BindNoVar $1 }
|
||||
|
||||
|
||||
ListBind :: { [Bind] }
|
||||
ListBind : {- empty -} { [] }
|
||||
| ListBind Bind ';' { flip (:) $1 $2 }
|
||||
|
||||
|
||||
Exp3 :: { Exp }
|
||||
Exp3 : Exp3 '>>=' Exp4 { EBind $1 $3 }
|
||||
| Exp3 '>>' Exp4 { EBindC $1 $3 }
|
||||
| Exp4 { $1 }
|
||||
|
||||
|
||||
Exp4 :: { Exp }
|
||||
Exp4 : Exp5 '||' Exp4 { EOr $1 $3 }
|
||||
| Exp5 { $1 }
|
||||
|
||||
|
||||
Exp5 :: { Exp }
|
||||
Exp5 : Exp6 '&&' Exp5 { EAnd $1 $3 }
|
||||
| Exp6 { $1 }
|
||||
|
||||
|
||||
Exp6 :: { Exp }
|
||||
Exp6 : Exp7 '==' Exp7 { EEq $1 $3 }
|
||||
| Exp7 '/=' Exp7 { ENe $1 $3 }
|
||||
| Exp7 '<' Exp7 { ELt $1 $3 }
|
||||
| Exp7 '<=' Exp7 { ELe $1 $3 }
|
||||
| Exp7 '>' Exp7 { EGt $1 $3 }
|
||||
| Exp7 '>=' Exp7 { EGe $1 $3 }
|
||||
| Exp7 { $1 }
|
||||
|
||||
|
||||
Exp7 :: { Exp }
|
||||
Exp7 : Exp8 '::' Exp7 { EListCons $1 $3 }
|
||||
| Exp8 { $1 }
|
||||
|
||||
|
||||
Exp8 :: { Exp }
|
||||
Exp8 : Exp8 '+' Exp9 { EAdd $1 $3 }
|
||||
| Exp8 '-' Exp9 { ESub $1 $3 }
|
||||
| Exp9 { $1 }
|
||||
|
||||
|
||||
Exp9 :: { Exp }
|
||||
Exp9 : Exp9 '*' Exp10 { EMul $1 $3 }
|
||||
| Exp9 '/' Exp10 { EDiv $1 $3 }
|
||||
| Exp9 '%' Exp10 { EMod $1 $3 }
|
||||
| Exp10 { $1 }
|
||||
|
||||
|
||||
Exp10 :: { Exp }
|
||||
Exp10 : '-' Exp10 { ENeg $2 }
|
||||
| Exp11 { $1 }
|
||||
|
||||
|
||||
Exp11 :: { Exp }
|
||||
Exp11 : Exp11 Exp12 { EApp $1 $2 }
|
||||
| Exp12 { $1 }
|
||||
|
||||
|
||||
Exp12 :: { Exp }
|
||||
Exp12 : Exp12 '.' Ident { EProj $1 $3 }
|
||||
| Exp13 { $1 }
|
||||
|
||||
|
||||
Exp13 :: { Exp }
|
||||
Exp13 : 'sig' '{' ListFieldType '}' { ERecType $3 }
|
||||
| 'rec' '{' ListFieldValue '}' { ERec $3 }
|
||||
| '[' ']' { EEmptyList }
|
||||
| '[' ListExp ']' { EList $2 }
|
||||
| '(' Exp ',' ListExp ')' { ETuple $2 $4 }
|
||||
| Ident { EVar $1 }
|
||||
| 'Type' { EType }
|
||||
| String { EStr $1 }
|
||||
| Integer { EInteger $1 }
|
||||
| Double { EDouble $1 }
|
||||
| '?' { EMeta }
|
||||
| '(' Exp ')' { $2 }
|
||||
|
||||
|
||||
FieldType :: { FieldType }
|
||||
FieldType : Ident ':' Exp { FieldType $1 $3 }
|
||||
|
||||
|
||||
ListFieldType :: { [FieldType] }
|
||||
ListFieldType : {- empty -} { [] }
|
||||
| FieldType { (:[]) $1 }
|
||||
| FieldType ';' ListFieldType { (:) $1 $3 }
|
||||
|
||||
|
||||
FieldValue :: { FieldValue }
|
||||
FieldValue : Ident '=' Exp { FieldValue $1 $3 }
|
||||
|
||||
|
||||
ListFieldValue :: { [FieldValue] }
|
||||
ListFieldValue : {- empty -} { [] }
|
||||
| FieldValue { (:[]) $1 }
|
||||
| FieldValue ';' ListFieldValue { (:) $1 $3 }
|
||||
|
||||
|
||||
Exp2 :: { Exp }
|
||||
Exp2 : Exp3 { $1 }
|
||||
|
||||
|
||||
ListExp :: { [Exp] }
|
||||
ListExp : Exp { (:[]) $1 }
|
||||
| Exp ',' ListExp { (:) $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
|
||||
}
|
||||
|
||||
@@ -1,206 +0,0 @@
|
||||
{-# 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 guard exp -> prPrec _i 0 (concatD [prt 0 i , prt 0 patterns , prt 0 guard , 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])
|
||||
GuardExp exp -> prPrec _i 0 (concatD [doc (showString "|") , prt 1 exp])
|
||||
GuardNo -> prPrec _i 0 (concatD [])
|
||||
POr pattern0 pattern1 -> prPrec _i 0 (concatD [prt 1 pattern0 , doc (showString "||") , prt 0 pattern1])
|
||||
PListCons pattern0 pattern1 -> prPrec _i 1 (concatD [prt 2 pattern0 , doc (showString "::") , prt 1 pattern1])
|
||||
PConsTop i pattern patterns -> prPrec _i 2 (concatD [prt 0 i , prt 3 pattern , prt 0 patterns])
|
||||
PCons i patterns -> prPrec _i 3 (concatD [doc (showString "(") , prt 0 i , prt 0 patterns , doc (showString ")")])
|
||||
PRec fieldpatterns -> prPrec _i 3 (concatD [doc (showString "rec") , doc (showString "{") , prt 0 fieldpatterns , doc (showString "}")])
|
||||
PEmptyList -> prPrec _i 3 (concatD [doc (showString "[") , doc (showString "]")])
|
||||
PList commapatterns -> prPrec _i 3 (concatD [doc (showString "[") , prt 0 commapatterns , doc (showString "]")])
|
||||
PTuple commapattern commapatterns -> prPrec _i 3 (concatD [doc (showString "(") , prt 0 commapattern , doc (showString ",") , prt 0 commapatterns , doc (showString ")")])
|
||||
PStr str -> prPrec _i 3 (concatD [prt 0 str])
|
||||
PInt n -> prPrec _i 3 (concatD [prt 0 n])
|
||||
PVar i -> prPrec _i 3 (concatD [prt 0 i])
|
||||
PWild -> prPrec _i 3 (concatD [doc (showString "_")])
|
||||
CommaPattern pattern -> prPrec _i 0 (concatD [prt 0 pattern])
|
||||
FieldPattern i pattern -> prPrec _i 0 (concatD [prt 0 i , doc (showString "=") , prt 0 pattern])
|
||||
EPi varorwild exp0 exp1 -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 varorwild , doc (showString ":") , prt 0 exp0 , doc (showString ")") , doc (showString "->") , prt 0 exp1])
|
||||
EPiNoVar exp0 exp1 -> prPrec _i 0 (concatD [prt 1 exp0 , doc (showString "->") , prt 0 exp1])
|
||||
EAbs varorwild exp -> prPrec _i 1 (concatD [doc (showString "\\") , prt 0 varorwild , doc (showString "->") , prt 1 exp])
|
||||
ELet letdefs exp -> prPrec _i 1 (concatD [doc (showString "let") , doc (showString "{") , prt 0 letdefs , doc (showString "}") , doc (showString "in") , prt 1 exp])
|
||||
ECase exp cases -> prPrec _i 1 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
|
||||
EIf exp0 exp1 exp2 -> prPrec _i 1 (concatD [doc (showString "if") , prt 0 exp0 , doc (showString "then") , prt 0 exp1 , doc (showString "else") , prt 1 exp2])
|
||||
EDo binds exp -> prPrec _i 1 (concatD [doc (showString "do") , doc (showString "{") , prt 0 binds , prt 0 exp , doc (showString "}")])
|
||||
EBind exp0 exp1 -> prPrec _i 3 (concatD [prt 3 exp0 , doc (showString ">>=") , prt 4 exp1])
|
||||
EBindC exp0 exp1 -> prPrec _i 3 (concatD [prt 3 exp0 , doc (showString ">>") , prt 4 exp1])
|
||||
EOr exp0 exp1 -> prPrec _i 4 (concatD [prt 5 exp0 , doc (showString "||") , prt 4 exp1])
|
||||
EAnd exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "&&") , prt 5 exp1])
|
||||
EEq exp0 exp1 -> prPrec _i 6 (concatD [prt 7 exp0 , doc (showString "==") , prt 7 exp1])
|
||||
ENe exp0 exp1 -> prPrec _i 6 (concatD [prt 7 exp0 , doc (showString "/=") , prt 7 exp1])
|
||||
ELt exp0 exp1 -> prPrec _i 6 (concatD [prt 7 exp0 , doc (showString "<") , prt 7 exp1])
|
||||
ELe exp0 exp1 -> prPrec _i 6 (concatD [prt 7 exp0 , doc (showString "<=") , prt 7 exp1])
|
||||
EGt exp0 exp1 -> prPrec _i 6 (concatD [prt 7 exp0 , doc (showString ">") , prt 7 exp1])
|
||||
EGe exp0 exp1 -> prPrec _i 6 (concatD [prt 7 exp0 , doc (showString ">=") , prt 7 exp1])
|
||||
EListCons exp0 exp1 -> prPrec _i 7 (concatD [prt 8 exp0 , doc (showString "::") , prt 7 exp1])
|
||||
EAdd exp0 exp1 -> prPrec _i 8 (concatD [prt 8 exp0 , doc (showString "+") , prt 9 exp1])
|
||||
ESub exp0 exp1 -> prPrec _i 8 (concatD [prt 8 exp0 , doc (showString "-") , prt 9 exp1])
|
||||
EMul exp0 exp1 -> prPrec _i 9 (concatD [prt 9 exp0 , doc (showString "*") , prt 10 exp1])
|
||||
EDiv exp0 exp1 -> prPrec _i 9 (concatD [prt 9 exp0 , doc (showString "/") , prt 10 exp1])
|
||||
EMod exp0 exp1 -> prPrec _i 9 (concatD [prt 9 exp0 , doc (showString "%") , prt 10 exp1])
|
||||
ENeg exp -> prPrec _i 10 (concatD [doc (showString "-") , prt 10 exp])
|
||||
EApp exp0 exp1 -> prPrec _i 11 (concatD [prt 11 exp0 , prt 12 exp1])
|
||||
EProj exp i -> prPrec _i 12 (concatD [prt 12 exp , doc (showString ".") , prt 0 i])
|
||||
ERecType fieldtypes -> prPrec _i 13 (concatD [doc (showString "sig") , doc (showString "{") , prt 0 fieldtypes , doc (showString "}")])
|
||||
ERec fieldvalues -> prPrec _i 13 (concatD [doc (showString "rec") , doc (showString "{") , prt 0 fieldvalues , doc (showString "}")])
|
||||
EEmptyList -> prPrec _i 13 (concatD [doc (showString "[") , doc (showString "]")])
|
||||
EList exps -> prPrec _i 13 (concatD [doc (showString "[") , prt 0 exps , doc (showString "]")])
|
||||
ETuple exp exps -> prPrec _i 13 (concatD [doc (showString "(") , prt 0 exp , doc (showString ",") , prt 0 exps , doc (showString ")")])
|
||||
EVar i -> prPrec _i 13 (concatD [prt 0 i])
|
||||
EType -> prPrec _i 13 (concatD [doc (showString "Type")])
|
||||
EStr str -> prPrec _i 13 (concatD [prt 0 str])
|
||||
EInteger n -> prPrec _i 13 (concatD [prt 0 n])
|
||||
EDouble d -> prPrec _i 13 (concatD [prt 0 d])
|
||||
EMeta -> prPrec _i 13 (concatD [doc (showString "?")])
|
||||
VVar i -> prPrec _i 0 (concatD [prt 0 i])
|
||||
VWild -> prPrec _i 0 (concatD [doc (showString "_")])
|
||||
LetDef i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString "=") , prt 0 exp])
|
||||
Case pattern guard exp -> prPrec _i 0 (concatD [prt 0 pattern , prt 0 guard , doc (showString "->") , prt 0 exp])
|
||||
BindVar varorwild exp -> prPrec _i 0 (concatD [prt 0 varorwild , doc (showString "<-") , prt 0 exp])
|
||||
BindNoVar exp -> prPrec _i 0 (concatD [prt 0 exp])
|
||||
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:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [Decl] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
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 [CommaPattern] where
|
||||
prt _ es = case es of
|
||||
[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 3 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 [Bind] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [FieldType] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [FieldValue] where
|
||||
prt _ es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
instance Print [Exp] where
|
||||
prt _ es = case es of
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
@@ -1,29 +0,0 @@
|
||||
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 (t@(PT (Pn _ l' c') _):ts) =
|
||||
replicate (l'-l) '\n'
|
||||
++ replicate (if l' == l then c'-c else c'-1) ' '
|
||||
++ s ++ prTokens_ l' (c'+length s) ts
|
||||
where s = prToken t
|
||||
-- prTokens_ l c (Err p:ts) =
|
||||
|
||||
layout :: String -> String
|
||||
layout s = prTokens ts'
|
||||
-- ++ "\n" ++ show ts'
|
||||
where ts = tokens s
|
||||
ts' = resolveLayout True ts
|
||||
|
||||
main :: IO ()
|
||||
main = do args <- getArgs
|
||||
case args of
|
||||
[] -> getContents >>= putStrLn . layout
|
||||
fs -> mapM_ (\f -> readFile f >>= putStrLn . layout) fs
|
||||
@@ -1,200 +0,0 @@
|
||||
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 guard exp -> failure t
|
||||
DeriveDecl i0 i1 -> failure t
|
||||
ConsDecl i exp -> failure t
|
||||
GuardExp exp -> failure t
|
||||
GuardNo -> failure t
|
||||
POr pattern0 pattern1 -> failure t
|
||||
PListCons pattern0 pattern1 -> failure t
|
||||
PConsTop i pattern patterns -> failure t
|
||||
PCons i patterns -> failure t
|
||||
PRec fieldpatterns -> failure t
|
||||
PEmptyList -> failure t
|
||||
PList commapatterns -> failure t
|
||||
PTuple commapattern commapatterns -> failure t
|
||||
PStr str -> failure t
|
||||
PInt n -> failure t
|
||||
PVar i -> failure t
|
||||
PWild -> failure t
|
||||
CommaPattern pattern -> failure t
|
||||
FieldPattern i pattern -> failure t
|
||||
EPi varorwild exp0 exp1 -> failure t
|
||||
EPiNoVar exp0 exp1 -> failure t
|
||||
EAbs varorwild exp -> failure t
|
||||
ELet letdefs exp -> failure t
|
||||
ECase exp cases -> failure t
|
||||
EIf exp0 exp1 exp2 -> failure t
|
||||
EDo binds exp -> failure t
|
||||
EBind exp0 exp1 -> failure t
|
||||
EBindC 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
|
||||
EListCons 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
|
||||
ENeg exp -> failure t
|
||||
EApp exp0 exp1 -> failure t
|
||||
EProj exp i -> failure t
|
||||
ERecType fieldtypes -> failure t
|
||||
ERec fieldvalues -> failure t
|
||||
EEmptyList -> failure t
|
||||
EList exps -> failure t
|
||||
ETuple exp exps -> failure t
|
||||
EVar i -> failure t
|
||||
EType -> failure t
|
||||
EStr str -> failure t
|
||||
EInteger n -> failure t
|
||||
EDouble d -> failure t
|
||||
EMeta -> failure t
|
||||
VVar i -> failure t
|
||||
VWild -> failure t
|
||||
LetDef i exp -> failure t
|
||||
Case pattern guard exp -> failure t
|
||||
BindVar varorwild exp -> failure t
|
||||
BindNoVar exp -> 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 guard exp -> failure t
|
||||
DeriveDecl i0 i1 -> failure t
|
||||
|
||||
transConsDecl :: ConsDecl -> Result
|
||||
transConsDecl t = case t of
|
||||
ConsDecl i exp -> failure t
|
||||
|
||||
transGuard :: Guard -> Result
|
||||
transGuard t = case t of
|
||||
GuardExp exp -> failure t
|
||||
GuardNo -> failure t
|
||||
|
||||
transPattern :: Pattern -> Result
|
||||
transPattern t = case t of
|
||||
POr pattern0 pattern1 -> failure t
|
||||
PListCons pattern0 pattern1 -> failure t
|
||||
PConsTop i pattern patterns -> failure t
|
||||
PCons i patterns -> failure t
|
||||
PRec fieldpatterns -> failure t
|
||||
PEmptyList -> failure t
|
||||
PList commapatterns -> failure t
|
||||
PTuple commapattern commapatterns -> failure t
|
||||
PStr str -> failure t
|
||||
PInt n -> failure t
|
||||
PVar i -> failure t
|
||||
PWild -> failure t
|
||||
|
||||
transCommaPattern :: CommaPattern -> Result
|
||||
transCommaPattern t = case t of
|
||||
CommaPattern pattern -> failure t
|
||||
|
||||
transFieldPattern :: FieldPattern -> Result
|
||||
transFieldPattern t = case t of
|
||||
FieldPattern i pattern -> failure t
|
||||
|
||||
transExp :: Exp -> Result
|
||||
transExp t = case t of
|
||||
EPi varorwild exp0 exp1 -> failure t
|
||||
EPiNoVar exp0 exp1 -> failure t
|
||||
EAbs varorwild exp -> failure t
|
||||
ELet letdefs exp -> failure t
|
||||
ECase exp cases -> failure t
|
||||
EIf exp0 exp1 exp2 -> failure t
|
||||
EDo binds exp -> failure t
|
||||
EBind exp0 exp1 -> failure t
|
||||
EBindC 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
|
||||
EListCons 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
|
||||
ENeg exp -> failure t
|
||||
EApp exp0 exp1 -> failure t
|
||||
EProj exp i -> failure t
|
||||
ERecType fieldtypes -> failure t
|
||||
ERec fieldvalues -> failure t
|
||||
EEmptyList -> failure t
|
||||
EList exps -> failure t
|
||||
ETuple exp exps -> failure t
|
||||
EVar i -> failure t
|
||||
EType -> failure t
|
||||
EStr str -> failure t
|
||||
EInteger n -> failure t
|
||||
EDouble d -> failure t
|
||||
EMeta -> failure t
|
||||
|
||||
transVarOrWild :: VarOrWild -> Result
|
||||
transVarOrWild t = case t of
|
||||
VVar i -> failure t
|
||||
VWild -> failure t
|
||||
|
||||
transLetDef :: LetDef -> Result
|
||||
transLetDef t = case t of
|
||||
LetDef i exp -> failure t
|
||||
|
||||
transCase :: Case -> Result
|
||||
transCase t = case t of
|
||||
Case pattern guard exp -> failure t
|
||||
|
||||
transBind :: Bind -> Result
|
||||
transBind t = case t of
|
||||
BindVar varorwild exp -> failure t
|
||||
BindNoVar exp -> 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
|
||||
|
||||
@@ -1,147 +0,0 @@
|
||||
entrypoints Module, Exp ;
|
||||
|
||||
layout "let", "where", "of","rec", "sig", "do" ;
|
||||
layout stop "in" ;
|
||||
layout toplevel ;
|
||||
|
||||
comment "--" ;
|
||||
comment "{-" "-}" ;
|
||||
|
||||
Module. Module ::= [Import] [Decl] ;
|
||||
|
||||
Import. Import ::= "import" Ident ;
|
||||
-- FIXME: this is terminator to ensure that the pretty printer
|
||||
-- produces a semicolon after the last import. This could cause
|
||||
-- problems in a program which only does imports and uses layout syntax.
|
||||
terminator Import ";" ;
|
||||
|
||||
DataDecl. Decl ::= "data" Ident ":" Exp "where" "{" [ConsDecl] "}" ;
|
||||
TypeDecl. Decl ::= Ident ":" Exp ;
|
||||
ValueDecl. Decl ::= Ident [Pattern] Guard "=" Exp ;
|
||||
DeriveDecl. Decl ::= "derive" Ident Ident ;
|
||||
terminator Decl ";" ;
|
||||
|
||||
ConsDecl. ConsDecl ::= Ident ":" Exp ;
|
||||
separator ConsDecl ";" ;
|
||||
|
||||
GuardExp. Guard ::= "|" Exp1 ;
|
||||
GuardNo. Guard ::= ;
|
||||
|
||||
-- Disjunctive patterns.
|
||||
POr. Pattern ::= Pattern1 "||" Pattern ;
|
||||
|
||||
-- List constructor patterns
|
||||
PListCons. Pattern1 ::= Pattern2 "::" Pattern1 ;
|
||||
|
||||
-- Hack: constructor applied to at least one pattern
|
||||
-- this is to separate it from variable patterns
|
||||
PConsTop. Pattern2 ::= Ident Pattern3 [Pattern] ;
|
||||
|
||||
-- Real constructor pattern
|
||||
internal PCons. Pattern3 ::= "(" Ident [Pattern] ")" ;
|
||||
|
||||
-- Record patterns
|
||||
PRec. Pattern3 ::= "rec" "{" [FieldPattern] "}";
|
||||
|
||||
-- List patterns
|
||||
PEmptyList. Pattern3 ::= "[" "]" ;
|
||||
PList. Pattern3 ::= "[" [CommaPattern] "]" ;
|
||||
|
||||
-- Tuple patterns
|
||||
PTuple. Pattern3 ::= "(" CommaPattern "," [CommaPattern] ")" ;
|
||||
|
||||
-- hack to allow a different [Pattern] from the one defined
|
||||
-- for constructor patterns
|
||||
CommaPattern. CommaPattern ::= Pattern ;
|
||||
separator nonempty CommaPattern "," ;
|
||||
|
||||
-- String literal patterns
|
||||
PStr. Pattern3 ::= String ;
|
||||
-- Integer literal patterns
|
||||
PInt. Pattern3 ::= Integer ;
|
||||
-- Variable patterns
|
||||
PVar. Pattern3 ::= Ident ;
|
||||
-- Wild card patterns
|
||||
PWild. Pattern3 ::= "_" ;
|
||||
|
||||
coercions Pattern 3 ;
|
||||
|
||||
[]. [Pattern] ::= ;
|
||||
(:). [Pattern] ::= Pattern3 [Pattern] ;
|
||||
|
||||
FieldPattern. FieldPattern ::= Ident "=" Pattern ;
|
||||
separator FieldPattern ";" ;
|
||||
|
||||
-- Function types have precedence < 1 to keep the
|
||||
-- "->" from conflicting with the "->" after guards
|
||||
EPi. Exp ::= "(" VarOrWild ":" Exp ")" "->" Exp ;
|
||||
EPiNoVar. Exp ::= Exp1 "->" Exp ;
|
||||
VVar. VarOrWild ::= Ident ;
|
||||
VWild. VarOrWild ::= "_" ;
|
||||
|
||||
EAbs. Exp1 ::= "\\" VarOrWild "->" Exp1 ;
|
||||
ELet. Exp1 ::= "let" "{" [LetDef] "}" "in" Exp1 ;
|
||||
LetDef. LetDef ::= Ident "=" Exp ;
|
||||
separator LetDef ";" ;
|
||||
ECase. Exp1 ::= "case" Exp "of" "{" [Case] "}" ;
|
||||
Case. Case ::= Pattern Guard "->" Exp ;
|
||||
separator Case ";" ;
|
||||
EIf. Exp1 ::= "if" Exp "then" Exp "else" Exp1 ;
|
||||
EDo. Exp1 ::= "do" "{" [Bind] Exp "}" ;
|
||||
BindVar. Bind ::= VarOrWild "<-" Exp ;
|
||||
BindNoVar. Bind ::= Exp ;
|
||||
terminator Bind ";" ;
|
||||
|
||||
EBind. Exp3 ::= Exp3 ">>=" Exp4 ;
|
||||
EBindC. Exp3 ::= Exp3 ">>" Exp4 ;
|
||||
|
||||
EOr. Exp4 ::= Exp5 "||" Exp4 ;
|
||||
|
||||
EAnd. Exp5 ::= Exp6 "&&" Exp5 ;
|
||||
|
||||
EEq. Exp6 ::= Exp7 "==" Exp7 ;
|
||||
ENe. Exp6 ::= Exp7 "/=" Exp7 ;
|
||||
ELt. Exp6 ::= Exp7 "<" Exp7 ;
|
||||
ELe. Exp6 ::= Exp7 "<=" Exp7 ;
|
||||
EGt. Exp6 ::= Exp7 ">" Exp7 ;
|
||||
EGe. Exp6 ::= Exp7 ">=" Exp7 ;
|
||||
|
||||
EListCons. Exp7 ::= Exp8 "::" Exp7 ;
|
||||
|
||||
EAdd. Exp8 ::= Exp8 "+" Exp9 ;
|
||||
ESub. Exp8 ::= Exp8 "-" Exp9 ;
|
||||
|
||||
EMul. Exp9 ::= Exp9 "*" Exp10 ;
|
||||
EDiv. Exp9 ::= Exp9 "/" Exp10 ;
|
||||
EMod. Exp9 ::= Exp9 "%" Exp10 ;
|
||||
|
||||
ENeg. Exp10 ::= "-" Exp10 ;
|
||||
|
||||
EApp. Exp11 ::= Exp11 Exp12 ;
|
||||
|
||||
EProj. Exp12 ::= Exp12 "." Ident ;
|
||||
|
||||
ERecType. Exp13 ::= "sig" "{" [FieldType] "}" ;
|
||||
FieldType. FieldType ::= Ident ":" Exp ;
|
||||
separator FieldType ";" ;
|
||||
|
||||
ERec. Exp13 ::= "rec" "{" [FieldValue] "}" ;
|
||||
FieldValue.FieldValue ::= Ident "=" Exp ;
|
||||
separator FieldValue ";" ;
|
||||
|
||||
EEmptyList.Exp13 ::= "[" "]" ;
|
||||
EList. Exp13 ::= "[" [Exp] "]" ;
|
||||
|
||||
-- n-tuple, where n>=2
|
||||
ETuple. Exp13 ::= "(" Exp "," [Exp] ")" ;
|
||||
|
||||
EVar. Exp13 ::= Ident ;
|
||||
EType. Exp13 ::= "Type" ;
|
||||
EStr. Exp13 ::= String ;
|
||||
EInteger. Exp13 ::= Integer ;
|
||||
EDouble. Exp13 ::= Double ;
|
||||
EMeta. Exp13 ::= "?" ;
|
||||
|
||||
coercions Exp 13 ;
|
||||
|
||||
separator nonempty Exp "," ;
|
||||
@@ -1,58 +0,0 @@
|
||||
-- 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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -1,766 +0,0 @@
|
||||
-- | 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
|
||||
|
||||
data CState = CState {
|
||||
nextVar :: Integer,
|
||||
nextMeta :: Integer
|
||||
}
|
||||
|
||||
|
||||
|
||||
declsToCore :: [Decl] -> [Decl]
|
||||
declsToCore m = evalState (declsToCore_ m) newState
|
||||
|
||||
declsToCore_ :: [Decl] -> C [Decl]
|
||||
declsToCore_ = deriveDecls
|
||||
>>> desugar
|
||||
>>> compilePattDecls
|
||||
>>> numberMetas
|
||||
>>> replaceCons
|
||||
>>> expandOrPatts
|
||||
>>> optimize
|
||||
|
||||
optimize :: [Decl] -> C [Decl]
|
||||
optimize = uniqueVars
|
||||
>>> removeUselessMatch
|
||||
>>> betaReduce
|
||||
|
||||
newState :: CState
|
||||
newState = CState {
|
||||
nextVar = 0,
|
||||
nextMeta = 0
|
||||
}
|
||||
|
||||
|
||||
--
|
||||
-- * Make all variable names unique
|
||||
--
|
||||
|
||||
uniqueVars :: [Decl] -> C [Decl]
|
||||
uniqueVars = mapM (f Map.empty)
|
||||
where
|
||||
f :: Map Ident Ident -> Tree a -> C (Tree a)
|
||||
f ss t = case t of
|
||||
ELet ds _ ->
|
||||
do
|
||||
let vs = Set.toList (letDefBinds ds)
|
||||
vs' <- freshIdents (length vs)
|
||||
let ss' = addToSubstEnv (zip vs vs') ss
|
||||
composOpM (f ss') t
|
||||
LetDef i e ->
|
||||
case Map.lookup i ss of
|
||||
Nothing -> fail $ "let var " ++ printTree i ++ " not renamed"
|
||||
Just i' -> liftM (LetDef i') (f ss e)
|
||||
Case p _ _ ->
|
||||
do
|
||||
let vs = Set.toList (binds p)
|
||||
vs' <- freshIdents (length vs)
|
||||
let ss' = addToSubstEnv (zip vs vs') ss
|
||||
composOpM (f ss') t
|
||||
EAbs (VVar i) e ->
|
||||
do
|
||||
i' <- freshIdent
|
||||
let ss' = addToSubstEnv [(i,i')] ss
|
||||
liftM (EAbs (VVar i')) (f ss' e)
|
||||
EPi (VVar i) e1 e2 ->
|
||||
do
|
||||
i' <- freshIdent
|
||||
let ss' = addToSubstEnv [(i,i')] ss
|
||||
liftM2 (EPi (VVar i')) (f ss e1) (f ss' e2)
|
||||
EVar i -> return $ case Map.lookup i ss of
|
||||
Nothing -> t -- constructor
|
||||
Just i' -> EVar i'
|
||||
PVar i -> return $ case Map.lookup i ss of
|
||||
Nothing -> t -- constructor
|
||||
Just i' -> PVar i'
|
||||
_ -> composOpM (f ss) t
|
||||
where addToSubstEnv bs m = foldr (\ (k,v) -> Map.insert k v) m bs
|
||||
|
||||
--
|
||||
-- * Number meta variables
|
||||
--
|
||||
|
||||
numberMetas :: [Decl] -> C [Decl]
|
||||
numberMetas = mapM f
|
||||
where
|
||||
f :: Tree a -> C (Tree a)
|
||||
f t = case t of
|
||||
EMeta -> do
|
||||
st <- get
|
||||
put (st { nextMeta = nextMeta st + 1})
|
||||
return $ EVar $ Ident $ "?" ++ show (nextMeta st) -- FIXME: hack
|
||||
_ -> composOpM f t
|
||||
|
||||
|
||||
--
|
||||
-- * 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)
|
||||
|
||||
-- | Checks if a declaration is a value declaration
|
||||
-- of the given identifier.
|
||||
isValueDecl :: Ident -> Decl -> Bool
|
||||
isValueDecl x (ValueDecl y _ _ _) = x == y
|
||||
isValueDecl _ _ = False
|
||||
|
||||
-- | Take a non-empty list of pattern equations with guards
|
||||
-- for the same function, and produce a single declaration.
|
||||
mergeDecls :: [Decl] -> C Decl
|
||||
mergeDecls ds@(ValueDecl x p _ _:_)
|
||||
= do let cs = [ (ps,g,rhs) | ValueDecl _ ps g rhs <- ds ]
|
||||
(pss,_,_) = unzip3 cs
|
||||
n = length p
|
||||
when (not (all ((== n) . length) pss))
|
||||
$ fail $ "Pattern count mismatch for " ++ printTree x
|
||||
vs <- freshIdents n
|
||||
let cases = map (\ (ps,g,rhs) -> Case (mkPTuple ps) g rhs) cs
|
||||
c = ECase (mkETuple (map EVar vs)) cases
|
||||
f = foldr (EAbs . VVar) c vs
|
||||
return $ ValueDecl x [] GuardNo f
|
||||
|
||||
--
|
||||
-- * 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 = [
|
||||
("Compos", deriveCompos),
|
||||
("Show", deriveShow),
|
||||
("Eq", deriveEq),
|
||||
("Ord", deriveOrd)
|
||||
]
|
||||
|
||||
--
|
||||
-- * Deriving instances of Compos
|
||||
--
|
||||
|
||||
deriveCompos :: Derivator
|
||||
deriveCompos t@(Ident ts) k cs =
|
||||
do
|
||||
co <- deriveComposOp t k cs
|
||||
cf <- deriveComposFold t k cs
|
||||
let [c] = argumentTypes k -- FIXME: what if there is not exactly one argument to t?
|
||||
d = Ident ("compos_"++ts)
|
||||
dt = apply (var "Compos") [c, EVar t]
|
||||
r = ERec [FieldValue (Ident "composOp") co,
|
||||
FieldValue (Ident "composFold") cf]
|
||||
return [TypeDecl d dt, ValueDecl d [] GuardNo r]
|
||||
|
||||
deriveComposOp :: Ident -> Exp -> [(Ident,Exp)] -> C Exp
|
||||
deriveComposOp t k cs =
|
||||
do
|
||||
f <- freshIdent
|
||||
x <- freshIdent
|
||||
let e = EVar
|
||||
pv = VVar
|
||||
infixr 3 \->
|
||||
(\->) = EAbs
|
||||
mkCase ci ct =
|
||||
do
|
||||
vars <- freshIdents (arity ct)
|
||||
-- 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') c | t' == t -> apply (e f) [c, e v]
|
||||
_ -> e v
|
||||
calls = zipWith rec vars (argumentTypes ct)
|
||||
return $ Case (PCons ci (map PVar vars)) gtrue (apply (e ci) calls)
|
||||
cases <- mapM (uncurry mkCase) cs
|
||||
let cases' = cases ++ [Case PWild gtrue (e x)]
|
||||
fb <- abstract (arity k) $ const $ pv f \-> pv x \-> ECase (e x) cases'
|
||||
return fb
|
||||
|
||||
deriveComposFold :: Ident -> Exp -> [(Ident,Exp)] -> C Exp
|
||||
deriveComposFold t k cs =
|
||||
do
|
||||
f <- freshIdent
|
||||
x <- freshIdent
|
||||
b <- freshIdent
|
||||
r <- freshIdent
|
||||
let e = EVar
|
||||
pv = VVar
|
||||
infixr 3 \->
|
||||
(\->) = EAbs
|
||||
mkCase ci ct =
|
||||
do
|
||||
vars <- freshIdents (arity ct)
|
||||
-- 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') c | t' == t -> apply (e f) [c, e v]
|
||||
_ -> e v
|
||||
calls = zipWith rec vars (argumentTypes ct)
|
||||
z = EProj (e r) (Ident "mzero")
|
||||
p = EProj (e r) (Ident "mplus")
|
||||
joinCalls [] = z
|
||||
joinCalls cs = foldr1 (\x y -> apply p [x,y]) cs
|
||||
return $ Case (PCons ci (map PVar vars)) gtrue (joinCalls calls)
|
||||
cases <- mapM (uncurry mkCase) cs
|
||||
let cases' = cases ++ [Case PWild gtrue (e x)]
|
||||
fb <- abstract (arity k) $ const $ pv f \-> pv x \-> ECase (e x) cases'
|
||||
return $ VWild \-> pv r \-> fb
|
||||
|
||||
--
|
||||
-- * Deriving instances of Show
|
||||
--
|
||||
|
||||
deriveShow :: Derivator
|
||||
deriveShow t k cs = fail $ "derive Show not implemented"
|
||||
|
||||
--
|
||||
-- * Deriving instances of Eq
|
||||
--
|
||||
|
||||
-- FIXME: how do we require Eq instances for all
|
||||
-- constructor arguments?
|
||||
|
||||
deriveEq :: Derivator
|
||||
deriveEq t@(Ident tn) k cs =
|
||||
do
|
||||
dt <- abstractType ats (EApp (var "Eq") . apply (EVar t))
|
||||
f <- mkEq
|
||||
r <- abstract (arity k) (\_ -> ERec [FieldValue (Ident "eq") f])
|
||||
return [TypeDecl d dt, ValueDecl d [] GuardNo r]
|
||||
where
|
||||
ats = argumentTypes k
|
||||
d = Ident ("eq_"++tn)
|
||||
mkEq = do
|
||||
x <- freshIdent
|
||||
y <- freshIdent
|
||||
cases <- mapM (uncurry mkEqCase) cs
|
||||
let fc = Case PWild gtrue false
|
||||
abstract 2 (\es -> ECase (mkETuple es) (cases++[fc]))
|
||||
mkEqCase c ct =
|
||||
do
|
||||
let n = arity ct
|
||||
ts = argumentTypes ct
|
||||
vs1 <- freshIdents n
|
||||
vs2 <- freshIdents n
|
||||
let pr = mkPTuple [PCons c (map PVar vs1), PCons c (map PVar vs2)]
|
||||
eqs = concat $ zipWith3 child_eq ts vs1 vs2
|
||||
rhs [] = true
|
||||
rhs xs = foldr1 EAnd xs
|
||||
return $ Case pr gtrue (rhs eqs)
|
||||
-- FIXME: hack: this returns a list to skip testing type arguments.
|
||||
child_eq EType _ _ = []
|
||||
child_eq t x y = [apply (var "eq") [t,eq_dict t, EVar x, EVar y]]
|
||||
-- FIXME: this is a hack to at least support Tree types
|
||||
eq_dict (EApp (EVar t') _)
|
||||
| t' == t = apply (EVar d) (replicate (arity k) EMeta)
|
||||
eq_dict (EVar (Ident x))
|
||||
| x `elem` ["String","Integer","Double"] = var ("eq_"++x)
|
||||
eq_dict _ = EMeta
|
||||
|
||||
--
|
||||
-- * Deriving instances of Ord
|
||||
--
|
||||
|
||||
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 cs) ds
|
||||
where
|
||||
cs = consArities ds
|
||||
f :: DataConsInfo -> Tree a -> C (Tree a)
|
||||
f cs x = case x of
|
||||
-- get rid of the PConsTop hack
|
||||
PConsTop id p1 ps -> f cs (PCons id (p1:ps))
|
||||
-- replace patterns C where C is a constructor with (C)
|
||||
PVar id | isCons id -> return $ PCons id []
|
||||
-- don't eta-expand overshadowed constructors
|
||||
EAbs (VVar id) e | isCons id ->
|
||||
liftM (EAbs (VVar id)) (f (Map.delete id cs) e)
|
||||
EPi (VVar id) t e | isCons id ->
|
||||
liftM2 (EPi (VVar id)) (f cs t) (f (Map.delete id cs) e)
|
||||
-- eta-expand constructors. betaReduce will remove any beta
|
||||
-- redexes produced here.
|
||||
EVar id | isCons id -> do
|
||||
let Just n = Map.lookup id cs
|
||||
abstract n (apply x)
|
||||
_ -> composOpM (f cs) x
|
||||
where isCons = (`Map.member` cs)
|
||||
|
||||
--
|
||||
-- * Do simple beta reductions.
|
||||
--
|
||||
|
||||
betaReduce :: [Decl] -> C [Decl]
|
||||
betaReduce = return . map f
|
||||
where
|
||||
f :: Tree a -> Tree a
|
||||
f t = case t of
|
||||
EApp e1 e2 ->
|
||||
case (f e1, f e2) of
|
||||
(EAbs (VVar x) b, e) | countFreeOccur x b == 1 -> f (subst x e b)
|
||||
(e1',e2') -> EApp e1' e2'
|
||||
_ -> composOp f t
|
||||
|
||||
--
|
||||
-- * Remove useless pattern matching and variable binding.
|
||||
--
|
||||
|
||||
removeUselessMatch :: [Decl] -> C [Decl]
|
||||
removeUselessMatch = return . map f
|
||||
where
|
||||
f :: Tree a -> Tree a
|
||||
f x = case x of
|
||||
EAbs (VVar x) b ->
|
||||
case f b of
|
||||
-- replace \x -> case x of { y | True -> e } with \y -> e,
|
||||
-- if x is not free in e
|
||||
ECase (EVar x') [Case (PVar y) g e]
|
||||
| x' == x && isTrueGuard g && not (x `isFreeIn` e)
|
||||
-> f (EAbs (VVar y) e)
|
||||
-- replace unused variable in lambda with wild card
|
||||
e | not (x `isFreeIn` e) -> f (EAbs VWild e)
|
||||
e -> EAbs (VVar x) e
|
||||
-- replace unused variable in pi with wild card
|
||||
EPi (VVar x) t e ->
|
||||
let e' = f e
|
||||
v = if not (x `isFreeIn` e') then VWild else VVar x
|
||||
in EPi v (f t) e'
|
||||
-- replace unused variables in case patterns with wild cards
|
||||
Case p (GuardExp g) e ->
|
||||
let g' = f g
|
||||
e' = f e
|
||||
used = freeVars g' `Set.union` freeVars e'
|
||||
p' = f (removeUnusedVarPatts used p)
|
||||
in Case p' (GuardExp g') e'
|
||||
-- for value declarations without patterns, compilePattDecls
|
||||
-- generates pattern matching on the empty record, remove these
|
||||
ECase (ERec []) [Case (PRec []) g e] | isTrueGuard g -> 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) (casePatterns cs)
|
||||
-> f (ECase e [ Case p g r | Case (PRec [FieldPattern _ p]) g r <- cs ])
|
||||
-- for all fields in record matching where all patterns for the field just
|
||||
-- bind variables, substitute in the field value (if it is a variable)
|
||||
-- in the guards and right hand sides.
|
||||
ECase (ERec fs) cs | all isPRec (casePatterns cs) ->
|
||||
let h (FieldValue f v@(EVar _):fs) xs
|
||||
| all (onlyBindsFieldToVariable f) (casePatterns xs)
|
||||
= h fs (map (inlineField f v) xs)
|
||||
h (f:fs) xs = let (fs',xs') = h fs xs in (f:fs',xs')
|
||||
h [] xs = ([],xs)
|
||||
inlineField f v (Case (PRec fps) (GuardExp g) e) =
|
||||
let p' = PRec [fp | fp@(FieldPattern f' _) <- fps, f' /= f]
|
||||
ss = zip (fieldPatternVars f fps) (repeat v)
|
||||
in Case p' (GuardExp (substs ss g)) (substs ss e)
|
||||
(fs',cs') = h fs cs
|
||||
x' = ECase (ERec fs') cs'
|
||||
in if length fs' < length fs then f x' else composOp f x'
|
||||
-- Remove wild card patterns in record patterns
|
||||
PRec fps -> PRec (map f (fps \\ wildcards))
|
||||
where wildcards = [fp | fp@(FieldPattern _ PWild) <- fps]
|
||||
_ -> composOp f x
|
||||
|
||||
isTrueGuard :: Guard -> Bool
|
||||
isTrueGuard (GuardExp (EVar (Ident "True"))) = True
|
||||
isTrueGuard GuardNo = True
|
||||
isTrueGuard _ = False
|
||||
|
||||
removeUnusedVarPatts :: Set Ident -> Tree a -> Tree a
|
||||
removeUnusedVarPatts keep x = case x of
|
||||
PVar id | not (id `Set.member` keep) -> PWild
|
||||
_ -> composOp (removeUnusedVarPatts keep) x
|
||||
|
||||
isSingleFieldPattern :: Ident -> Pattern -> Bool
|
||||
isSingleFieldPattern x p = case p of
|
||||
PRec [FieldPattern y _] -> x == y
|
||||
_ -> False
|
||||
|
||||
casePatterns :: [Case] -> [Pattern]
|
||||
casePatterns cs = [p | Case p _ _ <- cs]
|
||||
|
||||
isPRec :: Pattern -> Bool
|
||||
isPRec (PRec _) = True
|
||||
isPRec _ = False
|
||||
|
||||
-- | Checks if given pattern is a record pattern, and matches the field
|
||||
-- with just a variable, with a wild card, or not at all.
|
||||
onlyBindsFieldToVariable :: Ident -> Pattern -> Bool
|
||||
onlyBindsFieldToVariable f (PRec fps) =
|
||||
all isVar [p | FieldPattern f' p <- fps, f == f']
|
||||
where isVar (PVar _) = True
|
||||
isVar PWild = True
|
||||
isVar _ = False
|
||||
onlyBindsFieldToVariable _ _ = False
|
||||
|
||||
fieldPatternVars :: Ident -> [FieldPattern] -> [Ident]
|
||||
fieldPatternVars f fps = [p | FieldPattern f' (PVar p) <- fps, f == f']
|
||||
|
||||
--
|
||||
-- * Expand disjunctive patterns.
|
||||
--
|
||||
|
||||
expandOrPatts :: [Decl] -> C [Decl]
|
||||
expandOrPatts = return . map f
|
||||
where
|
||||
f :: Tree a -> Tree a
|
||||
f x = case x of
|
||||
ECase e cs -> ECase (f e) (concatMap (expandCase . f) cs)
|
||||
_ -> composOp f x
|
||||
|
||||
expandCase :: Case -> [Case]
|
||||
expandCase (Case p g e) = [ Case p' g e | p' <- expandPatt p ]
|
||||
|
||||
expandPatt :: Pattern -> [Pattern]
|
||||
expandPatt p = case p of
|
||||
POr p1 p2 -> expandPatt p1 ++ expandPatt p2
|
||||
PCons i ps -> map (PCons i) $ expandPatts ps
|
||||
PRec fps -> let (fs,ps) = unzip $ fromPRec fps
|
||||
fpss = map (zip fs) (expandPatts ps)
|
||||
in map (PRec . toPRec) fpss
|
||||
_ -> [p]
|
||||
|
||||
expandPatts :: [Pattern] -> [[Pattern]]
|
||||
expandPatts [] = [[]]
|
||||
expandPatts (p:ps) = [ p':ps' | p' <- expandPatt p, ps' <- expandPatts ps]
|
||||
|
||||
--
|
||||
-- * Remove simple syntactic sugar.
|
||||
--
|
||||
|
||||
desugar :: [Decl] -> C [Decl]
|
||||
desugar = return . map f
|
||||
where
|
||||
f :: Tree a -> Tree a
|
||||
f x = case x of
|
||||
PListCons p1 p2 -> pListCons <| p1 <| p2
|
||||
PEmptyList -> pList []
|
||||
PList xs -> pList [f p | CommaPattern p <- xs]
|
||||
PTuple x xs -> mkPTuple [f p | CommaPattern p <- (x:xs)]
|
||||
GuardNo -> gtrue
|
||||
EIf exp0 exp1 exp2 -> ifBool <| exp0 <| exp1 <| exp2
|
||||
EDo bs e -> mkDo (map f bs) (f e)
|
||||
BindNoVar exp0 -> BindVar VWild <| exp0
|
||||
EPiNoVar exp0 exp1 -> EPi VWild <| exp0 <| exp1
|
||||
EBind exp0 exp1 -> appBind <| exp0 <| exp1
|
||||
EBindC exp0 exp1 -> appBindC <| exp0 <| exp1
|
||||
EOr exp0 exp1 -> orBool <| exp0 <| exp1
|
||||
EAnd exp0 exp1 -> andBool <| exp0 <| exp1
|
||||
EEq exp0 exp1 -> overlBin "eq" <| exp0 <| exp1
|
||||
ENe exp0 exp1 -> overlBin "ne" <| exp0 <| exp1
|
||||
ELt exp0 exp1 -> overlBin "lt" <| exp0 <| exp1
|
||||
ELe exp0 exp1 -> overlBin "le" <| exp0 <| exp1
|
||||
EGt exp0 exp1 -> overlBin "gt" <| exp0 <| exp1
|
||||
EGe exp0 exp1 -> overlBin "ge" <| exp0 <| exp1
|
||||
EListCons exp0 exp1 -> appCons <| exp0 <| exp1
|
||||
EAdd exp0 exp1 -> overlBin "plus" <| exp0 <| exp1
|
||||
ESub exp0 exp1 -> overlBin "minus" <| exp0 <| exp1
|
||||
EMul exp0 exp1 -> overlBin "times" <| exp0 <| exp1
|
||||
EDiv exp0 exp1 -> overlBin "div" <| exp0 <| exp1
|
||||
EMod exp0 exp1 -> overlBin "mod" <| exp0 <| exp1
|
||||
ENeg exp0 -> overlUn "neg" <| exp0
|
||||
EEmptyList -> mkList []
|
||||
EList exps -> mkList (map f exps)
|
||||
ETuple exp1 exps -> mkETuple (map f (exp1:exps))
|
||||
_ -> composOp f x
|
||||
where g <| x = g (f x)
|
||||
|
||||
--
|
||||
-- * List patterns
|
||||
--
|
||||
|
||||
pListCons :: Pattern -> Pattern -> Pattern
|
||||
pListCons p1 p2 = PCons (Ident "Cons") [PWild,p1,p2]
|
||||
|
||||
pList :: [Pattern] -> Pattern
|
||||
pList = foldr pListCons (PCons (Ident "Nil") [PWild])
|
||||
|
||||
--
|
||||
-- * Use an overloaded function.
|
||||
--
|
||||
|
||||
overlUn :: String -> Exp -> Exp
|
||||
overlUn f e1 = apply (EVar (Ident f)) [EMeta,EVar (Ident "num_Integer"),e1] -- FIXME: hack, should be ?
|
||||
|
||||
overlBin :: String -> Exp -> Exp -> Exp
|
||||
overlBin f e1 e2 = apply (EVar (Ident f)) [EMeta,EVar (Ident "num_Integer"),e1,e2] -- FIXME: hack, should be ?
|
||||
|
||||
--
|
||||
-- * Monad
|
||||
--
|
||||
|
||||
mkDo :: [Bind] -> Exp -> Exp
|
||||
mkDo bs e = foldr (\ (BindVar v r) x -> appBind r (EAbs v x)) e bs
|
||||
|
||||
appBind :: Exp -> Exp -> Exp
|
||||
appBind e1 e2 = apply (EVar (Ident "bind")) [EMeta,EMeta,EMeta,EMeta,e1,e2]
|
||||
|
||||
appBindC :: Exp -> Exp -> Exp
|
||||
appBindC e1 e2 = appBind e1 (EAbs VWild e2)
|
||||
|
||||
--
|
||||
-- * List
|
||||
--
|
||||
|
||||
mkList :: [Exp] -> Exp
|
||||
mkList = foldr appCons (EApp (EVar (Ident "Nil")) EMeta)
|
||||
|
||||
appCons :: Exp -> Exp -> Exp
|
||||
appCons e1 e2 = apply (EVar (Ident "Cons")) [EMeta,e1,e2]
|
||||
|
||||
|
||||
--
|
||||
-- * Booleans
|
||||
--
|
||||
|
||||
andBool :: Exp -> Exp -> Exp
|
||||
andBool e1 e2 = ifBool e1 e2 false
|
||||
|
||||
orBool :: Exp -> Exp -> Exp
|
||||
orBool e1 e2 = ifBool e1 true e2
|
||||
|
||||
ifBool :: Exp -> Exp -> Exp -> Exp
|
||||
ifBool c t e = ECase c [Case (PCons (Ident "True") []) gtrue t,
|
||||
Case (PCons (Ident "False") []) gtrue e]
|
||||
|
||||
|
||||
--
|
||||
-- * Substitution
|
||||
--
|
||||
|
||||
subst :: Ident -> Exp -> Exp -> Exp
|
||||
subst x e = substs [(x,e)]
|
||||
|
||||
|
||||
|
||||
-- | Simultaneuous substitution
|
||||
substs :: [(Ident, Exp)] -> Exp -> Exp
|
||||
substs ss = f (Map.fromList ss)
|
||||
where
|
||||
f :: Map Ident Exp -> Tree a -> Tree a
|
||||
f ss t | Map.null ss = t
|
||||
f ss t = case t of
|
||||
EVar i -> Map.findWithDefault t i ss
|
||||
_ -> composOp (f ss) t
|
||||
|
||||
|
||||
{-
|
||||
-- not needed now that variable names are unique
|
||||
-- FIXE: this function does not properly rename bound variables
|
||||
substs :: [(Ident, Exp)] -> Exp -> Exp
|
||||
substs ss = f (Map.fromList ss)
|
||||
where
|
||||
f :: Map Ident Exp -> Tree a -> Tree a
|
||||
f ss t | Map.null ss = t
|
||||
f ss t = case t of
|
||||
ELet ds e3 ->
|
||||
ELet [LetDef id (f ss' e2) | LetDef id e2 <- ds] (f ss' e3)
|
||||
where ss' = ss `mapMinusSet` letDefBinds ds
|
||||
Case p g e -> Case p (f ss' g) (f ss' e) where ss' = ss `mapMinusSet` binds p
|
||||
EAbs (VVar id) e -> EAbs (VVar id) (f ss' e) where ss' = Map.delete id ss
|
||||
EPi (VVar id) e1 e2 ->
|
||||
EPi (VVar id) (f ss e1) (f ss' e2) where ss' = Map.delete id ss
|
||||
EVar i -> Map.findWithDefault t i ss
|
||||
_ -> composOp (f ss) t
|
||||
-}
|
||||
|
||||
--
|
||||
-- * Abstract syntax utilities
|
||||
--
|
||||
|
||||
var :: String -> Exp
|
||||
var s = EVar (Ident s)
|
||||
|
||||
true :: Exp
|
||||
true = var "True"
|
||||
|
||||
false :: Exp
|
||||
false = var "False"
|
||||
|
||||
gtrue :: Guard
|
||||
gtrue = GuardExp true
|
||||
|
||||
|
||||
mkETuple :: [Exp] -> Exp
|
||||
mkETuple = ERec . zipWith (\i -> FieldValue (Ident ("p"++show i))) [1..]
|
||||
|
||||
mkPTuple :: [Pattern] -> Pattern
|
||||
mkPTuple = PRec . zipWith (\i -> FieldPattern (Ident ("p"++show i))) [1..]
|
||||
|
||||
-- | Apply an expression to a list of arguments.
|
||||
apply :: Exp -> [Exp] -> Exp
|
||||
apply = foldl EApp
|
||||
|
||||
-- | Abstract a value over some arguments.
|
||||
abstract :: Int -- ^ number of arguments
|
||||
-> ([Exp] -> Exp) -> C Exp
|
||||
abstract n f =
|
||||
do
|
||||
vs <- freshIdents n
|
||||
return $ foldr EAbs (f (map EVar vs)) (map VVar vs)
|
||||
|
||||
-- | Abstract a type over some arguments.
|
||||
abstractType :: [Exp] -- ^ argument types
|
||||
-> ([Exp] -> Exp) -- ^ function from variable expressions
|
||||
-- to the expression to return
|
||||
-> C Exp
|
||||
abstractType ts f =
|
||||
do
|
||||
vs <- freshIdents (length ts)
|
||||
let pi (v,t) e = EPi (VVar v) t e
|
||||
return $ foldr pi (f (map EVar vs)) (zip vs ts)
|
||||
|
||||
-- | Get an identifier which cannot occur in user-written
|
||||
-- code, and which has not been generated before.
|
||||
freshIdent :: C Ident
|
||||
freshIdent = do
|
||||
st <- get
|
||||
put (st { nextVar = nextVar st + 1 })
|
||||
return (Ident ("x_"++show (nextVar st)))
|
||||
|
||||
freshIdents :: Int -> C [Ident]
|
||||
freshIdents n = replicateM n freshIdent
|
||||
|
||||
-- | Get the variables bound by a set of let definitions.
|
||||
letDefBinds :: [LetDef] -> Set Ident
|
||||
letDefBinds defs = Set.fromList [ id | LetDef id _ <- defs]
|
||||
|
||||
letDefRhss :: [LetDef] -> [Exp]
|
||||
letDefRhss defs = [ exp | LetDef _ exp <- 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 exp ->
|
||||
Set.unions (f exp:map f (letDefRhss defs)) Set.\\ letDefBinds defs
|
||||
ECase exp cases -> f exp `Set.union`
|
||||
Set.unions [(f g `Set.union` f e) Set.\\ binds p
|
||||
| Case p g 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 -> 0
|
||||
Case p _ _ | 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
|
||||
|
||||
|
||||
fromPRec :: [FieldPattern] -> [(Ident,Pattern)]
|
||||
fromPRec fps = [ (l,p) | FieldPattern l p <- fps ]
|
||||
|
||||
toPRec :: [(Ident,Pattern)] -> [FieldPattern]
|
||||
toPRec = map (uncurry FieldPattern)
|
||||
|
||||
--
|
||||
-- * 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 =
|
||||
case Map.lookup i ts of
|
||||
Just t -> t
|
||||
Nothing -> error $ "Data type " ++ printTree i ++ " not found."
|
||||
++ " Known types: " ++ show (Map.keysSet ts)
|
||||
|
||||
--
|
||||
-- * Utilities
|
||||
--
|
||||
|
||||
infixl 1 >>>
|
||||
|
||||
(>>>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c
|
||||
f >>> g = (g =<<) . f
|
||||
|
||||
mapMinusSet :: Ord k => Map k a -> Set k -> Map k a
|
||||
mapMinusSet m s = m Map.\\ (Map.fromList [(x,()) | x <- Set.toList s])
|
||||
Reference in New Issue
Block a user