CSPM-Frontend (empty) → 0.2.8.0

raw patch · 19 files changed

+3691/−0 lines, 19 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers, haskell98, mtl, old-time, parsec, pretty, syb, template-haskell

Files

• CSPM-Frontend.cabal +62/−0
• LICENSE +27/−0
• Setup.hs +3/−0
• src/Language/CSPM/AST.hs +378/−0
• src/Language/CSPM/AlexWrapper.hs +137/−0
• src/Language/CSPM/AstUtils.hs +114/−0
• src/Language/CSPM/Frontend.hs +66/−0
• src/Language/CSPM/LexHelper.hs +73/−0
• src/Language/CSPM/Lexer.x +225/−0
• src/Language/CSPM/Parser.hs +1117/−0
• src/Language/CSPM/PatternCompiler.hs +158/−0
• src/Language/CSPM/PrettyPrinter.hs +265/−0
• src/Language/CSPM/Rename.hs +446/−0
• src/Language/CSPM/SrcLoc.hs +148/−0
• src/Language/CSPM/Token.hs +78/−0
• src/Language/CSPM/TokenClasses.hs +125/−0
• src/Language/CSPM/Utils.hs +84/−0
• src/Language/CSPM/Version.hs +48/−0
• src/Text/ParserCombinators/Parsec/ExprM.hs +137/−0

@@ -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 <fontaine@cs.uni-duesseldorf.de>+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

@@ -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.

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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++}

@@ -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)

@@ -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

@@ -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 +

@@ -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

@@ -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+   }

@@ -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++"'"+

@@ -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)

@@ -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"

@@ -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 +   )

@@ -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)+