diff --git a/CSPM-Frontend.cabal b/CSPM-Frontend.cabal new file mode 100644 --- /dev/null +++ b/CSPM-Frontend.cabal @@ -0,0 +1,62 @@ +Name: CSPM-Frontend +Version: 0.2.8.0 + +Synopsis: A CSP-M parser compatible with FDR-2.83 + +Description: + CSP-M is the machine readable syntax of CSP (concurrent sequential processes) as used by + the formal methods tools FDR, Prob and ProB. + This Package contains functions for lexing, parsing, renaming and pretty-printing + CSP-M specifications. + The parser is (almost) 100% compatible with the FDR-2.83 parser. + This package is also used as the CSP-M frontend of the ProB animator and model checker. + + + +License: BSD3 +category: Language,Formal Methods,Concurrency +License-File: LICENSE +Author: Marc Fontaine +Maintainer: Marc Fontaine +Stability: unstable +Tested-With: GHC ==6.10.3 + +cabal-Version: >= 1.6 +build-type: Simple +Extra-source-files: + +flag testing { + description : Testing mode + default: False +} + + +library + if flag(testing) { + buildable: False + } + + Build-Depends: base >=4.0 && < 5.0, containers,array,parsec >=2.1.0.0 && < 3.0 ,old-time,template-haskell, pretty,mtl,haskell98,syb + + GHC-Options: -funbox-strict-fields -O2 -fasm -optl-Wl,-s -Wall + Extensions: DeriveDataTypeable, GeneralizedNewtypeDeriving + Hs-Source-Dirs: src,dist/build/autogen + Exposed-modules: + Language.CSPM.Frontend + Language.CSPM.Utils + Language.CSPM.AST + Language.CSPM.Parser + Language.CSPM.Rename + Language.CSPM.Token + Language.CSPM.SrcLoc + Language.CSPM.AstUtils + Language.CSPM.TokenClasses + Language.CSPM.PrettyPrinter + Language.CSPM.PatternCompiler + Other-modules: + Paths_CSPM_Frontend + Language.CSPM.Version + Language.CSPM.Lexer + Language.CSPM.AlexWrapper + Language.CSPM.LexHelper + Text.ParserCombinators.Parsec.ExprM diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Marc Fontaine 2007-2009 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/src/Language/CSPM/AST.hs b/src/Language/CSPM/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/AST.hs @@ -0,0 +1,378 @@ +---------------------------------------------------------------------------- +-- | +-- Module : Language.CSPM.AST +-- Copyright : (c) Fontaine 2008 +-- License : BSD +-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- This Module defines an Abstract Syntax Tree for CSPM. +-- This is the AST that is computed by the parser. +-- For historycal reasons, it is rather unstructured +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +module Language.CSPM.AST +where + +import Language.CSPM.Token +import Language.CSPM.SrcLoc (SrcLoc(..)) + +import Data.Typeable (Typeable) +import Data.Generics.Basics (Data) +import Data.Generics.Instances () +import Data.IntMap (IntMap) +import Data.Map (Map) +import Data.Array.IArray + +type AstAnnotation x = IntMap x +type Bindings = Map String UniqueIdent +type FreeNames = IntMap UniqueIdent + +newtype NodeId = NodeId {unNodeId :: Int} + deriving (Show,Eq,Ord,Enum,Ix, Typeable, Data) + +mkNodeId :: Int -> NodeId +mkNodeId = NodeId + +data Labeled t = Labeled { + nodeId :: NodeId + ,srcLoc :: SrcLoc + ,unLabel :: t + } deriving (Typeable, Data,Show) + +instance Eq (Labeled t) where + (==) a b = (nodeId a) == (nodeId b) + +instance Ord (Labeled t) where + compare a b = compare (nodeId a) (nodeId b) + +-- | wrap a node with a dummyLabel +-- | todo: redo we need a specal case in DataConstructor Labeled +-- | also rename to unLabeled +labeled :: t -> Labeled t +labeled t = Labeled { + --error use hashfunction here + nodeId = NodeId (-1) --error "unknown nodeId" + ,unLabel = t + ,srcLoc = NoLocation + } + +setNode :: Labeled t -> y -> Labeled y +setNode l n = l {unLabel = n} + +type LIdent = Labeled Ident + +data Ident + = Ident {unIdent :: String} + | UIdent {unUIdent :: UniqueIdent} + deriving (Show,Eq,Ord,Typeable, Data) + +identId :: LIdent -> Int +identId = uniqueIdentId . unUIdent . unLabel + +data UniqueIdent = UniqueIdent + { + uniqueIdentId :: Int + ,bindingSide :: NodeId + ,bindingLoc :: SrcLoc + ,idType :: IDType + ,realName :: String + ,newName :: String + ,prologMode :: PrologMode + ,bindType :: BindType + } deriving (Show,Eq,Ord,Typeable, Data) + +data IDType + = VarID | ChannelID | NameTypeID | FunID Int + | ConstrID String | DataTypeID | TransparentID + deriving (Show,Eq,Ord,Typeable, Data) + +{- actually BindType and PrologMode are semantically aquivalent -} +data BindType = LetBound | NotLetBound + deriving (Show,Eq,Ord,Typeable, Data) + +isLetBound :: BindType -> Bool +isLetBound x = x==LetBound + +data PrologMode = PrologGround | PrologVariable + deriving (Show,Eq,Ord,Typeable, Data) + +type LModule = Labeled Module +data Module = Module { + moduleDecls :: [LDecl] + ,moduleTokens :: Maybe [Token] + } deriving (Show,Eq,Ord,Typeable, Data) + + +{- +LProc is just a typealias for better readablility +todo : maybe use a real type +-} +type LProc = LExp + +-- expressions +type LExp = Labeled Exp + +data Exp + = Var LIdent + | IntExp Integer + | SetEnum [LExp] + | ListEnum [LExp] + | SetOpen LExp + | ListOpen LExp + | SetClose (LExp,LExp) + | ListClose (LExp,LExp) + | SetComprehension ([LExp],[LCompGen]) + | ListComprehension ([LExp],[LCompGen]) + | ClosureComprehension ([LExp],[LCompGen]) + | Let [LDecl] LExp + | Ifte LExp LExp LExp + | CallFunction LExp [[LExp]] + | CallBuiltIn LBuiltIn [[LExp]] + | Lambda [LPattern] LExp + | Stop + | Skip + | CTrue + | CFalse + | Events + | BoolSet + | IntSet + | TupleExp [LExp] + | Parens LExp + | AndExp LExp LExp + | OrExp LExp LExp + | NotExp LExp + | NegExp LExp + | Fun1 LBuiltIn LExp + | Fun2 LBuiltIn LExp LExp + | DotTuple [LExp] + | Closure [LExp] + | ProcSharing LExp LProc LProc + | ProcAParallel LExp LExp LProc LProc + | ProcLinkParallel LLinkList LProc LProc + | ProcRenaming [LRename] LProc + | ProcRenamingComprehension [LRename] [LCompGen] LProc + | ProcRepSequence LCompGenList LProc + | ProcRepInternalChoice LCompGenList LProc + | ProcRepInterleave LCompGenList LProc + | ProcRepChoice LCompGenList LProc + | ProcRepAParallel LCompGenList LExp LProc + | ProcRepLinkParallel LCompGenList LLinkList LProc + | ProcRepSharing LCompGenList LExp LProc + | PrefixExp LExp [LCommField] LProc +-- only used in later stages + | LetI [LDecl] FreeNames LExp -- freenames of all localBound names + | PrefixChan FreeNames LExp LProc +-- | PrefixI FreeNames LCommField LProc + | LambdaI FreeNames [LPattern] LExp + | ExprWithFreeNames FreeNames LExp + deriving (Show,Eq,Ord,Typeable, Data) + +type LCompGenList = Labeled [LCompGen] + +type LCommField = Labeled CommField +data CommField + = InComm LPattern + | InCommGuarded LPattern LExp + | OutComm LExp + deriving (Show,Eq,Ord,Typeable, Data) + +type LLinkList = Labeled LinkList +data LinkList + = LinkList [LLink] + | LinkListComprehension [LCompGen] [LLink] + deriving (Show,Eq,Ord,Typeable, Data) + +type LLink = Labeled Link +data Link = Link LExp LExp deriving (Show,Eq,Ord,Typeable, Data) + +type LRename = Labeled Rename +data Rename = Rename LExp LExp deriving (Show,Eq,Ord,Typeable, Data) + +type LBuiltIn = Labeled BuiltIn +data BuiltIn = BuiltIn Const deriving (Show,Eq,Ord,Typeable, Data) + +lBuiltInToConst :: LBuiltIn -> Const +lBuiltInToConst = h . unLabel where + h (BuiltIn c) = c + + --generators inside a comprehension-expression +type LCompGen = Labeled CompGen +data CompGen + = Generator LPattern LExp + | Guard LExp + deriving (Show,Eq,Ord,Typeable, Data) + + +type LPattern = Labeled Pattern +data Pattern + = IntPat Integer + | TruePat + | FalsePat + | WildCard + | ConstrPat LIdent + | Also [LPattern] + | Append [LPattern] + | DotPat [LPattern] + | SingleSetPat LPattern + | EmptySetPat + | ListEnumPat [LPattern] + | TuplePat [LPattern] +-- this the result of pattern-match-compilation + | VarPat LIdent + | Selectors { --origPat :: LPattern + -- fixme this creates an infinite tree with SYB everywehre' + selectors :: Array Int Selector + ,idents :: Array Int (Maybe LIdent) } + | Selector Selector (Maybe LIdent) + deriving (Show,Eq,Ord,Typeable, Data) + +{- a Selector is a path in a Pattern/Expression -} +data Selector + = IntSel Integer + | TrueSel + | FalseSel + | SelectThis + | ConstSel UniqueIdent + | DotSel Int Int Selector + | SingleSetSel Selector + | EmptySetSel + | TupleLengthSel Int Selector + | TupleIthSel Int Selector + | ListLengthSel Int Selector + | ListIthSel Int Selector + | HeadSel Selector + | HeadNSel Int Selector + | PrefixSel Int Int Selector + | TailSel Selector + | SliceSel Int Int Selector + | SuffixSel Int Int Selector + deriving (Show, Eq, Ord, Typeable, Data) + +type LDecl = Labeled Decl +data Decl + = PatBind LPattern LExp + | FunBind LIdent [FunCase] + | AssertRef LExp String LExp + | AssertBool LExp + | Transparent [LIdent] + | SubType LIdent [LConstructor] + | DataType LIdent [LConstructor] + | NameType LIdent LTypeDef + | Channel [LIdent] (Maybe LTypeDef) + | Print LExp +-- | FunBindI LIdent FreeNames [FunCase] + deriving (Show,Eq,Ord,Typeable, Data) + +{- +We want to use 1) type FunArgs = [LPattern] +it is not clear why we used 2) type FunArgs = [[LPattern]] + +If 1) works in the interpreter, we will refactor +Renaming , and prolog-interface to 1) + +For now we just patch the AST Just before PatternCompilation +-} +type FunArgs = [[LPattern]] -- CSPM confusion of currying/tuples +data FunCase + = FunCase FunArgs LExp -- osolete version + | FunCaseI [LPattern] LExp -- newVersion for interpreter + deriving (Show,Eq,Ord,Typeable, Data) + +type LTypeDef = Labeled TypeDef +data TypeDef + = TypeTuple [LExp] + | TypeDot [LExp] + deriving (Show,Eq,Ord,Typeable, Data) + +type LConstructor = Labeled Constructor +data Constructor + = Constructor LIdent (Maybe LTypeDef) + deriving (Show,Eq,Ord,Typeable, Data) + + + +{- +some helper functions +-} +{- does not make sense if nodId should be unique -} +instance Functor Labeled where + fmap f x = x {unLabel = f $ unLabel x } + +withLabel :: ( NodeId -> a -> b ) -> Labeled a -> Labeled b +withLabel f x = x {unLabel = f (nodeId x) (unLabel x) } + +mkLabeledNode :: (NodeIdSupply m) => SrcLoc -> t -> m (Labeled t) +mkLabeledNode loc node = do + i <- getNewNodeId + return $ Labeled { + nodeId = i + ,srcLoc = loc + ,unLabel = node } + +{- +-- user must supply a unique NodeId +unsafeMkLabeledNode :: NodeId -> SrcLoc -> t -> Labeled t +unsafeMkLabeledNode i loc node + = Labeled { + nodeId = i + ,srcLoc = loc + ,unLabel = node } +-} + +class (Monad m) => NodeIdSupply m where + getNewNodeId :: m NodeId + + +data Const + = F_true + | F_false + | F_not + | F_and + | F_or + | F_union + | F_inter + | F_diff + | F_Union + | F_Inter + | F_member + | F_card + | F_empty + | F_set + | F_Set + | F_Seq + | F_null + | F_head + | F_tail + | F_concat -- fix confusing F_Concat + | F_elem + | F_length + | F_STOP + | F_SKIP + | F_Events + | F_Int + | F_Bool + | F_CHAOS + | F_Concat -- fix confusing F_concat + | F_Len2 + | F_Mult + | F_Div + | F_Mod + | F_Add + | F_Sub + | F_Eq + | F_NEq + | F_GE + | F_LE + | F_LT + | F_GT + | F_Guard + | F_Sequential + | F_Interrupt + | F_ExtChoice + | F_Timeout + | F_IntChoice + | F_Interleave + | F_Hiding + deriving (Show,Eq,Ord,Typeable, Data) diff --git a/src/Language/CSPM/AlexWrapper.hs b/src/Language/CSPM/AlexWrapper.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/AlexWrapper.hs @@ -0,0 +1,137 @@ +module Language.CSPM.AlexWrapper +where + +import Language.CSPM.Token +import Language.CSPM.TokenClasses + +import Data.Char + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + String) -- current input string + +data AlexState = AlexState { + alex_pos :: !AlexPosn, -- position at current input location + alex_inp :: String, -- the current input + alex_chr :: !Char, -- the character before the input + alex_scd :: !Int, -- the current startcode + alex_cnt :: !Int -- nuber of tokens + } + +-- Compile with -funbox-strict-fields for best results! + +runAlex :: String -> Alex a -> Either LexError a +runAlex input (Alex f) + = case f (AlexState {alex_pos = alexStartPos, + alex_inp = input, + alex_chr = '\n', + alex_scd = 0, + alex_cnt = 0}) of Left msg -> Left msg + Right ( _, a ) -> Right a + +newtype Alex a = Alex { unAlex :: AlexState -> Either LexError (AlexState, a) } + +instance Monad Alex where + m >>= k = Alex $ \s -> case unAlex m s of + Left msg -> Left msg + Right (s',a) -> unAlex (k a) s' + return a = Alex $ \s -> Right (s,a) + +alexGetInput :: Alex AlexInput +alexGetInput + = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_inp=inp} -> + Right (s, (pos,c,inp)) + +alexSetInput :: AlexInput -> Alex () +alexSetInput (pos,c,inp) + = Alex $ \state -> case state {alex_pos=pos,alex_chr=c,alex_inp=inp} of + s@(AlexState{}) -> Right (s, ()) + +alexError :: String -> Alex a +alexError message = Alex $ update where + update st = Left $ LexError {lexEPos = alex_pos st, lexEMsg = message } + +alexGetStartCode :: Alex Int +alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc) + +alexSetStartCode :: Int -> Alex () +alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ()) + +-- increase token counter and return tokencount +alexNextToken :: Alex (Int) +alexNextToken = Alex $ \s@AlexState{alex_cnt=cnt} -> + Right (s {alex_cnt=(cnt+1)}, cnt) + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (_p,_c,[]) = Nothing +alexGetChar (p,_c,(c:s)) = let p' = alexMove p c in p' `seq` + Just (c, (p', c, s)) + +-- ----------------------------------------------------------------------------- +-- Useful token actions + +type AlexAction result = AlexInput -> Int -> result + +-- perform an action for this token, and set the start code to a new value +--andBegin :: AlexAction result -> Int -> AlexAction result +--andBegin action code input len = do alexSetStartCode code; action input len + +--token :: (String -> Int -> token) -> AlexAction token +--token t input len = return (t input len) + +-- after the dfa calls mkL, we copy the position and string to the token +mkL :: PrimToken -> AlexInput -> Int -> Alex Token +mkL c (pos,_,str) len = do + cnt<-alexNextToken + return (Token (mkTokenId cnt) pos len c (take len str)) + +block_comment :: AlexInput -> Int -> Alex Token +block_comment (startPos,_,_) _ = do + inputs <- alexGetInput + go 1 0 inputs inputs + where + go :: Int -> Int -> AlexInput -> AlexInput -> Alex Token + go 0 count input (spos,_,str) = do + alexSetInput input + cnt<-alexNextToken + return (Token (mkTokenId cnt) spos count L_BComment (take (count-2) str) ) + go n count inputt i= do + case alexGetChar inputt of + Nothing -> err inputt + Just (c,input) -> do + case c of + '-' -> do + case alexGetChar input of + Nothing -> err input + Just ('\125',input) -> go (n-1) (count+2) input i + Just (_c,input) -> go n (count+2) input i + '\123' -> do + case alexGetChar input of + Nothing -> err input + Just ('-',input) -> go (n+1) (count+2) input i + Just (_c,input) -> go n (count+2) input i + c -> go n (count+1) input i + + err input = do alexSetInput input; + lexError $ "Unclosed Blockcomment (starting at :" + ++ (pprintAlexPosn startPos) ++") " + +lexError :: String -> Alex a +lexError s = do + (_p,_c,input) <- alexGetInput + alexError ( s ++ (if (not (null input)) + then " at " ++ myShowChar (head input) + else " at end of file")) + where + myShowChar c = + if isPrint c then show c + else "charcode " ++ (show $ ord c) + + +alexEOF :: Alex Token +alexEOF = return (Token (mkTokenId 0) (AlexPn 0 0 0) 0 L_EOF "") + +{- reverenced from Code generated by Alex -} + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_p,c,_s) = c diff --git a/src/Language/CSPM/AstUtils.hs b/src/Language/CSPM/AstUtils.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/AstUtils.hs @@ -0,0 +1,114 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.CSPM.AstUtils +-- Copyright : (c) Fontaine 2008 +-- License : BSD +-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Some utility functions for converting the AST + +module Language.CSPM.AstUtils + ( + removeSourceLocations + ,removeParens + ,removeModuleTokens + ,unUniqueIdent + ,showAst + ,relabelAst + ,computeFreeNames + ) +where + +import Language.CSPM.AST hiding (prologMode) +import qualified Language.CSPM.AST as AST +import qualified Language.CSPM.SrcLoc as SrcLoc + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Data +import Data.Generics.Schemes (everywhere,listify) +import Data.Generics.Aliases (mkT,extQ) +import Data.Generics.Basics (gmapQ,toConstr,showConstr) + +-- | 'removeSourceLocations' sets all locationsInfos to 'NoLocation' +removeSourceLocations :: LModule -> LModule +removeSourceLocations ast + = everywhere (mkT patchLabel) ast + where + patchLabel :: SrcLoc.SrcLoc -> SrcLoc.SrcLoc + patchLabel _ = SrcLoc.NoLocation + +-- | set the tokenlist in the module datatype to Nothing +removeModuleTokens :: LModule -> LModule +removeModuleTokens t = t {unLabel = m} + where m = (unLabel t ) {moduleTokens = Nothing} + +-- | 'removeParens' removes all occurences of of Parens,i.e. explicit parentheses from the AST +removeParens :: LModule -> LModule +removeParens ast + = everywhere (mkT patchExp) ast + where + patchExp :: LExp -> LExp + patchExp x = case unLabel x of + Parens e -> e + _ -> x + +-- | unUniqueIdent replaces the all UIdent with the Ident of the the new name, thus forgetting +-- | additional information like the bindingside, etc. +-- | Usefull to get a smaller AST. +unUniqueIdent :: LModule -> LModule +unUniqueIdent ast + = everywhere (mkT patchIdent) ast + where + patchIdent :: Ident -> Ident + patchIdent (UIdent u) = Ident $ newName u + patchIdent _ = error "unUniqueIdent : did not expect and 'Ident' in the AST" + +-- | 'relabelAst' compute an AST with new NodeIds starting with the given NodeId +relabelAst :: + NodeId + -> LModule + -> LModule +relabelAst = error "relabel not yet implemented (TODO)" + +-- | 'a show function that omits the node labeles. +-- | TODO : fix this is very buggy. +showAst :: Data a => Labeled a -> String +showAst ast = gshow ast + where + gshow :: Data a => a -> String + gshow = mShow `extQ` (show :: String -> String) + mShow t = if (tyConString $ typeRepTyCon $ typeOf t) == "Language.CSPM.AST.Labeled" + then gmapQi 2 gshow t + else + "(" + ++ showConstr (toConstr t) + ++ concat (gmapQ ((++) " " . gshow) t) + ++ ")" + + + +-- | Compute the "FreeNames" of an Expression. +-- | This function does only work after renaming has been done. +-- | This implementation is inefficient. +computeFreeNames :: Data a => a -> FreeNames +computeFreeNames syntax + = IntMap.difference (toIntMap used) (toIntMap def) + where + toIntMap :: [UniqueIdent] -> IntMap UniqueIdent + toIntMap + = IntMap.fromList . map (\x -> (uniqueIdentId x,x)) + used :: [UniqueIdent] + used = map (\(Var x) -> unUIdent $ unLabel x) $ listify isUse syntax + def :: [UniqueIdent] + def = map (\(VarPat x) -> unUIdent $ unLabel x) $ listify isDef syntax + isUse :: Exp -> Bool + isUse (Var {}) = True + isUse _ = False + + isDef :: Pattern -> Bool + isDef (VarPat {}) = True + isDef _ = False diff --git a/src/Language/CSPM/Frontend.hs b/src/Language/CSPM/Frontend.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/Frontend.hs @@ -0,0 +1,66 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.CSPM.Frontend +-- Copyright : (c) Fontaine 2008 +-- License : BSD +-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Frontend contains some reexports from other modules + +module Language.CSPM.Frontend +( + testFrontend + ,parseFile + ,Token + ,Lexer.lexInclude + ,Lexer.lexPlain + ,Lexer.filterIgnoredToken + ,LexError(..) + ,parse + ,ParseError(..) + ,Module + ,LModule + ,Labeled(..) + ,Bindings + ,getRenaming + ,applyRenaming + -- AstUtils + ,removeSourceLocations + ,removeParens + ,removeModuleTokens + ,unUniqueIdent + ,showAst + ,relabelAst + ,computeFreeNames + -- + ,RenameError(..) + ,eitherToExc + ,handleLexError + ,handleParseError + ,handleRenameError + ,compilePattern + ,version + ,pp +) +where + +import Language.CSPM.Parser (ParseError(..),parse) +import Language.CSPM.Rename (RenameError(..),getRenaming,applyRenaming) +import Language.CSPM.PatternCompiler (compilePattern) +import Language.CSPM.Token (Token,LexError(..)) +import Language.CSPM.AST (Labeled(..),LModule,Module(..),Bindings) +import Language.CSPM.AstUtils + (removeSourceLocations,removeModuleTokens,removeParens,relabelAst + ,unUniqueIdent,showAst,computeFreeNames) + +import qualified Language.CSPM.LexHelper as Lexer + (lexInclude,lexPlain,filterIgnoredToken) +import Language.CSPM.Version + +import Language.CSPM.PrettyPrinter (pp) +import Language.CSPM.Utils + (eitherToExc,handleLexError,handleParseError,handleRenameError + ,parseFile,testFrontend) diff --git a/src/Language/CSPM/LexHelper.hs b/src/Language/CSPM/LexHelper.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/LexHelper.hs @@ -0,0 +1,73 @@ +module Language.CSPM.LexHelper +( + lexInclude + ,lexPlain + ,filterIgnoredToken + ,tokenIsIgnored + ,tokenIsComment + ,tokenIsFDR +) +where + +import qualified Language.CSPM.Lexer as Lexer (scanner) +import Language.CSPM.Token (Token(..), LexError(..) ) +import Language.CSPM.TokenClasses (PrimToken(..)) +import qualified Language.CSPM.Token as Token + (Token(..), LexError(..)) + +{- todo : use an error monad -} + +lexInclude :: String -> IO (Either LexError [Token]) +lexInclude src = do + case Lexer.scanner src of + Left err -> return $ Left err + Right toks -> do + tokenIncl <- processIncludeAndReverse toks + case tokenIncl of + Left err -> return $ Left err + Right t -> return $ Right t + +lexPlain :: String -> Either LexError [Token] +lexPlain src = fmap reverse $ Lexer.scanner src + +processIncludeAndReverse :: [Token] -> IO (Either LexError [Token] ) +processIncludeAndReverse tokens = picl_acc tokens [] + where + picl_acc ::[Token] ->[Token] -> IO (Either LexError [Token] ) + picl_acc [] acc = return $ Right acc + picl_acc ((Token _ _ _ L_String fname) : (Token _ _ _ L_Include _) :trest) acc = do + let fileName = reverse $ tail $ reverse $ tail fname -- remove quotes + -- putStrLn $ "Including file : " ++ fileName + input <-readFile fileName + case Lexer.scanner input of + Right toks -> do + new_acc <- picl_acc toks acc + case new_acc of + Right t -> picl_acc trest t + e -> return e + Left e -> return $ Left e + picl_acc ((incl@(Token _ _ _ L_Include _)) : _) _ = + return $ Left $ LexError { + lexEPos = tokenStart incl + ,lexEMsg = "Include without filename" + } + picl_acc (h:rest) acc = picl_acc rest $ h:acc + + +filterIgnoredToken :: [Token] -> [Token] +filterIgnoredToken = filter ( not . tokenIsIgnored) + +tokenIsIgnored :: Token -> Bool +tokenIsIgnored (Token _ _ _ L_LComment _) = True +tokenIsIgnored (Token _ _ _ L_CSPFDR _) = True +tokenIsIgnored (Token _ _ _ L_BComment _) = True +tokenIsIgnored _ = False + +tokenIsComment :: Token -> Bool +tokenIsComment (Token _ _ _ L_LComment _) = True +tokenIsComment (Token _ _ _ L_BComment _) = True +tokenIsComment _ = False + +tokenIsFDR :: Token -> Bool +tokenIsFDR (Token _ _ _ L_CSPFDR _) = True +tokenIsFDR _ = False diff --git a/src/Language/CSPM/Lexer.x b/src/Language/CSPM/Lexer.x new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/Lexer.x @@ -0,0 +1,225 @@ +{ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -cpp #-} + +module Language.CSPM.Lexer +( +scanner +) +where +import Language.CSPM.Token +import Language.CSPM.TokenClasses +import Language.CSPM.AlexWrapper +} + +$whitechar = [\ \t\n\r\f\v] +$special = [\(\)\,\;\[\]\`\{\}] + +$ascdigit = 0-9 +$unidigit = [] -- TODO +$digit = [$ascdigit $unidigit] + +$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~] +$unisymbol = [] -- TODO +$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\'] + +--$large = [A-Z \xc0-\xd6 \xd8-\xde] +--$small = [a-z \xdf-\xf6 \xf8-\xff \_] +$large = [A-Z] +$small = [a-z] +$alpha = [$small $large] + +$graphic = [$small $large $symbol $digit $special \:\"\'] + +$octit = 0-7 +$hexit = [0-9 A-F a-f] +$idchar = [$alpha $digit \' \_] +$symchar = [$symbol \:] +$nl = [\n\r] + +@ident = $alpha $idchar* + +@varid = $small $idchar* +@conid = $large $idchar* +@varsym = $symbol $symchar* +@consym = \: $symchar* + +@decimal = $digit+ +@octal = $octit+ +@hexadecimal = $hexit+ +@exponent = [eE] [\-\+] @decimal + +$cntrl = [$large \@\[\\\]\^\_] +@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK + | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE + | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM + | SUB | ESC | FS | GS | RS | US | SP | DEL +$charesc = [abfnrtv\\\"\'\&] +@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal) +@gap = \\ $whitechar+ \\ +@string = $graphic # [\"\\] | " " | @escape | @gap + +@assertExts = $whitechar+ "[FD]" | $whitechar+ "[F]" +@assertCore = "deterministic" @assertExts? + | "livelock" $whitechar+ "free" @assertExts? + | "deadlock" $whitechar+ "free" @assertExts? + | "divergence" $whitechar+ "free" @assertExts? + +csp :- + +-- CSP-M Keywords +<0> "channel" { mkL T_channel } +<0> "datatype" { mkL T_datatype } +<0> "nametype" { mkL T_nametype } +<0> "subtype" { mkL T_subtype } +<0> "assert" { mkL T_assert } +<0> "pragma" { mkL T_pragma } +<0> "transparent" { mkL T_transparent } +<0> "external" { mkL T_external } +<0> "print" { mkL T_print } +<0> "if" { mkL T_if } +<0> "then" { mkL T_then } +<0> "else" { mkL T_else } +<0> "let" { mkL T_let } +<0> "within" { mkL T_within } + +-- CSP-M builtIns + +<0> "STOP" { mkL T_STOP } +<0> "SKIP" { mkL T_SKIP } +<0> "true" { mkL T_true } +<0> "false" { mkL T_false } +<0> "not" { mkL T_not } +<0> "and" { mkL T_and } +<0> "or" { mkL T_or } +<0> "Int" { mkL T_Int } +<0> "Bool" { mkL T_Bool } +<0> "Events" { mkL T_Events } +<0> "CHAOS" { mkL T_CHAOS } +<0> "union" { mkL T_union } +<0> "inter" { mkL T_inter } +<0> "diff" { mkL T_diff } +<0> "Union" { mkL T_Union } +<0> "Inter" { mkL T_Inter } +<0> "member" { mkL T_member } +<0> "card" { mkL T_card } +<0> "empty" { mkL T_empty } +<0> "set" { mkL T_set } +<0> "Set" { mkL T_Set } +<0> "Seq" { mkL T_Seq } +<0> "null" { mkL T_null } +<0> "head" { mkL T_head } +<0> "tail" { mkL T_tail } +<0> "concat" { mkL T_concat } +<0> "elem" { mkL T_elem } +<0> "length" { mkL T_length } + +-- symbols +<0> "^" { mkL T_hat } +<0> "#" { mkL T_hash } +<0> "*" { mkL T_times } +<0> "/" { mkL T_slash } +<0> "%" { mkL T_percent } +<0> "+" { mkL T_plus } +<0> "-" { mkL T_minus } +<0> "==" { mkL T_eq } +<0> "!=" { mkL T_neq } +<0> ">=" { mkL T_ge } +<0> "<=" { mkL T_le } +<0> "<" { mkL T_lt } +<0> ">" { mkL T_gt } +<0> "&" { mkL T_amp } +<0> ";" { mkL T_semicolon } +<0> "," { mkL T_comma } +<0> "/\" { mkL T_triangle } +<0> "[]" { mkL T_box } +<0> "[>" { mkL T_rhd } +<0> "|~|" { mkL T_sqcap } +<0> "|||" { mkL T_interleave } +<0> "\" { mkL T_backslash } +<0> "||" { mkL T_parallel } +<0> "|" { mkL T_mid } +<0> "@" { mkL T_at } +<0> "@@" { mkL T_atat } +<0> "->" { mkL T_rightarrow } +<0> "<-" { mkL T_leftarrow } +<0> "<->" { mkL T_leftrightarrow } +<0> "." { mkL T_dot } +<0> ".." { mkL T_dotdot } +<0> "!" { mkL T_exclamation } +<0> "?" { mkL T_questionmark } +<0> ":" { mkL T_colon } +<0> "(" { mkL T_openParen } +<0> ")" { mkL T_closeParen } +<0> "{" { mkL T_openBrace } +<0> "}" { mkL T_closeBrace } +<0> "[" { mkL T_openBrack } +<0> "]" { mkL T_closeBrack } +<0> "[|" { mkL T_openOxBrack } +<0> "|]" { mkL T_closeOxBrack } +<0> "{|" { mkL T_openPBrace } +<0> "|}" { mkL T_closePBrace } +<0> "_" { mkL T_underscore } +<0> "=" { mkL T_is } +<0> "[[" { mkL T_openBrackBrack } +<0> "]]" { mkL T_closeBrackBrack } + +<0> $white+ { skip } +<0> "--".* { mkL L_LComment } +"{-" { block_comment } + +-- Fixme : tread this properly +<0> ":[" $whitechar* @assertCore $whitechar* "]" { mkL L_CSPFDR } + +<0> "include" { mkL L_Include } + +<0> @ident { mkL L_Ident} -- ambiguity for wildcardpattern _ + +<0> @decimal + | 0[oO] @octal + | 0[xX] @hexadecimal { mkL L_Integer } + + +-- <0> \' ($graphic # [\'\\] | " " | @escape) \' { mkL LChar } + + <0> \" @string* \" { mkL L_String } + +<0> "[" $large + "=" { mkL T_Refine } + + + +{ +alexMonadScan = do + inp <- alexGetInput + sc <- alexGetStartCode + case alexScan inp sc of -- alexScan is jump to alexGenerated code + AlexEOF -> alexEOF + AlexError (pos,chr,h:rest) + -> lexError $ "lexical error" + AlexSkip inp' len -> do + alexSetInput inp' + alexMonadScan + AlexToken inp' len action -> do + alexSetInput inp' + action inp len + +scanner str = runAlex str $ scannerAcc [] + where + scannerAcc i = do + tok <- alexMonadScan; + if tokenClass tok == L_EOF + then return i + else scannerAcc $! (tok:i) + +-- just ignore this token and scan another one +-- skip :: AlexAction result +skip input len = alexMonadScan + +-- ignore this token, but set the start code to a new value +-- begin :: Int -> AlexAction result +begin code input len = do alexSetStartCode code; alexMonadScan + +} diff --git a/src/Language/CSPM/Parser.hs b/src/Language/CSPM/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/Parser.hs @@ -0,0 +1,1117 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.CSPM.Parser +-- Copyright : (c) Fontaine 2008 +-- License : BSD +-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- This modules defines a Parser for CSPM +-- +----------------------------------------------------------------------------- +{- todo: +* add Autoversion to packet +* add wrappers for functions that throw dynamic exceptions +-} +{-# OPTIONS_GHC -fglasgow-exts #-} +{-# LANGUAGE ImplicitParams #-} +module Language.CSPM.Parser +( + parse + ,ParseError(..) +) +where +import Language.CSPM.AST +import Language.CSPM.Token (Token(..),AlexPosn) +import Language.CSPM.TokenClasses as TokenClasses +import qualified Language.CSPM.Token as Token + +import qualified Language.CSPM.SrcLoc as SrcLoc +import Language.CSPM.SrcLoc (SrcLoc) + +import Language.CSPM.LexHelper (filterIgnoredToken) +import Text.ParserCombinators.Parsec.ExprM + +import Text.ParserCombinators.Parsec + hiding (parse,eof,notFollowedBy,anyToken,label,ParseError,errorPos,token) +import Text.ParserCombinators.Parsec.Pos (newPos) +import qualified Text.ParserCombinators.Parsec.Error as ParsecError +import Data.Typeable (Typeable) +import Control.Monad.State +import Data.List +import Prelude hiding (exp) +import Control.Exception (Exception) + +type PT a= GenParser Token PState a + +-- | The 'parse' function parses a List of 'Token'. +-- It returns a 'ParseError' or a 'Labled' 'Module'. +-- The 'SourceName' argument is currently not used. +parse :: + SourceName + -> [Token] + -> Either ParseError LModule +parse filename tokenList + = wrapParseError tokenList $ + runParser (parseModule tokenList) initialPState filename $ filterIgnoredToken tokenList + +data ParseError = ParseError { + parseErrorMsg :: String + ,parseErrorToken :: Token + ,parseErrorPos :: AlexPosn + } deriving (Show,Typeable) + +instance Exception ParseError + +data PState + = PState { + lastTok :: Token + ,lastChannelDir :: LastChannelDir + ,gtCounter :: Int + ,gtMode :: GtMode + ,nodeIdSupply :: NodeId + } deriving Show + +initialPState :: PState +initialPState = PState { + lastTok = Token.tokenSentinel + ,lastChannelDir = WasOut + ,gtCounter = 0 + ,gtMode = GtNoLimit + ,nodeIdSupply = mkNodeId 0 + } + +setLastChannelDir :: LastChannelDir -> PState -> PState +setLastChannelDir dir env = env {lastChannelDir=dir} + +setGtMode :: GtMode-> PState -> PState +setGtMode mode env = env {gtMode = mode} + +countGt :: PState -> PState +countGt env = env {gtCounter = gtCounter env +1 } + +data LastChannelDir = WasIn | WasOut deriving Show +data GtMode=GtNoLimit | GtLimit Int deriving Show + +instance NodeIdSupply (GenParser Token PState) where + getNewNodeId = do + i <- gets nodeIdSupply + modify $ \s -> s { nodeIdSupply = succ $ nodeIdSupply s} + return i + +instance MonadState PState (GenParser Token PState) where + get = getState + put = setState + +getNextPos :: PT Token +getNextPos = do + tokenList <-getInput + case tokenList of + (hd:_) -> return hd + [] -> return Token.tokenSentinel + +getLastPos :: PT Token +getLastPos = getStates lastTok + +getPos :: PT SrcLoc +getPos = do + t<-getNextPos + return $ mkSrcPos t + +mkSrcSpan :: Token -> Token -> SrcLoc +mkSrcSpan b e= SrcLoc.mkTokSpan b e + +{-# DEPRECATED mkSrcPos "simplify alternatives for sourcelocations" #-} +mkSrcPos :: Token -> SrcLoc +mkSrcPos l = SrcLoc.mkTokPos l + +withLoc :: PT a -> PT (Labeled a) +withLoc a = do + s <- getNextPos + av <- a + e <- getLastPos + mkLabeledNode (mkSrcSpan s e) av + +inSpan :: (a -> b ) -> PT a -> PT (Labeled b) +inSpan constr exp = do + s <- getNextPos + l <- exp + e <- getLastPos + mkLabeledNode (mkSrcSpan s e) $ constr l + +parseModule :: [Token.Token] -> PT (Labeled Module) +parseModule tokenList = withLoc $ do + decl<-topDeclList + eof "end of module" + return $ Module { + moduleDecls = decl + ,moduleTokens = Just tokenList + } + +token :: TokenClasses.PrimToken -> PT () +token t = tokenPrimExDefault tokenTest + where + tokenTest tok = if tokenClass tok == t + then Just () + else Nothing + +{- +builtInFunctions :: Set TokenClasses.PrimToken +builtInFunctions = Set.fromList + [ T_union ,T_inter, T_diff, T_Union, T_Inter, + T_member, T_card, T_empty, T_set, T_Set, + T_Seq, T_null, T_head, T_tail, T_concat, + T_elem, T_length, T_CHAOS ] +-} + +anyBuiltIn :: PT Const +anyBuiltIn = try $ do + tok <- tokenPrimExDefault (\t -> Just $ tokenClass t) + case tok of + T_union -> return F_union + T_inter -> return F_inter + T_diff -> return F_diff + T_Union -> return F_Union + T_Inter -> return F_Inter + T_member -> return F_member + T_card -> return F_card + T_empty -> return F_empty + T_set -> return F_set + T_Set -> return F_Set + T_Seq -> return F_Seq + T_null -> return F_null + T_head -> return F_head + T_tail -> return F_tail + T_concat -> return F_concat + T_elem -> return F_elem + T_length -> return F_length + T_CHAOS -> return F_CHAOS + _ -> fail "not a built-in function" + + +blockBuiltIn :: PT a +blockBuiltIn = do + bi <- anyBuiltIn + fail $ "can not use built-in '"++ show bi ++ "' here" -- todo fix: better error -message + + +lIdent :: PT String +lIdent = + tokenPrimExDefault testToken + "identifier" + where + testToken t = case tokenClass t of + L_Ident -> Just $ tokenString t + _ -> Nothing + +ident :: PT LIdent +ident = withLoc (lIdent >>= return . Ident) + +varExp :: PT LExp +varExp= withLoc (ident >>= return . Var) + +commaSeperator :: PT () +commaSeperator = token T_comma + +sepByComma :: PT x -> PT [x] +sepByComma a = sepBy a commaSeperator + +sepBy1Comma :: PT x -> PT [x] +sepBy1Comma a = sepBy1 a commaSeperator + +rangeCloseExp :: PT (LExp,LExp) +rangeCloseExp = do + s<-parseExp_noPrefix + token T_dotdot + e<- parseExp_noPrefix + return (s,e) + +rangeOpenExp :: PT LExp +rangeOpenExp = do + s <- parseExp_noPrefix + token T_dotdot + return s + +comprehensionExp :: PT ([LExp],[LCompGen]) +comprehensionExp = do + expList <- sepByComma parseExp + gens <- parseComprehension + return (expList,gens) + +parseComprehension :: PT [LCompGen] +parseComprehension = token T_mid >> sepByComma (compGenerator<|>compGuard ) + +compGuard :: PT LCompGen +compGuard= withLoc (parseExp_noPrefix >>= return . Guard) + +compGenerator :: PT LCompGen +compGenerator = try $ withLoc $ do + pat <- parsePattern + token T_leftarrow + exp <- parseExp_noPrefix + return $ Generator pat exp + +-- replicated operations use comprehensions with a differen Syntax +comprehensionRep :: PT LCompGenList +comprehensionRep = withLoc $ do + l <- sepByComma (repGenerator <|> compGuard) + token T_at + return l + +repGenerator :: PT LCompGen +repGenerator = try $ withLoc $ do + pat <- parsePattern + token T_colon + exp <- parseExp_noPrefix + return $ Generator pat exp + +inBraces :: PT x -> PT x +inBraces = between (token T_openBrace) (token T_closeBrace) + +inParens :: PT x -> PT x +inParens = between (token T_openParen) (token T_closeParen) + +setExpEnum :: PT LExp +setExpEnum = inSpan SetEnum $ inBraces (sepByComma parseExp) + +listExpEnum :: PT LExp +listExpEnum = inSpan ListEnum $ betweenLtGt (sepByComma parseExp_noPrefix) + +setExpOpen :: PT LExp +setExpOpen = inSpan SetOpen $ inBraces rangeOpenExp + +listExpOpen :: PT LExp +listExpOpen = inSpan ListOpen $ betweenLtGt rangeOpenExp + +setExpClose :: PT LExp +setExpClose = inSpan SetClose $ inBraces rangeCloseExp + +listExpClose :: PT LExp +listExpClose = inSpan ListClose $ betweenLtGt rangeCloseExp + +setComprehension :: PT LExp +setComprehension = inSpan SetComprehension $ inBraces comprehensionExp + +listComprehension :: PT LExp +listComprehension = inSpan ListComprehension $ betweenLtGt comprehensionExp + +closureComprehension :: PT LExp +closureComprehension = inSpan ClosureComprehension + $ between (token T_openPBrace) (token T_closePBrace) comprehensionExp + +-- todo check in csp-m doku size of Int +intLit :: PT Integer +intLit = + -- " - {-comment-} 10 " is parsed as Integer(-10) " + (token T_minus >> linteger >>= return . negate) + <|> linteger + where + linteger :: PT Integer + linteger = tokenPrimExDefault testToken + testToken t = if tokenClass t == L_Integer + then Just $ read $ tokenString t + else Nothing + +negateExp :: PT LExp +negateExp = withLoc $ do + token T_minus + body <- parseExp + return $ NegExp body + +litExp :: PT LExp +litExp = inSpan IntExp intLit + +litPat :: PT LPattern +litPat = inSpan IntPat intLit + +letExp :: PT LExp +letExp = withLoc $ do + token T_let + decl <- parseDeclList + token T_within + exp <- parseExp + return $ Let decl exp + +ifteExp :: PT LExp +ifteExp = withLoc $ do + token T_if + cond <- parseExp + token T_then + thenExp <- parseExp + token T_else + elseExp <- parseExp + return $ Ifte cond thenExp elseExp + + +funCall :: PT LExp +funCall = funCallFkt <|> funCallBi + +funCallFkt :: PT LExp +funCallFkt = withLoc $ do + fkt <- varExp + args <- parseFunArgs + return $ CallFunction fkt args + +funCallBi :: PT LExp +funCallBi = withLoc $ do + fkt <- inSpan BuiltIn anyBuiltIn + args <- parseFunArgs + return $ CallBuiltIn fkt args + +parseFunArgs :: PT [[LExp]] +parseFunArgs = do + argsL <- many1 funArgsT + return argsL + +{- +fun application in tuple form f(1,2,3) +if the tuple is follwed by "=", it belongs to the next declaration +g = h +(a,b) = (1,2) +-} + +funArgsT :: PT [LExp] +funArgsT = try $ do + tArgs <- inParens $ sepByComma parseExp + notFollowedBy' token_is + return tArgs + +lambdaExp :: PT LExp +lambdaExp = withLoc $ do + token T_backslash + patList <- sepBy1 parsePattern $ token T_comma + token T_at + exp <- parseExp + return $ Lambda patList exp + +parseExpBase :: PT LExp +parseExpBase = + parenExpOrTupleEnum + <|> (try funCall) + <|> withLoc ( token T_STOP >> return Stop) + <|> withLoc ( token T_SKIP >> return Skip) + <|> withLoc ( token T_true >> return CTrue) + <|> withLoc ( token T_false >> return CFalse) + <|> withLoc ( token T_Events >> return Events) + <|> withLoc ( token T_Bool >> return BoolSet) + <|> withLoc ( token T_Int >> return IntSet) + <|> ifteExp + <|> letExp + <|> try litExp -- -10 is Integer(-10) + <|> negateExp -- -(10) is NegExp(Integer(10)) + <|> varExp + <|> lambdaExp + <|> try closureComprehension + <|> closureExp + <|> try listComprehension + <|> try setComprehension + <|> try listExpEnum + <|> try setExpEnum + <|> try setExpClose + <|> try listExpClose + <|> try setExpOpen + <|> try listExpOpen + <|> blockBuiltIn + "core-expression" + + +{- +maybe need a Ast-node for parenExp for prettyPrint-Printing +parenExps are now a special case of TupleExps +-} + +parenExpOrTupleEnum :: PT LExp +parenExpOrTupleEnum = withLoc $ do + body <- inParens $ sepByComma parseExp + case body of + [] -> return $ TupleExp [] + [x] -> return $ Parens x + _ -> return $ TupleExp body + + +{- +Warning : postfixM and Prefix may not be nested + "not not true" does not parse !! +-} +opTable :: [[Text.ParserCombinators.Parsec.ExprM.Operator + Token PState LExp]] +opTable = + [ +-- [ infixM ( cspSym "." >> binOp mkDotPair) AssocRight ] +-- , +-- dot.expression moved to a seperate Step +-- ToDo : fix funApply and procRenaming + [ postfixM funApplyImplicit ] + ,[ postfixM procRenaming ] + ,[ infixM (nfun2 T_hat F_Concat ) AssocLeft, + prefixM (nfun1 T_hash F_Len2 ) -- different from Roscoe Book + ] + ,[ infixM (nfun2 T_times F_Mult ) AssocLeft + ,infixM (nfun2 T_slash F_Div ) AssocLeft + ,infixM (nfun2 T_percent F_Mod ) AssocLeft + ] + ,[ infixM (nfun2 T_plus F_Add ) AssocLeft, + infixM (nfun2 T_minus F_Sub ) AssocLeft + ] + ,[ infixM (nfun2 T_eq F_Eq ) AssocLeft + ,infixM (nfun2 T_neq F_NEq) AssocLeft + ,infixM (nfun2 T_ge F_GE ) AssocLeft + ,infixM (nfun2 T_le F_LE ) AssocLeft + ,infixM (nfun2 T_lt F_LT ) AssocLeft + ,infixM (do + s <- getNextPos + gtSym + e <- getLastPos + op <- mkLabeledNode (mkSrcSpan s e) (BuiltIn F_GT) + return $ (\a b-> mkLabeledNode (posFromTo a b) $ Fun2 op a b) + ) AssocLeft + ] + ,[ prefixM ( token T_not >> unOp NotExp )] + ,[ infixM ( token T_and >> binOp AndExp) AssocLeft ] + ,[ infixM ( token T_or >> binOp OrExp) AssocLeft ] + ,[ infixM proc_op_aparallel AssocLeft ] + ,[ infixM proc_op_lparallel AssocLeft ] + + ,[infixM procOpSharing AssocLeft ] + ,[infixM (nfun2 T_amp F_Guard ) AssocLeft] + ,[infixM (nfun2 T_semicolon F_Sequential ) AssocLeft] + ,[infixM (nfun2 T_triangle F_Interrupt ) AssocLeft] + ,[infixM (nfun2 T_box F_ExtChoice ) AssocLeft] + ,[infixM (nfun2 T_rhd F_Timeout ) AssocLeft] + ,[infixM (nfun2 T_sqcap F_IntChoice ) AssocLeft] + ,[infixM (nfun2 T_interleave F_Interleave ) AssocLeft] + ,[infixM (nfun2 T_backslash F_Hiding ) AssocLeft] + ] + where + nfun1 :: TokenClasses.PrimToken -> Const -> PT (LExp -> PT LExp) + nfun1 tok cst = do + fkt <- biOp tok cst + pos<-getPos + return $ (\a -> mkLabeledNode pos $ Fun1 fkt a) + + nfun2 :: TokenClasses.PrimToken -> Const -> PT (LExp -> LExp -> PT LExp) + nfun2 tok cst = do + fkt <- biOp tok cst + pos<-getLastPos +-- return $ \a b -> mkLabeledNode (posFromTo a b) $ Fun2 fkt a b + return $ \a b -> mkLabeledNode (mkSrcPos pos) $ Fun2 fkt a b + + binOp :: (LExp -> LExp -> Exp) -> PT (LExp -> LExp -> PT LExp) + binOp op = return $ \a b -> mkLabeledNode (posFromTo a b) $ op a b + + unOp :: (LExp -> Exp) -> PT (LExp -> PT LExp ) + unOp op = do + pos<-getLastPos + return $ (\a -> mkLabeledNode (mkSrcPos pos) $ op a) + + biOp :: TokenClasses.PrimToken -> Const -> PT LBuiltIn + biOp tok cst = inSpan BuiltIn (token tok >> return cst) + + posFromTo :: LExp -> LExp -> SrcLoc.SrcLoc + posFromTo a b = SrcLoc.srcLocFromTo (srcLoc a) (srcLoc b) + +parseExp :: PT LExp +parseExp = + (parseDotExpOf $ + buildExpressionParser opTable parseProcReplicatedExp + ) + "expression" + +parseExp_noPrefix_NoDot :: PT LExp +parseExp_noPrefix_NoDot = buildExpressionParser opTable parseExpBase + +parseExp_noPrefix :: PT LExp +parseExp_noPrefix = parseDotExpOf parseExp_noPrefix_NoDot + +parseDotExpOf :: PT LExp -> PT LExp +parseDotExpOf baseExp = do + sPos <-getNextPos + dotExp <- sepBy1 baseExp $ token T_dot + ePos <-getLastPos + case dotExp of + [x] -> return x + l -> mkLabeledNode (mkSrcSpan sPos ePos) $ DotTuple l + +{- +place (term) as a suffix behind any term to +make a function application +used a lot in CspBook -examples +notice : we do not destict between f(a,b,c) and f(a)(b)(c) or f(a,b)(c) +this is buggy for f(a)(b)(c) +this may interact with normal function -application ! +-} +funApplyImplicit :: PT (LExp -> PT LExp) +funApplyImplicit = do + args <- parseFunArgs + pos <-getPos + return $ (\fkt -> mkLabeledNode pos $ CallFunction fkt args ) + + +-- this is complicated and meight as well be buggy ! +gtSym :: PT () +gtSym = try $ do + token T_gt + updateState countGt --we count the occurences of gt-symbols + next <- testFollows parseExp -- and accept it only if it is followed by an expression + case next of + Nothing -> fail "Gt token not followed by an expression" + (Just _) -> do -- + mode <- getStates gtMode + case mode of + GtNoLimit -> return () + (GtLimit x) -> do + cnt <- getStates gtCounter + if cnt < x then return () + else fail "(Gt token belongs to sequence expression)" +{- +parse an sequenceexpression <...> +we have to be carefull not to parse the end of sequence ">" +as comparision +-} + +token_gt :: PT () +token_gt = token T_gt + +token_lt :: PT () +token_lt = token T_lt + +betweenLtGt :: PT a -> PT a +betweenLtGt parser = do + token_lt + st <- getParserState -- maybe we need to backtrack + body <- parser -- even if this is successfull + cnt <- getStates gtCounter + endSym <-testFollows token_gt + case endSym of + Just () -> do + token_gt + return body -- gtSym could make distinction between endOfSequence and GtSym + Nothing -> do -- last comparision expression was indeed end of sequence + setParserState st --backtrack + s <- parseWithGtLimit (cnt) parser + token_gt + return s +{- +parse an expression which contains as most count Greater-symbols (">" +used to leave the last ">" as end of sequence +attention: this can be nested !! +-} + +parseWithGtLimit :: Int -> PT a -> PT a +parseWithGtLimit maxGt parser = do + oldLimit <- getStates gtMode + updateState $ setGtMode $ GtLimit maxGt + res <- optionMaybe parser + updateState $ setGtMode oldLimit + case res of + Just p -> return p + Nothing -> fail "contents of sequence expression" + +proc_op_aparallel :: PT (LExp -> LExp -> PT LExp) +proc_op_aparallel = try $ do + s <- getNextPos + token T_openBrack + a1<-parseExp_noPrefix + token T_parallel + a2<-parseExp_noPrefix + token T_closeBrack + e<-getLastPos + return $ (\p1 p2 -> mkLabeledNode (mkSrcSpan s e ) $ ProcAParallel a1 a2 p1 p2 ) + +proc_op_lparallel :: PT (LExp -> LExp -> PT LExp) +proc_op_lparallel = try $ do + ren <- parseLinkList + p <- getPos + return $ (\p1 p2 -> mkLabeledNode p $ ProcLinkParallel ren p1 p2) + +procRenaming :: PT (LExp -> PT LExp) +procRenaming = do + rens <- many1 procOneRenaming + return $ (\x -> foldl (>>=) (return x) rens) + +procOneRenaming :: PT (LExp -> PT LExp ) +procOneRenaming = try $ do + s <- getNextPos + token T_openBrackBrack + ren<-(sepBy parseRename commaSeperator) + gens <- optionMaybe parseComprehension + token T_closeBrackBrack + e<-getLastPos + case gens of + Nothing -> return $ (\p1 -> mkLabeledNode (mkSrcSpan s e ) $ ProcRenaming ren p1) + Just g -> return $ (\p1 -> mkLabeledNode (mkSrcSpan s e ) $ ProcRenamingComprehension ren g p1 ) + +parseLinkList :: PT LLinkList +parseLinkList = withLoc $ do + token T_openBrack + linkList<-(sepBy parseLink commaSeperator) + gens <- optionMaybe parseComprehension + token T_closeBrack + case gens of + Nothing -> return $ LinkList linkList + Just g -> return $ LinkListComprehension g linkList + +parseLink :: PT LLink +parseLink= withLoc $ do + e1<-parseExp_noPrefix + token T_leftrightarrow + e2<-parseExp_noPrefix + return $ Link e1 e2 + +parseRename :: PT LRename +parseRename= withLoc $ do + e1<-parseExp_noPrefix + token T_leftarrow + e2<-parseExp_noPrefix + return $ Rename e1 e2 + + +-- here starts the parser for pattern +parsePatternNoDot :: PT LPattern +parsePatternNoDot = let ?innerDot = False in parsePatternAlso + +parsePattern :: PT LPattern +parsePattern = let ?innerDot = True in parsePatternAlso + +parsePatternAlso :: (?innerDot::Bool) => PT LPattern +parsePatternAlso = ( do + sPos <- getNextPos + concList <- sepBy1 parsePatternAppend $ token T_atat + ePos <- getLastPos + case concList of + [x] -> return x + l -> mkLabeledNode (mkSrcSpan sPos ePos) $ Also l + ) + "pattern" + +parsePatternAppend :: (?innerDot::Bool) => PT LPattern +parsePatternAppend = do + sPos <- getNextPos + concList <- sepBy1 parsePatternDot $ token T_hat + ePos <- getLastPos + case concList of + [x] -> return x + l -> mkLabeledNode (mkSrcSpan sPos ePos) $ Append l + +parsePatternDot :: (?innerDot::Bool) => PT LPattern +parsePatternDot = case ?innerDot of + False -> parsePatternCore + True -> do + s <- getNextPos + dList <- sepBy1 parsePatternCore $ token T_dot + e <- getLastPos + case dList of + [p] -> return p + l -> mkLabeledNode (mkSrcSpan s e) $ DotPat l + +parsePatternCore :: (?innerDot::Bool) => PT LPattern +parsePatternCore = + nestedPattern + <|> withLoc ( token T_true >> return TruePat) + <|> withLoc ( token T_false >> return FalsePat) + <|> litPat + <|> varPat + <|> tuplePatEnum + <|> listPatEnum + <|> singleSetPat + <|> emptySetPat + <|> withLoc ( token T_underscore >> return WildCard) + <|> blockBuiltIn + "pattern" + where + nestedPattern = try $ inParens parsePattern + + varPat :: (?innerDot :: Bool) => PT LPattern + varPat = inSpan VarPat ident + + singleSetPat :: (?innerDot :: Bool) => PT LPattern + singleSetPat = try $ inSpan SingleSetPat $ inBraces parsePattern + + emptySetPat :: (?innerDot :: Bool) => PT LPattern + emptySetPat = withLoc ( token T_openBrace >> token T_closeBrace >> return EmptySetPat ) + + listPatEnum :: (?innerDot :: Bool) => PT LPattern + listPatEnum = inSpan ListEnumPat $ between token_lt token_gt (sepByComma parsePattern) + + tuplePatEnum :: (?innerDot :: Bool) => PT LPattern + tuplePatEnum = inSpan TuplePat $ inParens (sepByComma parsePattern) + + +-- FixMe: do not use patBind to parse variable bindings ? + +patBind :: PT LDecl +patBind = withLoc $ do + pat <- parsePattern + token_is + exp <-parseExp + return $ PatBind pat exp + +-- parse all fundefs and merge consecutive case alternatives +funBind :: PT [LDecl] +funBind = do + flist <-many1 sfun + -- group functioncases by the name of the function + let flgr = groupBy + (\a b -> (unIdent $ unLabel $ fst $ a) == (unIdent $ unLabel $ fst b)) + flist + mapM mkFun flgr + where + mkFun :: [(LIdent,(FunArgs,LExp))] -> PT LDecl + mkFun l = do + let + fname = fst $ head l + pos = srcLoc fname + cases = map ((uncurry FunCase) . snd ) l + mkLabeledNode pos $ FunBind fname cases + +-- parse a single function-case +sfun :: PT (LIdent,(FunArgs,LExp)) +sfun = do + (fname,patl) <- try sfunHead + token_is "rhs of function clause" + exp <-parseExp + return (fname,(patl,exp)) + where + sfunHead = do + fname <- ident + patl <- parseFktCurryPat + return (fname,patl) + +{- +in CSP f(x)(y), f(x,y) , f((x,y)) are all different +we parse a function pattern as a list of curryargs (a)(b)( )( ).. +each of with can be a comma-seperated list of args that do not allow +currying in-between +i,e (a,b,c)(d,e,f) -> [[a,b,c][d,e,f]] +-} + +parseFktCurryPat :: PT [[LPattern]] +parseFktCurryPat = many1 parseFktCspPat + +parseFktCspPat :: PT [LPattern] +parseFktCspPat = inParens $ sepByComma parsePattern + +{- +5. nov 2007 remove try to give better error-messages +parseFktCspPat = + try $ between (cspSym "(") (cspSym ")") $ sepByComma parsePattern +todo: better error-messages for fun(card) (card is a buildin) +-} + +{- +parsePatL = withLoc $ between (cspSym "(") (cspSym ")") + $ sepBy parsePattern funArgumentSeperator +funArgumentSeperator = cspSym "," <|> (try (cspSym ")" >> cspSym "(")) +-} + +parseDeclList :: PT [LDecl] +parseDeclList = do + decl<- many1 parseDecl + return $ concat decl + + +singleList :: PT a -> PT [a] +singleList a = do + av <-a + return [av] + +{- +returns a list of decls +because funBind can't easily parse a single function +ToDo : PatBinds are actually different from varbind +example x={} with patbind will not be polymorphic +-} +parseDecl :: PT [LDecl] +parseDecl = + funBind + <|> singleList patBind + "declaration" + +topDeclList :: PT [LDecl] +topDeclList = do + decl<- many1 topDecl + return $ concat decl + where + + topDecl :: PT [LDecl] + topDecl = + funBind + <|> singleList patBind + <|> singleList parseAssert + <|> singleList parseTransparent + <|> singleList parseDatatype + <|> singleList parseSubtype + <|> singleList parseNametype + <|> singleList parseChannel + <|> singleList parsePrint + "top-level declaration" + + assertRef = withLoc $ do + token T_assert + p1<-parseExp + op<- token T_Refine {- ToDo: fix this -} + p2<-parseExp + return $ AssertRef p1 "k" p2 + + assertBool = withLoc $ do + token T_assert + b<-parseExp + return $ AssertBool b + + parseAssert :: PT LDecl + parseAssert = (try assertRef) <|> assertBool + + parseTransparent :: PT LDecl + parseTransparent = withLoc $ do + token T_transparent + l <- sepBy1Comma ident + return $ Transparent l + + parseSubtype :: PT LDecl + parseSubtype = withLoc $ do + token T_subtype + i <- ident + token_is + conList<-sepBy1 constrDef $ token T_mid + return $ SubType i conList + + parseDatatype :: PT LDecl + parseDatatype = withLoc $ do + token T_datatype + i <- ident + token_is + conList<-sepBy1 constrDef $ token T_mid + return $ DataType i conList + + constrDef :: PT LConstructor + constrDef = withLoc $ do + i <- ident + ty <- optionMaybe constrType + return $ Constructor i ty + + constrType = try ( token T_dot >> typeExp) + + parseNametype :: PT LDecl + parseNametype = withLoc $ do + token T_nametype + i <- ident + token_is + t<-typeExp + return $ NameType i t + + parseChannel :: PT LDecl + parseChannel = withLoc $ do + token T_channel + identl<-sepBy1Comma ident + t<-optionMaybe typeDef + return $ Channel identl t + + + typeDef = token T_colon >> typeExp + typeExp = typeTuple <|> typeDot + + typeTuple = inSpan TypeTuple $ inParens $ sepBy1Comma parseExp + + typeDot = inSpan TypeDot $ + sepBy1 parseExpBase $ token T_dot + + parsePrint :: PT LDecl + parsePrint = withLoc $ do + token T_print + e <- parseExp + return $ Print e + +procOpSharing :: PT (LProc -> LProc -> PT LProc) +procOpSharing = do + spos <- getNextPos + al <- between ( token T_openOxBrack) (token T_closeOxBrack) parseExp + epos <- getLastPos + return $ (\a b -> mkLabeledNode (mkSrcSpan spos epos) $ ProcSharing al a b) + +closureExp :: PT LExp +closureExp = inSpan Closure $ + between (token T_openPBrace ) (token T_closePBrace) + (sepBy1Comma parseExp ) + +{- Replicated Expressions in Prefix form -} + +parseProcReplicatedExp :: PT LProc +parseProcReplicatedExp = do + procRep T_semicolon ProcRepSequence + <|> procRep T_sqcap ProcRepInternalChoice + <|> procRep T_interleave ProcRepInterleave + <|> procRep T_box ProcRepChoice + <|> procRepAParallel + <|> procRepLinkParallel + <|> procRepSharing + <|> parsePrefixExp + <|> parseExpBase + "parseProcReplicatedExp" + where + -- todo : refactor all these to using inSpan + procRep :: TokenClasses.PrimToken -> (LCompGenList -> LProc -> Exp) -> PT LProc + procRep sym fkt = withLoc $ do + token sym + l<-comprehensionRep + body <- parseExp + return $ fkt l body + + procRepAParallel = withLoc $ do + token T_parallel + l<-comprehensionRep + token T_openBrack + alph <- parseExp + token T_closeBrack + body <- parseExp + return $ ProcRepAParallel l alph body + + procRepLinkParallel = withLoc $ do + link <- parseLinkList + gen <-comprehensionRep + body <- parseExp + return $ ProcRepLinkParallel gen link body + + procRepSharing = withLoc $ do + al <- between (token T_openOxBrack ) (token T_closeOxBrack) parseExp + gen <- comprehensionRep + body <- parseExp + return $ ProcRepSharing gen al body + +{- +parsePrefixExp is to be called without try +i.e. it must only commit after "->" + +prefix binds stronger than any operator (except dot-operator) +either another prefix or an expression without prefix +exp <-(parsePrefixExp <|> parseExpBase ) "rhs of prefix operation" + +-} +parsePrefixExp :: PT LExp +parsePrefixExp = withLoc $ do + (channel,comm) <- try parsePrefix + exp <- parseProcReplicatedExp "rhs of prefix operation" + return $ PrefixExp channel comm exp + where + parsePrefix :: PT (LExp,[LCommField]) + parsePrefix = do + channel <- try funCall <|> varExp --maybe permit even more + updateState $ setLastChannelDir WasOut + commfields <- many parseCommField + token T_rightarrow + return (channel,commfields) + + +{- +this is not what fdr really does +fdr parese ch?x.y:a as ch?((x.y):a) +-} +parseCommField :: PT LCommField +parseCommField = inComm <|> outComm <|> dotComm "communication field" + where + inComm = withLoc $ do + token T_questionmark + updateState$ setLastChannelDir WasIn + inCommCore + + inCommCore = do + pat<-parsePatternNoDot + guarD <- optionMaybe (token T_colon >> parseExp_noPrefix_NoDot) + case guarD of + Nothing -> return $ InComm pat + Just g -> return $ InCommGuarded pat g + + outComm = withLoc $ do + token T_exclamation + updateState $ setLastChannelDir WasOut + e <- parseExp_noPrefix_NoDot + return $ OutComm e + +-- repeat the direction of the last CommField + dotComm = withLoc $ do + token T_dot + lastDir <- getStates lastChannelDir + case lastDir of + WasOut -> do + com<-parseExp_noPrefix_NoDot + return $ OutComm com + WasIn -> inCommCore + + + + +{- +Helper routines for connecting the Token with the parser +and general Helper routines +The following is not related to CSPM-Syntax +-} + + +--maybe this is Combinator.lookAhead ? + +testFollows :: PT x -> PT (Maybe x) +testFollows p = do + oldState <- getParserState + res<-optionMaybe p + setParserState oldState + return res + +getStates :: (PState -> x) -> PT x +getStates sel = do + st <- getState + return $ sel st + + +primExUpdatePos :: SourcePos -> Token -> t -> SourcePos +primExUpdatePos pos t@(Token {}) _ + = newPos (sourceName pos) (-1) (Token.unTokenId $ Token.tokenId t) + +primExUpdateState :: t -> Token -> t1 -> PState -> PState +primExUpdateState _ tok _ st = st { lastTok =tok} + +{- +replicating existing combinators, just to work with our lexer +improve this +-} + +anyToken :: PT Token +anyToken = tokenPrimEx Token.showToken primExUpdatePos (Just primExUpdateState) Just + +notFollowedBy :: PT Token -> PT () +notFollowedBy p = try (do{ c <- p; unexpected $ Token.showToken c } + <|> return () + ) + +notFollowedBy' :: PT x -> PT () +notFollowedBy' p = try (do{ p; pzero } + <|> return () + ) + +eof :: PT () +eof = notFollowedBy anyToken "end of input" + +pprintParsecError :: ParsecError.ParseError -> String +pprintParsecError err + = ParsecError.showErrorMessages "or" "unknown parse error" + "expecting" "unexpected" "end of input" + (ParsecError.errorMessages err) + + +wrapParseError :: [Token] -> Either ParsecError.ParseError LModule -> Either ParseError LModule +wrapParseError _ (Right ast) = Right ast +wrapParseError tl (Left err) = Left $ ParseError { + parseErrorMsg = pprintParsecError err + ,parseErrorToken = errorTok + ,parseErrorPos = tokenStart errorTok + } + where + tokId = Token.mkTokenId $ sourceColumn $ ParsecError.errorPos err + errorTok = maybe Token.tokenSentinel id $ find (\t -> tokenId t == tokId) tl + + +token_is :: PT () +token_is = token T_is + +tokenPrimExDefault :: (Token -> Maybe a) -> GenParser Token PState a +tokenPrimExDefault = tokenPrimEx Token.showToken primExUpdatePos (Just primExUpdateState) diff --git a/src/Language/CSPM/PatternCompiler.hs b/src/Language/CSPM/PatternCompiler.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/PatternCompiler.hs @@ -0,0 +1,158 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.CSPM.PatternCompiler +-- Copyright : (c) Fontaine 2008 +-- License : BSD +-- +-- Maintainer : fontaine@cs.uni-duesseldorf.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- replace nested patterns with a set of linear Selectors +-- todo : benchmark if it pays off to introduce +-- helperbindings and only atomic bindings (unlikely) +-- todo : add testcases +{-# LANGUAGE ViewPatterns #-} + +module Language.CSPM.PatternCompiler + ( + compilePattern + ) +where + +import Language.CSPM.AST hiding (prologMode) +import qualified Language.CSPM.AST as AST + +import Control.Monad +import Data.Generics.Schemes (everywhere') +import Data.Generics.Aliases (mkT) +import Data.Array.IArray + +-- | replace all pattern in the module with list of linear Selectors +compilePattern :: LModule -> LModule +compilePattern ast + = Data.Generics.Schemes.everywhere' (Data.Generics.Aliases.mkT compPat) ast + where +-- pattern that consist only of a variable match remain unchanged + compPat :: LPattern -> LPattern + compPat x@(unLabel -> VarPat {}) = x + compPat pat = case cp id pat of + [(i,s)] -> setNode pat $ Selector s i + x -> setNode pat $ Selectors { +-- origPat = pat + selectors = listToArr $ map snd x + ,idents = listToArr $ map fst x + } + + listToArr :: [a] -> Array Int a + listToArr l = array (0,length l -1) $ zip [0..] l + + cp :: (Selector -> Selector ) -> LPattern -> [(Maybe LIdent,Selector)] + cp path pat = case unLabel pat of + IntPat i -> return (Nothing, path $ IntSel i) + TruePat -> return (Nothing, path TrueSel ) + FalsePat -> return (Nothing, path FalseSel ) + WildCard -> return (Nothing, path SelectThis ) + VarPat x -> return (Just x , path SelectThis ) + ConstrPat x -> return (Nothing, path $ ConstSel $ unUIdent $ unLabel x) +{- Also l -> -} + Append l -> do + let (prefix,suffix,variable) = analyzeAppendPattern l + msum [ concatMap (mkListPrefixPat path) prefix + , mkListVariablePat path variable + , concatMap (mkListSuffixPat path) suffix ] +{- | DotPat [LPattern] -} + SingleSetPat p -> cp (path . SingleSetSel) p + EmptySetPat -> return (Nothing, path EmptySetSel) + ListEnumPat [] -> return (Nothing, path $ ListLengthSel 0 $ SelectThis ) + ListEnumPat l -> do + let len = length l + msum $ map + (\(x,i) -> cp (path . ListLengthSel len . ListIthSel i) x) + (zip l [0..]) + TuplePat [] -> return (Nothing, path $ TupleLengthSel 0 $ SelectThis ) + TuplePat l -> do + let len = length l + msum $ map + (\(x,i) -> cp (path . TupleLengthSel len . TupleIthSel i) x) + (zip l [0..]) + Selector {} -> error "PatternCompiler.hs : didn't expect Selector" + Selectors {} -> error "PatternCompiler.hs : didn't expect Selectors" + + mkListPrefixPat + :: (Selector -> Selector ) + -> (Offset,Len,LPattern) + -> [(Maybe LIdent,Selector)] + mkListPrefixPat path l = case l of + (0,1,pat) -> let (unLabel -> ListEnumPat [r]) = pat + in cp (path . HeadSel) r + (0,n,pat) -> cp (path . HeadNSel n) pat + (o,s,pat) -> cp (path . PrefixSel o s) pat + + mkListSuffixPat + :: (Selector -> Selector ) + -> (Offset,Len,LPattern) + -> [(Maybe LIdent,Selector)] + mkListSuffixPat path (o,l,pat) + = cp (path . SuffixSel o l) pat + + mkListVariablePat + :: (Selector -> Selector ) + -> Maybe (Offset,Offset,LPattern) + -> [(Maybe LIdent,Selector)] + mkListVariablePat _path Nothing = [] + mkListVariablePat path (Just (l,r,pat)) = cp (path . SliceSel l r) pat + +type Offset = Int +type Len = Int +analyzeAppendPattern :: + [LPattern] -> + ([(Offset,Len,LPattern)] -- prefixpattern + ,[(Offset,Len,LPattern)] -- suffixpattern + ,Maybe (Offset,Offset,LPattern) + ) +analyzeAppendPattern pl + = let + taggedPatList = zip pl $ map lengthOfListPattern pl + prefixPat = computePrefixPattern taggedPatList + suffixPat = computeSuffixPattern taggedPatList + lenPrefix = sum $ map (\(_,l,_)-> l) prefixPat + lenSuffix = sum $ map (\(_,l,_)-> l) suffixPat + varPat = case filter (\(_,len) -> len == Nothing) taggedPatList of + [] -> Nothing + [(pat,_)] -> Just (lenPrefix,lenSuffix,pat) + l -> error $ "PatternCompiler.hs : alsopattern contains multiple " + ++ "variable length pattern " + ++ show l + in + (prefixPat,suffixPat,varPat) + where +{- compute the length of a list pattern + Just Int -> fixed length pattern + Nothing -> variable length pattern -} + + lengthOfListPattern :: LPattern -> Maybe Len + lengthOfListPattern p = case unLabel p of + ListEnumPat l -> return $ length l + Append patl -> do + l <- mapM lengthOfListPattern patl + return $ sum l + VarPat _ -> Nothing + Also patl -> do + let l = map lengthOfListPattern patl + error "PatternCompiler.hs: lengthOfListPat : alsopattern: todo" + _ -> error $ "PatternCompiler.hs: lengthOfListPat : no list pattern " + ++ show p +{- +PrefixPattern are fixed-length pattern with a fixed offset from the front +return when the first variable length pattern occurs +-} + computePrefixPattern :: [(LPattern,Maybe Len)] -> [(Offset,Len,LPattern)] + computePrefixPattern l = worker 0 l where + worker _ [] = [] + worker _ ((_ ,Nothing ) : _) = [] + worker offset ((pat,Just len): rest) + = (offset,len,pat) : worker (offset+len) rest + + computeSuffixPattern :: [(LPattern,Maybe Len)] -> [(Offset,Len,LPattern)] + computeSuffixPattern = computePrefixPattern . reverse diff --git a/src/Language/CSPM/PrettyPrinter.hs b/src/Language/CSPM/PrettyPrinter.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/PrettyPrinter.hs @@ -0,0 +1,265 @@ + +{-# LANGUAGE TypeSynonymInstances #-} + +{-# OPTIONS_GHC + -XTypeSynonymInstances + -XScopedTypeVariables #-} + + + + +---------------------------------------------------------------------------- +-- | +-- Module : Language.CSPM.PrettyPrinter +-- Copyright : (c) Dobrikov 2008 +-- License : BSD +-- +-- Maintainer : me@dobrikov.biz +-- Stability : experimental +-- Portability : GHC-only +-- +module Language.CSPM.PrettyPrinter +where + +import Text.PrettyPrint as PrettyPrint hiding (char) +import qualified Text.PrettyPrint as PrettyPrint +import Language.CSPM.AST +import Language.CSPM.Utils + +import Data.Maybe + + +class PP x where pp :: x-> Doc + +mapPP :: PP x => [x] -> [Doc] +mapPP = map pp + +instance (PP x) => PP (Labeled x) where + pp = pp . unLabel + +instance PP Ident where pp = text . unIdent + +instance PP Exp where pp = prettyExp + +prettyExp :: Exp -> Doc +prettyExp x = case x of + Var x -> pp x + IntExp x -> integer x + SetEnum x -> braces $ hcatCommaSpace x -- (vcat $ punctuate (comma <+> empty) $ map pp x) -- <> rbrace + ListEnum x -> text "<" <> (hcat $ punctuate (comma <+> empty) $ map pp x) <> text ">" + SetOpen x -> braces (pp x <> text "..") + ListOpen x -> text "<" <> pp x <> text ".." <> text ">" + SetComprehension (x{-[LExp]-},l{-[LCompGen]-}) + -> braces ((hcat $ punctuate (comma) $ map pp x) <+> text "|" <+> (hcat $ punctuate (comma) $ map pp l)) + ListComprehension (x,l) + -> text "<" <+> (hcat $ punctuate comma $ map pp x) <+> text "|" <+> (hcat $ punctuate (comma) $ map pp l) <+> text ">" + ClosureComprehension (x,l) -> text "{|" <+> (hcat $ punctuate comma $ map pp x) <+> text "|" <+> (hcat $ punctuate comma $ map pp l) <+> text "|}" + SetClose (x,y) -> braces (pp x <> text ".." <> pp y) + ListClose (x,y) -> text "<" <> pp x <> text ".." <> pp y <> text ">" + Parens x -> parens (pp x) + BoolSet -> text "Bool" + IntSet -> text "Int" + Events -> text "Events" + Stop -> text "STOP" + Skip -> text "SKIP" + CTrue -> text "true" + CFalse -> text "false" + TupleExp xlist -> parens (hcat $ punctuate comma (map pp xlist)) + DotTuple x -> hcat $ punctuate (text ".") $ map pp x + Closure x -> text "{|" <+> (hcat $ punctuate (comma <+> empty) $ map pp x) <+> text "|}" + CallBuiltIn x [list] -> pp x <> parens (hcat $ punctuate comma $ map pp list) + Ifte x y z -> text "if" <+> pp x <+> text "then" $$ pp y $$ text "else" <+> pp z + AndExp x y -> pp x <+> text "and" <+> pp y + OrExp x y -> pp x <+> text "or" <+> pp y + NotExp x -> text "not" <+> pp x + Fun1 x y -> pp x <> pp y + Fun2 fun x y -> pp x <+> pp fun <+> pp y + Lambda patt x -> text "\\" <+> (hcat $ punctuate (comma <+> empty) $ map pp patt) <+> text "@" <+> pp x + PrefixExp x l_comm_field y -> pp x <> (hcat $ map pp l_comm_field) <+> text "->" <+> pp y + ProcSharing x_middle x_left x_right -> pp x_left <+> text "[|" <+> pp x_middle <+> text "|]" <> pp x_right + Let decl x -> text "let" $$ (vcat $ map pp decl) $$ text "within" <+> pp x +-- TODO CallFunction: produce not the correct output in file: protocol.fix.csp + CallFunction x [list] -> pp x <> parens (hcat $ punctuate (comma <+> empty) $ map pp list) + ProcLinkParallel list x y -> pp x <+> pp list <+> pp y + ProcAParallel x1 x2 x3 x4 -> pp x3 <+> brackets (pp x1 <+> text "||" <+> pp x2) <+> pp x4 +-- ProcRepInterleave (Labeled _ list _ :: (Labeled [LCompGen])) proc -> text "|||" <+> (hcat $ punctuate (space <> colon <> space) $ map pp list) <+> text "@" <+> pp proc +-- ProcRepChoice (Labeled _ list _ :: (Labeled [LCompGen])) proc -> text "[]" <+> (hcat $ punctuate (space <> colon <> space) $ map pp list) <+> text "@" <+> pp proc +-- pp (ProcRepSharing list x x_proc) = pp x <> text "[|" <> comp_gen_list list <> text "|]" <> pp x_proc -- nicht in die Beispiele vorhanden + ProcRenaming rlist proc -> pp proc <+> text "[[" <+> (hsep $ punctuate (space <> comma <> space) $ map pp rlist) <+> text "]]" + ProcRenamingComprehension rlist lcomp proc + -> pp proc <+> text "[[" <+> (hsep $ punctuate (space <> comma <> space) $ map pp rlist) <+> text "|" <+> (hsep $ punctuate (space <> comma <> space) $ map pp lcomp) <+> text "]]" +-- ProcRepAParallel (Labeled _ list _ :: (Labeled [LCompGen])) alph body +-- -> text "||" <+> (hsep $ punctuate (space <> comma <> space) $ map pp list) <+> text "@" <+> brackets (pp alph) <+> pp body +-- pp (ProcRepSharing (Labeled s list v) x proc) = +-- ProcRepInternalChoice (Labeled _ list _ :: (Labeled [LCompGen])) proc +-- -> text "|~|" <+> (hsep $ punctuate (space <> comma <> space) $ map pp list) <+> text "@" <+> pp proc + where + hcatComma :: PP x => [x] -> Doc + hcatComma a = hcat $ punctuate comma $ mapPP a + +-- Ivo ? what is the difference between comma and (comma <+> empty) ? + hcatCommaSpace :: PP x => [x] -> Doc + hcatCommaSpace a = hcat $ punctuate (comma <+> empty) $ mapPP a + + +instance PP Rename where + pp (Rename x y) = pp x <> text "<-" <> pp y + +instance PP CompGen where + pp (Generator patt x) = pp patt <> {-text "<-"-}colon <> pp x + pp (Guard x) = space <> pp x + +comp_gen_list :: [LCompGen] -> Doc +comp_gen_list l = hcat $ punctuate empty (map pp l) + + +instance PP BuiltIn where + pp (BuiltIn const) = pp const + +--type LCompGenList = Labeled [LCompGen] + +--instance PP LCompGenList => (Labeled [LCompGen]) where +-- pp list = list . unLabel + +instance PP Decl where + pp (PatBind x y) = pp x <+> equals <+> pp y + pp (DataType ident list_constr) = text "datatype" <+> pp ident <+> equals <+> (hcat $ punctuate (space <> text "|" <> space) $ map pp list_constr) + pp (AssertRef x s y) = text "assert" <+> pp x <+> ptext s <+> pp y + pp (AssertBool x) = text "assert" <+> pp x <+> text ":[livelock free]" + pp (Channel list_x ty_ref) = text "channel" <+> (hcat $ punctuate (comma <> space) $ map pp list_x) <> if isEmpty (pp ty_ref) + then empty + else space <> colon <> space <> pp ty_ref + pp (FunBind ident list) = {-pp ident {-<> text "("-} <>-} (vcat $ punctuate empty $ map (pp ident <>) (map pp list)) --TODO + pp (SubType ident list_constr) = text "subtype" <+> pp ident <+> equals <+> (hcat $ punctuate (space <> text "|" <> space) $ map pp list_constr) + pp (NameType ident ty_ref) = text "nametype" <+> pp ident <+> equals <+> pp ty_ref + pp (Transparent list) = text "transparent" <+> (hcat $ punctuate (comma <> space) $ map pp list) + pp (Print x) = text "print" <+> pp x + +instance PP Module where + pp m= vcat $ map pp (moduleDecls m) + +instance PP FunCase where + pp (FunCase [l_fun_args] x) = text "(" <> (hcat $ punctuate (comma <+> empty) $ map pp l_fun_args ) <> text ")" <+> equals <+> pp x + +instance PP LinkList where + pp (LinkList list_link) = brackets (hcat $ punctuate (comma <+> empty) $ map pp list_link) + +instance PP Link where + pp (Link x y) = pp x <> text "<->" <> pp y + +instance PP Constructor where + pp (Constructor ident ty_ref) = pp ident <> if isEmpty (pp ty_ref) + then empty + else {-text "." <>-} pp ty_ref + +instance (PP x) => PP (Maybe x) where + pp (Just x) = pp x + pp Nothing = empty + +--instance PP Funcase where -- siehe emptySet +-- pp (Funcase [[arg]] x) = text "(" <> <> text ")" <+> equals <+> pp x + +instance PP TypeDef where + pp (TypeTuple x) = text "." <> parens (hcat $ punctuate comma $ map pp x) + pp (TypeDot x) = (hcat $ punctuate (text ".") $ map pp x) + +instance PP Pattern where + pp (IntPat x) = integer x + pp (VarPat x) = pp x + pp EmptySetPat = braces empty + pp WildCard = text "_" + pp (SingleSetPat patt) = brackets (pp patt) + pp (ListEnumPat list) = text "<" <> (hcat $ (punctuate (comma) $ map pp list)) <> text ">" + pp (TuplePat list) = parens (hcat $ (punctuate (comma) $ map pp list)) + pp (DotPat list) = hcat $ punctuate (text ".") $ map pp list + +instance PP CommField where + pp (InComm x) = space <> text "?" <+> pp x + pp (OutComm x) = empty <> text "."{-"!"-} <> pp x + pp (InCommGuarded pattern x {-LPattern LExp-}) = space <> text "?" <+> pp pattern <+> colon <+> pp x + +instance PP Const where + pp F_true = text "true" + pp F_false = text "false" + pp F_not = text "not" + pp F_and = text "and" + pp F_or = text "or" + pp F_STOP = text "STOP" + pp F_SKIP = text "SKIP" + pp F_Mult = text "*" + pp F_Div = colon + pp F_Add = text "+" + pp F_Sub = text "-" + pp F_Eq = text "==" + pp F_NEq = text "!=" + pp F_ExtChoice = text "[]" + pp F_Union = text "Union" + pp F_concat = text "concat" + pp F_Concat = text "^" + pp F_union = text "union" + pp F_inter = text "inter" + pp F_diff = text "diff" + pp F_Inter = text "Inter" + pp F_member = text "member" + pp F_card = text "card" + pp F_empty = text "empty" + pp F_set = text "set" + pp F_Set = text "Set" + pp F_null = text "null" + pp F_Seq = text "Seq" + pp F_head = text "head" + pp F_tail = text "tail" + pp F_elem = text "elem" + pp F_Events = text "Events" + pp F_Int = text "Int" + pp F_Bool = text "Bool" + pp F_GE = text ">=" + pp F_LE = text "<=" + pp F_LT = text "<" + pp F_GT = text ">" + pp F_Sequential = text "Sequential" + pp F_Guard = text "&" + pp F_Interrupt = text "/\\" + pp F_Len2 = text "#" + pp F_CHAOS = text "CHAOS" + pp F_Timeout = text "[>" + pp F_IntChoice = text "|~|" + pp F_Interleave = text "|||" + pp F_Hiding = text "\\" + pp F_length = text "length" + pp F_Mod = text "%" + +to_PString :: LModule -> String +to_PString my_mod = render (pp my_mod) + + +runPretty :: FilePath -> IO String +runPretty fname = + do + my_mod <- parseFile fname + return (to_PString my_mod) --(render (pp mod)) + +compareTrees :: FilePath -> IO Bool +compareTrees file = + do + parsedFile <- parseFile file + let prettyFile = to_PString parsedFile + writeFile (file ++ ".pp") prettyFile + secondPFile <- parseFile file + if (parsedFile == secondPFile) + then + return True + else + return False + +simpleCompare :: FilePath -> FilePath -> IO Bool +simpleCompare file1 file2 = + do + tree1 <- readFile file1 + tree2 <- readFile file2 + if (tree1 == tree2) + then + return True + else + return False + diff --git a/src/Language/CSPM/Rename.hs b/src/Language/CSPM/Rename.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/Rename.hs @@ -0,0 +1,446 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.CSPM.Rename +-- Copyright : (c) Fontaine 2008 +-- License : BSD +-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Compute the mapping between the using occurences and the defining occurences of all Identifier in a Module +-- Also decide whether to use ground or non-ground- representaions for the translation to Prolog. +{- +todo : check that we do not bind variables when we pattern match against +constructors : add a testcase for that +todo :: maybe use SYB for gathering the renaming +todo :: maybe also compute debruin-index/ freevariables +todo :: check idType in useIdent +fix topleveldecls to toplevel ? -> allready done by parser +-} +module Language.CSPM.Rename + ( + getRenaming + ,applyRenaming + ,RenameError(..) + ) +where + +import Language.CSPM.AST hiding (prologMode,bindType) +import qualified Language.CSPM.AST as AST +import qualified Language.CSPM.SrcLoc as SrcLoc + +import Data.Generics.Schemes (everywhere) +import Data.Generics.Aliases (mkT) +import Data.Typeable (Typeable) +import Control.Exception (Exception) + +import Control.Monad.Error +import Control.Monad.State +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap + +-- | 'getRenaming' computes two 'AstAnnotation's. +-- The first one contains all the defining occurences of identifier +-- The second one contains all the using occurences of identitier. +-- 'getRename' returns an 'RenameError' if the 'Module' contains unbound +-- identifiers or illegal redefinitions. +getRenaming :: + LModule + -> Either RenameError (Bindings,AstAnnotation UniqueIdent,AstAnnotation UniqueIdent) +getRenaming m + = case execStateT (rnModule m) initialRState of + Right state -> Right (visible state,identDefinition state, identUse state) + Left e -> Left e + +type RM x = StateT RState (Either RenameError) x + +type UniqueName = Int + +data RState = RState + { + nameSupply :: UniqueName +-- used to check that we do not bind a name twice inside a pattern + ,localBindings :: Bindings + ,visible :: Bindings -- everything that is visible + ,identDefinition :: AstAnnotation UniqueIdent + ,identUse :: AstAnnotation UniqueIdent + ,usedNames :: Set String + ,prologMode :: PrologMode + ,bindType :: BindType + } deriving Show + +initialRState :: RState +initialRState = RState + { + nameSupply = 0 + ,localBindings = Map.empty + ,visible = Map.empty + ,identDefinition = IntMap.empty + ,identUse = IntMap.empty + ,usedNames = Set.empty + ,prologMode = PrologVariable + ,bindType = NotLetBound + } + +data RenameError + = RenameError { + renameErrorMsg :: String + ,renameErrorLoc :: SrcLoc.SrcLoc + } deriving (Show,Typeable) + +instance Exception RenameError + + +instance Error RenameError where + noMsg = RenameError { renameErrorMsg = "no Messsage", renameErrorLoc = SrcLoc.NoLocation } + strMsg m = RenameError { renameErrorMsg = m, renameErrorLoc = SrcLoc.NoLocation } + +bindNewTopIdent :: IDType -> LIdent -> RM () +bindNewTopIdent t i = do + let (Ident origName) = unLabel i + vis <- gets visible + case Map.lookup origName vis of + Nothing -> bindNewUniqueIdent t i + Just _ -> throwError $ RenameError { + renameErrorMsg = "Redefinition of toplevel name " ++ origName + ,renameErrorLoc = srcLoc i } + +bindNewUniqueIdent :: IDType -> LIdent -> RM () +bindNewUniqueIdent iType lIdent = do + let (Ident origName) = unLabel lIdent + local <- gets localBindings + {- check that we do not bind a variable twice i.e. in a pattern -} + case Map.lookup origName local of + Nothing -> return () + Just _ -> throwError $ RenameError { + renameErrorMsg = "Redefinition of " ++ origName + ,renameErrorLoc = srcLoc lIdent } +{- + If we have a Constructor in scope and try to bind + a VarID then we actually have a Constructor-Pattern. + Same situation for a channelIDs. + We throw an error if the csp-code tries to reuse a constructor + or a channel for i.e. a function. +-} + vis <- gets visible + case (Map.lookup origName vis,iType) of + (Just x ,VarID) -> case idType x of + ConstrID _ -> useExistingBinding x + ChannelID -> useExistingBinding x + _ -> addNewBinding + (Just x , _) -> case idType x of + ConstrID _-> throwError $ RenameError { + renameErrorMsg = "Illigal reuse of Contructor " ++ origName + ,renameErrorLoc = srcLoc lIdent } + ChannelID -> throwError $ RenameError { + renameErrorMsg = "Illigal reuse of Channel " ++ origName + ,renameErrorLoc = srcLoc lIdent } + _ -> addNewBinding + (_, _ ) -> addNewBinding + where + useExistingBinding :: UniqueIdent -> RM () + useExistingBinding constr = do + let ptr = unNodeId $ nodeId $ lIdent + modify $ \s -> s + { identDefinition = IntMap.insert ptr constr (identDefinition s) } + + addNewBinding :: RM () + addNewBinding = do + let (Ident origName) = unLabel lIdent + nodeID = nodeId lIdent + + (nameNew,unique) <- nextUniqueName origName + plMode <- gets prologMode + bType <- gets bindType + let uIdent = UniqueIdent { + uniqueIdentId = unique + ,bindingSide = nodeID + ,bindingLoc = srcLoc lIdent + ,idType = iType + ,realName = origName + ,newName = nameNew + ,AST.prologMode = plMode + ,AST.bindType = bType } + modify $ \s -> s + { localBindings = Map.insert origName uIdent $ localBindings s + , visible = Map.insert origName uIdent $ visible s } + modify $ \s -> s + { identDefinition = IntMap.insert + (unNodeId nodeID) uIdent $ identDefinition s } + return () + + nextUniqueName :: String -> RM (String,UniqueName) + nextUniqueName oldName = do + n <- gets nameSupply + modify $ \s -> s {nameSupply = succ n} + occupied <- gets usedNames + let + suffixes = "" : map show ([2..9] ++ [n + 10 .. ]) + candidates = map ((++) oldName) suffixes + nextName = head $ filter (\x -> not $ Set.member x occupied) candidates + modify $ \s -> s {usedNames = Set.insert nextName $ usedNames s} + return (nextName,n) + +localScope :: RM x -> RM x +localScope h = do + vis <- gets visible + localBind <- gets localBindings + modify $ \s -> s {localBindings = Map.empty} + res <- h + modify $ \e -> e { + visible = vis + ,localBindings = localBind } + return res + + +{- +rn just walks through the AST, without modifing it. +The actual renamings are stored in a sepearte AstAnnotation inside the RM-Monad +-} + + + +nop :: RM () +nop = return () + +rnModule :: LModule -> RM () +rnModule m = rnDeclList $ moduleDecls $ unLabel m + +rnExpList :: [LExp] -> RM () +rnExpList = mapM_ rnExp + +-- rename an expression +rnExp :: LExp -> RM () +rnExp expression = case unLabel expression of + Var ident -> useIdent Nothing ident + IntExp _ -> nop + SetEnum a -> rnExpList a + ListEnum a -> rnExpList a + SetOpen a -> rnExp a + ListOpen a -> rnExp a + SetClose (a,b) -> rnExp a >> rnExp b + ListClose (a,b) -> rnExp a >> rnExp b + SetComprehension (a,b) -> inCompGen b (rnExpList a) + ListComprehension (a,b) -> inCompGen b (rnExpList a) + ClosureComprehension (a,b) -> inCompGen b (rnExpList a) + Let decls e -> localScope (rnDeclList decls >> rnExp e) + Ifte a b c -> rnExp a >> rnExp b >> rnExp c + CallFunction a args -> rnExp a >> mapM_ rnExpList args + CallBuiltIn _ args -> mapM_ rnExpList args + Lambda pList e -> localScope (rnPatList pList >> rnExp e) + Stop -> nop + Skip -> nop + CTrue -> nop + CFalse -> nop + Events -> nop + BoolSet -> nop + IntSet -> nop + TupleExp l -> rnExpList l + Parens a -> rnExp a + AndExp a b -> rnExp a >> rnExp b + OrExp a b -> rnExp a >> rnExp b + NotExp a -> rnExp a + NegExp a -> rnExp a + Fun1 _ a -> rnExp a + Fun2 _ a b -> rnExp a >> rnExp b + DotTuple l -> rnExpList l + Closure l -> rnExpList l + ProcSharing al p1 p2 -> rnExp al >> rnExp p1 >> rnExp p2 + ProcAParallel a b c d -> rnExp a >> rnExp b >> rnExp c >> rnExp d + ProcLinkParallel l e1 e2 -> rnLinkList l >> rnExp e1 >> rnExp e2 + ProcRenaming rlist e -> mapM_ reRename rlist >> rnExp e +{- scopingrules for LCompGen as found in FDR -} + ProcRenamingComprehension re comp proc + -> inCompGen comp (mapM_ reRename re) >> rnExp proc + ProcRepSequence a p -> inCompGenL a (rnExp p) + ProcRepInternalChoice a p -> inCompGenL a (rnExp p) + ProcRepInterleave a p -> inCompGenL a (rnExp p) + ProcRepChoice a p -> inCompGenL a (rnExp p) + ProcRepAParallel comp a p -> inCompGenL comp (rnExp a >> rnExp p) + ProcRepLinkParallel comp l p + -> rnLinkList l >> inCompGenL comp (rnExp p) + ProcRepSharing comp s p -> rnExp s >> inCompGenL comp (rnExp p) + PrefixExp chan fields proc -> localScope $ do + rnExp chan + mapM_ rnCommField fields + rnExp proc +{- to make the match total : (these may only appear in later stages) -} + ExprWithFreeNames {} -> error "Rename.hs : no match for ExprWithFreeNames" + LambdaI {} -> error "Rename.hs : no match for LambdaI" + PrefixChan {} -> error "Rename.hs : no match for PrefixChan" + LetI {} -> error "Rename.hs : no match for LetI" + + where + {- + called from VarExp + we can bind lIdent to any Identifier that is in scope + (ConstID,FunID ..) + -} + +useIdent :: (Maybe IDType) -> LIdent -> RM () +useIdent expectedType lIdent = do + let (Ident origName) = unLabel lIdent + nodeID = nodeId lIdent + vis <- gets visible + case Map.lookup origName vis of + Nothing -> throwError $ RenameError { + renameErrorMsg = "Unbound Identifier :" ++ origName + ,renameErrorLoc = srcLoc lIdent } + Just uniqueIdent -> do -- todo check idType + case expectedType of + Nothing -> return () + Just t -> when (t /= idType uniqueIdent) $ do + throwError $ RenameError { + renameErrorMsg = "Typeerror :" ++ origName + ,renameErrorLoc = srcLoc lIdent } + modify $ \s -> s + { identUse = IntMap.insert + (unNodeId nodeID) uniqueIdent $ identUse s } + return () + + +rnPatList :: [LPattern] -> RM () +rnPatList = mapM_ rnPattern + +rnPattern :: LPattern -> RM () +rnPattern p = case unLabel p of + IntPat _ -> nop + TruePat -> nop + FalsePat -> nop + WildCard -> nop + VarPat lIdent -> bindNewUniqueIdent VarID lIdent + Also l -> rnPatList l + Append l -> rnPatList l + DotPat l -> rnPatList l + SingleSetPat a -> rnPattern a + EmptySetPat -> nop + ListEnumPat l -> rnPatList l + TuplePat l -> rnPatList l + +rnCommField :: LCommField -> RM () +rnCommField f = case unLabel f of + InComm pat -> rnPattern pat + InCommGuarded p g -> rnPattern p >> rnExp g + OutComm e -> rnExp e + +inCompGenL :: LCompGenList -> RM () -> RM () +inCompGenL l r = inCompGen (unLabel l) r + +inCompGen :: [LCompGen] -> RM () -> RM () +inCompGen (h:t) ret = localScope $ do + rnCompGen h + inCompGen t ret +inCompGen [] ret = ret + +rnCompGen :: LCompGen -> RM () +rnCompGen g = case unLabel g of + Generator pat e -> rnExp e >> rnPattern pat + Guard e -> rnExp e + +reRename :: LRename -> RM () +reRename = r2 . unLabel + where r2 (Rename e1 e2) = rnExp e1 >> rnExp e2 + +rnLinkList :: LLinkList -> RM () +rnLinkList = rnLink2 . unLabel + where + rnLink2 (LinkList l) = mapM_ rnLink l + rnLink2 (LinkListComprehension a b) = inCompGen a (mapM_ rnLink b) + + rnLink = (\(Link a b) ->rnExp a >> rnExp b) . unLabel + + +-- rename a recursive binding group +rnDeclList :: [LDecl] -> RM () +rnDeclList declList = do + modify $ \s -> s {prologMode = PrologGround + ,bindType = LetBound} + forM_ declList declLHS + modify $ \s -> s {prologMode = PrologVariable + ,bindType = NotLetBound} + forM_ declList declRHS + +declLHS :: LDecl -> RM () +declLHS d = case unLabel d of + PatBind pat _ -> rnPattern pat + --todo : proper type-checking/counting number of Funargs + FunBind i _ -> bindNewUniqueIdent (FunID (-1)) i + AssertRef {} -> nop + AssertBool {} -> nop + Transparent tl -> mapM_ (bindNewTopIdent TransparentID) tl + SubType i clist -> do + bindNewTopIdent DataTypeID i -- fix this + mapM_ rnSubtypeLHS clist + DataType i clist -> do + bindNewTopIdent DataTypeID i + mapM_ rnConstructorLHS clist + NameType i _ -> bindNewTopIdent NameTypeID i + Channel chList _ -> mapM_ (bindNewTopIdent ChannelID) chList + Print _ -> nop + where + rnConstructorLHS :: LConstructor -> RM () + rnConstructorLHS a = do + let (Constructor c _ ) = unLabel a + bindNewTopIdent (ConstrID "someConstructor") c --Todo -- fix + + rnSubtypeLHS :: LConstructor -> RM () + rnSubtypeLHS a = do + let (Constructor c _ ) = unLabel a + useIdent Nothing c -- <- fix this Nothing <-> dont check + +declRHS :: LDecl -> RM () +declRHS d = case unLabel d of + PatBind _ e -> rnExp e + FunBind _ cases -> mapM_ rnFunCase cases + AssertRef a _ b -> rnExp a >> rnExp b + AssertBool e -> rnExp e + Transparent _ -> nop + SubType _ clist -> forM_ clist rnConstructorRHS + DataType _ clist -> forM_ clist rnConstructorRHS + NameType _ td -> rnTypeDef td + Channel _ Nothing -> nop + Channel _ (Just td) -> rnTypeDef td + Print e -> rnExp e + where + rnFunCase c = case c of --todo:uses Labeled version + (FunCase pat e) -> localScope (mapM_ rnPatList pat >> rnExp e) + rnConstructorRHS :: LConstructor -> RM () + rnConstructorRHS = rc . unLabel where + rc (Constructor _ Nothing ) = nop + rc (Constructor _ (Just t)) = rnTypeDef t + + +rnTypeDef :: LTypeDef -> RM () +rnTypeDef t = case unLabel t of + TypeTuple l -> rnExpList l + TypeDot l -> rnExpList l + +-- | 'applyRenaming' uses SYB to replace turn every 'Ident' in the 'Module' into to the +-- 'UIdent' version, i.e. set the 'UniqueIdent'. +-- At the same time, we also replace VarPat x with ConstrPat x if x an toplevel constant +-- It is an error if the 'Module' contains occurences of 'Ident' that are not covered by +-- the 'AstAnnotation's. +applyRenaming :: + (Bindings,AstAnnotation UniqueIdent,AstAnnotation UniqueIdent) + -> LModule + -> LModule +applyRenaming (_,defIdent,usedIdent) ast + = everywhere (mkT patchVarPat . mkT patchIdent) ast + where + patchIdent :: LIdent -> LIdent + patchIdent l = + let nodeID = unNodeId $ nodeId l in + case IntMap.lookup nodeID usedIdent of + Just u -> l { unLabel = UIdent u} + Nothing -> case IntMap.lookup nodeID defIdent of + Just d -> l { unLabel = UIdent d} + Nothing -> error $ "internal error: patchIdent nodeId :" ++ show nodeID + + patchVarPat :: Pattern -> Pattern + patchVarPat p@(VarPat x) = case idType $ unUIdent $ unLabel x of + VarID -> p + _ -> ConstrPat x + patchVarPat x = x diff --git a/src/Language/CSPM/SrcLoc.hs b/src/Language/CSPM/SrcLoc.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/SrcLoc.hs @@ -0,0 +1,148 @@ +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Language.CSPM.SrcLoc +-- Copyright : (c) Fontaine 2008 +-- License : BSD +-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de +-- Stability : provisional +-- Portability : GHC-only +-- +-- This module contains the datatype for sourcelocations and some utility functions. + +module Language.CSPM.SrcLoc +where + +import Language.CSPM.Token as Token + +import Data.List +import Data.Typeable (Typeable) +import Data.Generics.Basics (Data) +import Data.Generics.Instances () + +{- todo : simplify this -} +data SrcLoc + = TokIdPos TokenId + | TokIdSpan TokenId TokenId + | TokSpan Token Token -- the spans are closed intervals + -- single token with token x :: TokSpan x x + | TokPos Token + | NoLocation + | FixedLoc { + fixedStartLine :: !Int + ,fixedStartCol :: !Int + ,fixedStartOffset :: !Int + ,fixedLen :: !Int + ,fixedEndLine :: !Int + ,fixedEndCol :: !Int + ,fixedEndOffset :: !Int + } + deriving (Show,Eq,Ord,Typeable, Data) + +mkTokSpan :: Token -> Token -> SrcLoc +mkTokSpan = TokSpan + +mkTokPos :: Token -> SrcLoc +mkTokPos = TokPos + +type SrcLine = Int +type SrcCol = Int +type SrcOffset = Int + +getStartLine :: SrcLoc -> SrcLine +getStartLine x = case x of + TokSpan s _e -> alexLine $ tokenStart s + TokPos t -> alexLine $ tokenStart t + FixedLoc {} -> fixedStartLine x + _ -> error "no SrcLine Availabel" + +getStartCol :: SrcLoc -> SrcCol +getStartCol x = case x of + TokSpan s _e -> alexCol $ tokenStart s + TokPos t -> alexCol $ tokenStart t + FixedLoc {} -> fixedStartCol x + _ -> error "no SrcCol Availabel" + +getStartOffset :: SrcLoc -> SrcOffset +getStartOffset x = case x of + TokSpan s _e -> alexPos $ tokenStart s + TokPos t -> alexPos $ tokenStart t + FixedLoc {} -> fixedStartOffset x + _ -> error "no SrcOffset available" + +getTokenLen :: SrcLoc -> SrcOffset +getTokenLen x = case x of + TokPos t -> tokenLen t + TokSpan s e -> (alexPos $ tokenStart e) - (alexPos $ tokenStart s) + tokenLen e + FixedLoc {} -> fixedLen x + _ -> error "getTokenLen : info not available" + +getEndLine :: SrcLoc -> SrcLine +getEndLine x = case x of + TokSpan _s e -> alexLine $ computeEndPos e + TokPos t -> alexLine $ computeEndPos t + FixedLoc {} -> fixedEndLine x + _ -> error "no SrcLine available" + +getEndCol :: SrcLoc -> SrcCol +getEndCol x = case x of + TokSpan _s e -> alexCol $ computeEndPos e + TokPos t -> alexCol $ computeEndPos t + FixedLoc {} -> fixedEndCol x + _ -> error "no SrcCol available" + +getEndOffset :: SrcLoc -> SrcOffset +getEndOffset x = case x of + TokSpan _s e -> (alexPos $ tokenStart e) + tokenLen e + TokPos t -> (alexPos $ tokenStart t) + tokenLen t + FixedLoc {} -> fixedEndOffset x + _ -> error "no SrcOffset available" + +computeEndPos :: Token -> AlexPosn +computeEndPos t = foldl' alexMove (tokenStart t) (tokenString t) + +getStartTokenId :: SrcLoc -> TokenId +getStartTokenId s = case s of + TokIdPos x -> x + TokIdSpan x _ -> x + TokSpan x _ -> Token.tokenId x + TokPos x -> Token.tokenId x + _ -> error "no startTokenId available" + +getEndTokenId :: SrcLoc -> TokenId +getEndTokenId s = case s of + TokIdPos x -> x + TokIdSpan _ x -> x + TokSpan _ x -> Token.tokenId x + TokPos x -> Token.tokenId x + _ -> error "no endTokenId available" + + +{-# DEPRECATED srcLocFromTo "sourceLoc arithmetics is not reliable" #-} +-- this is the closed Interval between s and e +srcLocFromTo :: SrcLoc -> SrcLoc -> SrcLoc +srcLocFromTo (TokSpan s _) (TokSpan _ e) = TokSpan s e +srcLocFromTo s e = FixedLoc { + fixedStartLine = getStartLine s + ,fixedStartCol = getStartCol s + ,fixedStartOffset = getStartOffset s + ,fixedLen = getEndOffset e - getStartOffset s + ,fixedEndLine = getEndLine e + ,fixedEndCol = getEndCol e + ,fixedEndOffset = getEndOffset e + } + +{-# DEPRECATED srcLocBetween "sourceLoc arithmetics is not reliable" #-} +-- this is the open Interval between s and e +srcLocBetween :: SrcLoc -> SrcLoc -> SrcLoc +srcLocBetween s e = FixedLoc { + fixedStartLine = getEndLine s + ,fixedStartCol = getEndCol s + 1 -- maybe wrong when token at end of Line + ,fixedStartOffset = getStartOffset s + getTokenLen s + ,fixedLen = getEndOffset e - getStartOffset s + ,fixedEndLine = getStartLine e + ,fixedEndCol = getStartCol e -1 -- maybe wrong when startCol = 0 + ,fixedEndOffset = getStartOffset e + } diff --git a/src/Language/CSPM/Token.hs b/src/Language/CSPM/Token.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/Token.hs @@ -0,0 +1,78 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.CSPM.Token +-- Copyright : (c) Fontaine 2008 +-- License : BSD +-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de +-- Stability : provisional +-- Portability : GHC-only +-- +-- This module contains the datatype Tokens. + +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} + +module Language.CSPM.Token +where + +import Language.CSPM.TokenClasses + +import Data.Typeable (Typeable) +import Data.Generics.Basics (Data) +import Data.Generics.Instances () +import Data.Ix +import Data.Char +import Control.Exception (Exception) + +newtype TokenId = TokenId {unTokenId :: Int} + deriving (Show,Eq,Ord,Enum,Ix, Typeable, Data) + +mkTokenId :: Int -> TokenId +mkTokenId = TokenId + +data AlexPosn = AlexPn { + alexPos :: !Int + ,alexLine :: !Int + ,alexCol :: !Int + } deriving (Show,Eq,Ord, Typeable, Data) + +pprintAlexPosn :: AlexPosn -> String +pprintAlexPosn (AlexPn _p l c) = "Line: "++show l++" Col: "++show c + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l _c) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + + +data LexError = LexError { + lexEPos :: !AlexPosn + ,lexEMsg :: !String + } deriving (Show, Typeable) +instance Exception LexError + + +data Token = Token + { tokenId :: TokenId + , tokenStart :: AlexPosn + , tokenLen :: Int + , tokenClass :: PrimToken + , tokenString :: String + } deriving (Show,Eq,Ord, Typeable, Data) + +tokenSentinel :: Token +tokenSentinel = Token + { tokenId = mkTokenId (- 1) + , tokenStart = AlexPn 0 0 0 + , tokenLen = 0 + , tokenClass =error "CSPLexer.x illegal access tokenSentinel" + , tokenString =error "CSPLexer.x illegal access tokenSentinel"} + +showPosn :: AlexPosn -> String +showPosn (AlexPn _ line col) = show line ++ ':': show col + +showToken :: Token -> String +showToken Token {tokenString=str} = "'"++str++"'" + diff --git a/src/Language/CSPM/TokenClasses.hs b/src/Language/CSPM/TokenClasses.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/TokenClasses.hs @@ -0,0 +1,125 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.CSPM.TokenClasses +-- Copyright : (c) Fontaine 2008 +-- License : BSD +-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de +-- Stability : provisional +-- Portability : GHC-only +-- +-- This module contains the datatype Tokens. + +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} + +module Language.CSPM.TokenClasses +where + +import Data.Typeable (Typeable) +import Data.Generics.Basics (Data) +import Data.Generics.Instances () + +data PrimToken + = L_Integer + | L_String + | L_Ident + | L_CSPFDR -- needed for special assertions + | L_LComment + | L_BComment + | L_EOF + | L_Include + | T_Refine +-- keywords + | T_channel + | T_datatype + | T_nametype + | T_subtype + | T_assert + | T_pragma + | T_transparent + | T_external + | T_print + | T_if + | T_then + | T_else + | T_let + | T_within +-- constants and builtins + | T_true + | T_false + | T_not + | T_and + | T_or + | T_union + | T_inter + | T_diff + | T_Union + | T_Inter + | T_member + | T_card + | T_empty + | T_set + | T_Set + | T_Seq + | T_null + | T_head + | T_tail + | T_concat + | T_elem + | T_length + | T_STOP + | T_SKIP + | T_Events + | T_Int + | T_Bool + | T_CHAOS +-- symbols + | T_hat -- "^" + | T_hash -- "#" + | T_times -- "*" + | T_slash -- "/" + | T_percent -- "%" + | T_plus -- "+" + | T_minus -- "-" + | T_eq -- "==" + | T_neq -- "!=" + | T_ge -- ">=" + | T_le -- "<=" + | T_lt -- "<" + | T_gt -- ">" + | T_amp -- "&" + | T_semicolon -- ";" + | T_comma -- "," + | T_triangle -- "/\\" + | T_box -- "[]" + | T_rhd -- "[>" + | T_sqcap -- "|~|" + | T_interleave -- "|||" + | T_backslash -- "\\" + | T_parallel -- "||" + | T_mid -- "|" + | T_at -- "@" + | T_atat -- "@@" + | T_rightarrow -- "->" + | T_leftarrow -- "<-" + | T_leftrightarrow -- "<->" + | T_dot -- "." + | T_dotdot -- ".." + | T_exclamation -- "!" + | T_questionmark -- "?" + | T_colon -- ":" + | T_openParen -- "(" + | T_closeParen -- ")" + | T_openBrace -- "{" + | T_closeBrace -- "}" + | T_openBrack -- "[" + | T_closeBrack -- "]" + | T_openOxBrack -- "[|" + | T_closeOxBrack -- "|]" + | T_openBrackBrack -- "[[" + | T_closeBrackBrack -- "]]" + | T_openPBrace -- "{|" + | T_closePBrace -- "|}" + | T_underscore -- "_" + | T_is -- "=" + deriving (Show,Eq,Ord,Typeable, Data) diff --git a/src/Language/CSPM/Utils.hs b/src/Language/CSPM/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/Utils.hs @@ -0,0 +1,84 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.CSPM.Utils +-- Copyright : (c) Fontaine 2008 +-- License : BSD +-- +-- Maintainer : fontaine@cs.uni-duesseldorf.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Some Utilities + +module Language.CSPM.Utils + (eitherToExc + ,handleLexError + ,handleParseError + ,handleRenameError + ,parseFile,testFrontend) +where + +import Language.CSPM.Parser (ParseError(..),parse) +import Language.CSPM.Rename (RenameError(..),getRenaming,applyRenaming) +import Language.CSPM.PatternCompiler (compilePattern) +import Language.CSPM.Token (Token,LexError(..)) +import Language.CSPM.AST (Labeled(..),LModule,Module(..),Bindings) +import Language.CSPM.AstUtils + (removeSourceLocations,removeModuleTokens,removeParens,relabelAst + ,unUniqueIdent,showAst,computeFreeNames) + +import qualified Language.CSPM.LexHelper as Lexer + (lexInclude,lexPlain,filterIgnoredToken) + +import Control.Exception as Exception +import System.CPUTime + +-- | "eitherToExe" returns the Right part of "Either" or throws the Left part as an dynamic exception. +eitherToExc :: Exception a => Either a b -> IO b +eitherToExc (Right r) = return r +eitherToExc (Left e) = throw e + +-- | Handle a dymanic exception of type "LexError". +handleLexError :: (LexError -> IO a) -> IO a -> IO a +handleLexError handler proc = Exception.catch proc handler + +-- | Handle a dymanic exception of type "ParseError". +handleParseError :: (ParseError -> IO a) -> IO a -> IO a +handleParseError handler proc = Exception.catch proc handler + +-- | Handle a dymanic exception of type "RenameError". +handleRenameError :: (RenameError -> IO a) -> IO a -> IO a +handleRenameError handler proc = Exception.catch proc handler + +-- | Lex and parse a file and return a "LModule", throw an exception in case of an error +parseFile :: FilePath -> IO LModule +parseFile fileName = do + src <- readFile fileName + tokenList <- Lexer.lexInclude src >>= eitherToExc + eitherToExc $ parse fileName tokenList + +testFrontend :: FilePath -> IO (LModule,LModule) +testFrontend fileName = do + src <- readFile fileName + + putStrLn $ "Reading File " ++ fileName + startTime <- (return $ length src) >> getCPUTime + tokenList <- Lexer.lexInclude src >>= eitherToExc + time_have_tokens <- getCPUTime + + ast <- eitherToExc $ parse fileName tokenList + time_have_ast <- getCPUTime + + renaming <- eitherToExc $ getRenaming ast + let astNew = applyRenaming renaming ast + time_have_renaming <- getCPUTime + + putStrLn $ "Parsing OK" + putStrLn $ "lextime : " ++ showTime (time_have_tokens - startTime) + putStrLn $ "parsetime : " ++ showTime(time_have_ast - time_have_tokens) + putStrLn $ "renamingtime : " ++ showTime (time_have_renaming - time_have_ast) + putStrLn $ "total : " ++ showTime(time_have_ast - startTime) + return (ast,astNew) + where + showTime :: Integer -> String + showTime a = show (div a 1000000000) ++ "ms" diff --git a/src/Language/CSPM/Version.hs b/src/Language/CSPM/Version.hs new file mode 100644 --- /dev/null +++ b/src/Language/CSPM/Version.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.CSPM.Version +-- Copyright : (c) Fontaine 2008 +-- License : BSD +-- +-- Maintainer : Fontaine@cs.uni-duesseldorf.de +-- Stability : experimental +-- Portability : GHC-only +-- +-- Use Template Haskell to gather some info a compile-time. + +{-# LANGUAGE TemplateHaskell #-} +module Language.CSPM.Version +( + version +) +where + +import qualified Paths_CSPM_Frontend as Paths +import Language.Haskell.TH +import System.Time +import System.Info +import Data.List +--import Network.BSD --check if this is the reason why we have to link to network ? +import Data.Version + +-- | "version" returns a "String" with some info about the, on which the libray was built. +version :: IO String +version = return $( let + mkVersion :: IO String + mkVersion = do + timeDate <- getClockTime +-- hn <- getHostName + let sysInfo = concat $ intersperse " " [ + "CSPM-Fronted" + ,show Paths.version + ,"\nCompiled at",show timeDate +-- ,"\non",hn + ,"\n(",os,arch,compilerName,showVersion compilerVersion ,")" + ] + putStrLn "\n\n" + putStrLn "version :" + putStrLn sysInfo + putStrLn "\n\n" + return sysInfo + in stringE =<< runIO mkVersion + ) diff --git a/src/Text/ParserCombinators/Parsec/ExprM.hs b/src/Text/ParserCombinators/Parsec/ExprM.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/Parsec/ExprM.hs @@ -0,0 +1,137 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.ExprM +-- Stability : experimental +-- Portability : portable +-- +-- This module is a variant of Text.ParserCombinators.Parsec.Expr +-- A helper module to parse \"expressions\". +-- Builds a parser given a table of operators and associativities. +-- +-- In this module, the application of an operator is a monadic action. +-- This is, i.e. usefull if one wants to construct an AST an attach a unique +-- label to every node. +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.ExprM + ( Assoc(..), infixM, prefixM, postfixM + , OperatorTable, Operator + , buildExpressionParser + ) where + +import Text.ParserCombinators.Parsec.Prim +import Text.ParserCombinators.Parsec.Combinator + + +----------------------------------------------------------- +-- Assoc and OperatorTable +----------------------------------------------------------- +data Assoc = AssocNone + | AssocLeft + | AssocRight + +data Operator t st a + = Infix (GenParser t st (a -> a -> GenParser t st a)) Assoc + | Prefix (GenParser t st (a -> GenParser t st a)) + | Postfix (GenParser t st (a -> GenParser t st a)) + +infixM :: + (GenParser t st (a -> a -> GenParser t st a)) + -> Assoc + -> Operator t st a +infixM = Infix + +prefixM :: (GenParser t st (a -> GenParser t st a)) -> Operator t st a +prefixM = Prefix + +postfixM :: (GenParser t st (a -> GenParser t st a)) -> Operator t st a +postfixM = Postfix + +type OperatorTable t st a = [[Operator t st a]] + + + +----------------------------------------------------------- +-- Convert an OperatorTable and basic term parser into +-- a full fledged expression parser +----------------------------------------------------------- +buildExpressionParser :: OperatorTable tok st a -> GenParser tok st a -> GenParser tok st a +buildExpressionParser operators simpleExpr + = foldl (makeParser) simpleExpr operators + where + makeParser term ops + = let (rassoc,lassoc,nassoc + ,prefix,postfix) = foldr splitOp ([],[],[],[],[]) ops + + rassocOp = choice rassoc + lassocOp = choice lassoc + nassocOp = choice nassoc + prefixOp = choice prefix "" + postfixOp = choice postfix "" + + ambigious assoc op= try $ + do{ op; fail ("ambiguous use of a " ++ assoc + ++ " associative operator") + } + + ambigiousRight = ambigious "right" rassocOp + ambigiousLeft = ambigious "left" lassocOp + ambigiousNon = ambigious "non" nassocOp + + termP = do{ pre <- prefixP + ; x <- term + ; post <- postfixP + ; pre x >>= post + } + + postfixP = postfixOp <|> return return + + prefixP = prefixOp <|> return return + + rassocP x = do{ f <- rassocOp + ; y <- do{ z <- termP; rassocP1 z } + ; f x y + } + <|> ambigiousLeft + <|> ambigiousNon + -- <|> return x + + rassocP1 x = rassocP x <|> return x + + lassocP x = do{ f <- lassocOp + ; y <- termP + ; f x y >>= lassocP1 + } + <|> ambigiousRight + <|> ambigiousNon + -- <|> return x + + lassocP1 x = lassocP x <|> return x + + nassocP x = do{ f <- nassocOp + ; y <- termP + ; ambigiousRight + <|> ambigiousLeft + <|> ambigiousNon + <|> f x y + } + -- <|> return x + + in do{ x <- termP + ; rassocP x <|> lassocP x <|> nassocP x <|> return x + "operator" + } + + + splitOp (Infix op assoc) (rassoc,lassoc,nassoc,prefix,postfix) + = case assoc of + AssocNone -> (rassoc,lassoc,op:nassoc,prefix,postfix) + AssocLeft -> (rassoc,op:lassoc,nassoc,prefix,postfix) + AssocRight -> (op:rassoc,lassoc,nassoc,prefix,postfix) + + splitOp (Prefix op) (rassoc,lassoc,nassoc,prefix,postfix) + = (rassoc,lassoc,nassoc,op:prefix,postfix) + + splitOp (Postfix op) (rassoc,lassoc,nassoc,prefix,postfix) + = (rassoc,lassoc,nassoc,prefix,op:postfix) +