CSPM-Frontend 0.3.0.4 → 0.4.0.0

raw patch · 10 files changed

+114/−136 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CSPM-Frontend.cabal +1/−1
• src/Language/CSPM/AST.hs +10/−11
• src/Language/CSPM/LexHelper.hs +2/−2
• src/Language/CSPM/Parser.hs +41/−53
• src/Language/CSPM/PatternCompiler.hs +3/−3
• src/Language/CSPM/PrettyPrinter.hs +17/−16
• src/Language/CSPM/Rename.hs +35/−39
• src/Language/CSPM/Token.hs +0/−1
• src/Language/CSPM/Utils.hs +2/−7
• src/Text/ParserCombinators/Parsec/ExprM.hs +3/−3

@@ -1,5 +1,5 @@ Name:                CSPM-Frontend-Version:             0.3.0.4+Version:             0.4.0.0  Synopsis:            A CSP-M parser compatible with FDR-2.83 

@@ -117,14 +117,8 @@ 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])+  | SetExp LRange (Maybe [LCompGen])+  | ListExp LRange (Maybe [LCompGen])   | ClosureComprehension ([LExp],[LCompGen])   | Let [LDecl] LExp   | Ifte LExp LExp LExp@@ -166,9 +160,14 @@   | LetI [LDecl] FreeNames LExp -- freenames of all localBound names   | LambdaI FreeNames [LPattern] LExp   | ExprWithFreeNames FreeNames LExp-  deriving (Show,Eq,Ord,Typeable, Data)+  deriving (Show, Eq, Ord, Typeable, Data) -type LCompGenList = Labeled [LCompGen]+type LRange = Labeled Range+data Range+  = RangeEnum [LExp]+  | RangeClosed LExp LExp+  | RangeOpen LExp+  deriving (Show, Eq, Ord, Typeable, Data)  type LCommField = Labeled CommField data CommField@@ -196,7 +195,7 @@ lBuiltInToConst = h . unLabel where   h (BuiltIn c) = c - --generators inside a comprehension-expression+type LCompGenList = Labeled [LCompGen] type LCompGen = Labeled CompGen data CompGen   = Generator LPattern LExp

@@ -12,8 +12,8 @@ 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(..))+--import qualified Language.CSPM.Token as Token+--  (Token(..), LexError(..))  {- todo : use an error monad -} 

@@ -128,7 +128,7 @@   e <- getLastPos   mkLabeledNode (mkSrcSpan s e) av -inSpan :: (a -> b ) -> PT a -> PT (Labeled b) +inSpan :: (a -> b) -> PT a -> PT (Labeled b)  inSpan constr exp = do   s <- getNextPos   l <- exp@@ -215,19 +215,25 @@ 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+parseRangeExp :: PT LRange+parseRangeExp = withLoc (rangeClosed <|> rangeOpen <|> rangeEnum)+  where+    rangeEnum = liftM RangeEnum $ sepByComma parseExp_noPrefix +    rangeClosed :: PT Range+    rangeClosed = try $ do+      s <-parseExp_noPrefix+      token T_dotdot+      e <- parseExp_noPrefix+      return $ RangeClosed s e++    rangeOpen :: PT Range+    rangeOpen = try $ do+      s <- parseExp_noPrefix+      token T_dotdot+      return $ RangeOpen s+ comprehensionExp :: PT ([LExp],[LCompGen]) comprehensionExp = do   expList <- sepByComma parseExp@@ -267,29 +273,18 @@ 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 +setExp :: PT LExp+setExp = withLoc $ inBraces $ do+  (range,comp) <- lsBody+  return $ SetExp range comp -setComprehension :: PT LExp-setComprehension =  inSpan SetComprehension $ inBraces comprehensionExp+listExp :: PT LExp+listExp = withLoc $ betweenLtGt $ do+  (range,comp) <- lsBody+  return $ ListExp range comp -listComprehension :: PT LExp-listComprehension =  inSpan  ListComprehension $ betweenLtGt comprehensionExp+lsBody :: PT (LRange, Maybe [LCompGen])+lsBody = liftM2 (,) parseRangeExp (optionMaybe parseComprehension)  closureComprehension :: PT LExp closureComprehension = inSpan  ClosureComprehension@@ -399,14 +394,8 @@      <|> lambdaExp      <|> try closureComprehension      <|> closureExp-     <|> try listComprehension-     <|> try setComprehension-     <|> try listExpEnum-     <|> try setExpEnum-     <|> try setExpClose-     <|> try listExpClose-     <|> try setExpOpen-     <|> try listExpOpen+     <|> try listExp+     <|> try setExp      <|> blockBuiltIn      <?> "core-expression"  @@ -597,7 +586,7 @@       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+      _ <- setParserState st --backtrack       s <- parseWithGtLimit (cnt) parser       token_gt       return s@@ -1025,8 +1014,8 @@ testFollows :: PT x -> PT (Maybe x) testFollows p = do   oldState <- getParserState-  res<-optionMaybe p-  setParserState oldState+  res <-optionMaybe p+  _ <- setParserState oldState   return res  getStates :: (PState -> x) -> PT x@@ -1050,16 +1039,15 @@ 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 ()-                       )+notFollowedBy p +  = try (do{ c <- p; unexpected $ Token.showToken c }+         <|> return ()+        ) +notFollowedBy' p+  = try (do{ p; pzero }+         <|> return ()+        ) eof :: PT () eof  = notFollowedBy anyToken <?> "end of input" 

@@ -20,8 +20,7 @@   ) where -import Language.CSPM.AST hiding (prologMode)-import qualified Language.CSPM.AST as AST+import Language.CSPM.AST as AST  import Control.Monad import Data.Generics.Schemes (everywhere')@@ -142,7 +141,8 @@       VarPat _ -> Nothing       Also patl -> do         let l = map lengthOfListPattern patl-        error "PatternCompiler.hs: lengthOfListPat : alsopattern: todo"+        -- todo: check that all length are equal:+        error "PatternCompiler.hs: lengthOfListPat : also pattern: todo"       _ -> error $ "PatternCompiler.hs: lengthOfListPat : no list pattern "                     ++ show p {-

@@ -45,17 +45,12 @@ 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 ">"+  SetExp a Nothing -> braces $ pp x+  SetExp a (Just comp) -> braces ( pp a <+> text "|" <+> hcatCommaSpace comp)+  ListExp a Nothing -> text "<" <+> pp a <+> text ">"+  ListExp a (Just comp)+    -> text "<" <+> pp a <+> text "|" <+> hcatCommaSpace comp <+> 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"@@ -93,17 +88,23 @@ --     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 +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+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+  pp (Rename x y) = pp x <> text "<-" <> pp y++instance PP Range where+   pp x = case x of+     RangeEnum l -> hcatCommaSpace l+     RangeOpen a -> pp a <+> text ".."+     RangeClosed a b -> pp a <+> text ".." <+> pp b  instance PP CompGen where      pp (Generator patt x) = pp patt <> {-text "<-"-}colon <> pp x

@@ -195,14 +195,32 @@     ,localBindings = localBind }   return res +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 ()  {- 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 () @@ -217,14 +235,10 @@ 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)+  SetExp a Nothing -> rnRange a+  SetExp a (Just comp) -> inCompGen comp (rnRange a)+  ListExp a Nothing -> rnRange a+  ListExp a (Just comp) -> inCompGen comp (rnRange 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@@ -273,35 +287,13 @@   ExprWithFreeNames {} -> error "Rename.hs : no match for ExprWithFreeNames"   LambdaI {} -> error "Rename.hs : no match for LambdaI"   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 ()+  PrefixI {} -> error "Rename.hs : no match for PrefixI" +rnRange :: LRange -> RM ()+rnRange r = case unLabel r of+  RangeEnum l -> rnExpList l+  RangeOpen a -> rnExp a+  RangeClosed a b -> rnExp a >> rnExp b  rnPatList :: [LPattern] -> RM () rnPatList = mapM_ rnPattern@@ -320,6 +312,9 @@   EmptySetPat -> nop   ListEnumPat l -> rnPatList l   TuplePat l -> rnPatList l+  ConstrPat {} -> error "Rename.hs : no match for ConstrPat" -- Where have they gone ?+  Selectors {} -> error "Rename.hs : no match for Selectors"+  Selector {} -> error "Rename.hs : no match for Selector"  rnCommField :: LCommField -> RM () rnCommField f = case unLabel f of@@ -407,7 +402,8 @@   Print e -> rnExp e   where     rnFunCase c = case c of  --todo:uses Labeled version-      (FunCase pat e) -> localScope (mapM_ rnPatList pat >> rnExp e)+      FunCase pat e -> localScope (mapM_ rnPatList pat >> rnExp e)+      FunCaseI {} -> error "Rename.hs : no match for FunCaseI"     rnConstructorRHS :: LConstructor -> RM ()     rnConstructorRHS = rc . unLabel where       rc (Constructor _ Nothing ) = nop

@@ -21,7 +21,6 @@ import Data.Generics.Basics (Data) import Data.Generics.Instances () import Data.Ix-import Data.Char import Control.Exception (Exception)  newtype TokenId = TokenId {unTokenId :: Int}

@@ -20,13 +20,8 @@  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 Language.CSPM.Token (Token, LexError(..))+import Language.CSPM.AST (LModule) import qualified Language.CSPM.LexHelper as Lexer   (lexInclude,lexPlain,filterIgnoredToken) 

@@ -69,10 +69,10 @@               prefixOp   = choice prefix  <?> ""               postfixOp  = choice postfix <?> ""               -              ambigious assoc op= try $-                                  do{ op; fail ("ambiguous use of a " ++ assoc +              ambigious assoc op+                = try ( op >> fail ("ambiguous use of a " ++ assoc                                                   ++ " associative operator")-                                    }+                      )                              ambigiousRight    = ambigious "right" rassocOp               ambigiousLeft     = ambigious "left" lassocOp