forked from GitHub/gf-core
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