language-ats 1.2.0.0 → 1.2.0.1

raw patch · 6 files changed

+53/−35 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• language-ats.cabal +1/−1
• src/Language/ATS.hs +19/−15
• src/Language/ATS/Lexer.x +21/−8
• src/Language/ATS/Parser.y +4/−5
• src/Language/ATS/PrettyPrint.hs +7/−6
• src/Language/ATS/Types.hs +1/−0

@@ -1,6 +1,6 @@ cabal-version: 1.18 name: language-ats-version: 1.2.0.0+version: 1.2.0.1 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018 Vanessa McHale

@@ -5,6 +5,7 @@                       lexATS                     , parse                     , parseWithCtx+                    , parseM                     , printATS                     , printATSCustom                     , printATSFast@@ -13,7 +14,6 @@                     , defaultFixityState                     -- * Library functions                     , getDependencies-                    , getDeps                     -- * Syntax Tree                     , ATS (..)                     , Declaration (..)@@ -78,27 +78,31 @@ printErr = liftIO . hPutDoc stderr . (<> "\n") . pretty  -- | Same as 'printErr', but print a yellow warning message instead.-warnErr :: MonadIO m => ATSError -> m ()-warnErr = liftIO . hPutDoc stderr . (dullyellow "Warning" <+>) . preErr+warnErr :: MonadIO m => FilePath -> ATSError -> m ()+warnErr fp = liftIO . hPutDoc stderr . ((dullyellow "Warning" <+> text (fp <> ":")) <+> ) . preErr +-- | Parse a string containing ATS source, disregarding comments.+parseM :: String -> Either ATSError (ATS AlexPosn)+parseM = parseWithCtx defaultFixityState stripComments+ -- | Parse a string containing ATS source. parse :: String -> Either ATSError (ATS AlexPosn)-parse = parseWithCtx defaultFixityState+parse = parseWithCtx defaultFixityState id +stripComments :: [Token] -> [Token]+stripComments = filter nc+    where nc CommentLex{}      = False+          nc CommentBegin{}    = False+          nc CommentEnd{}      = False+          nc CommentContents{} = False+          nc _                 = True+ -- | Parse with some fixity declarations already in scope.-parseWithCtx :: FixityState AlexPosn -> String -> Either ATSError (ATS AlexPosn)-parseWithCtx st = stateParse <=< lexErr+parseWithCtx :: FixityState AlexPosn -> ([Token] -> [Token]) -> String -> Either ATSError (ATS AlexPosn)+parseWithCtx st p = stateParse <=< lexErr     where withSt = flip runStateT st-          lexErr = over _Left LexError . lexATS+          lexErr = over _Left LexError . fmap p . lexATS           stateParse = fmap rewriteATS' . withSt . parseATS---- FIXME should we use a pattern synonym?-getDeps :: [Token] -> [FilePath]-getDeps (Keyword _ KwStaload{}:StringTok _ s:xs) = (init . drop 1) s : getDeps xs-getDeps (Keyword _ KwDynload{}:StringTok _ s:xs) = (init . drop 1) s : getDeps xs-getDeps (Keyword _ KwInclude{}:StringTok _ s:xs) = (init . drop 1) s : getDeps xs-getDeps (_:xs)                                   = getDeps xs-getDeps []                                       = mempty  -- | Extract a list of files that some code depends on. getDependencies :: ATS a -> [FilePath]

@@ -77,7 +77,7 @@ @inner_signature = ("!wrt" | "!exn" | "!refwrt" | "!exnwrt" | "!exnrefwrt" | "!exnref" | "0" | "1" | "!all" | "!laz" | "lin" | "fun" | "clo" | "cloptr" | "cloref" | "!ntm" | "!ref" | "prf" | "fe" | @block_comment) @inner_signature_mult = (@inner_signature (("," | "") @inner_signature)*) | "" -@lambda = "=>" | "=>>" | "=<" @inner_signature_mult ">"+@lambda = "=>" | "=>>" | "=/=>" | "=<" @inner_signature_mult ">" @signature = ":<" @inner_signature_mult ">" | ":" @func_type = "->" | "-<" @inner_signature_mult ">" @@ -102,8 +102,10 @@  @builtin = \$ (("effmask_" (wrt | all | ref)) | "extfcall" | "extype" (_struct | "") | "arrpsz" | "ldelay" | "delay" | "list" (_vt | "") | "tempenver" | "extval" | "mylocation" | "solver_assert" | "showtype") -@block_comment_start = \(\* | \/\*-@block_comment_end = \*\) | \*\/+@block_comment_start = \(\*+@block_comment_end = \*\)+@c_comment_start = \/\*+@c_comment_end = \*\/  @comment_in = [\*$white] @comment_general = @comment_in | [\)\(\/]@@ -111,23 +113,31 @@ tokens :-      <0> $white+                  ;+    <one,two,three,one_c> "(*)"  ;     <0> @block_comment_start     { tok (\p _ -> alex $ CommentBegin p) `andBegin` one }+    <0> @c_comment_start         { tok (\p _ -> alex $ CommentBegin p) `andBegin` one_c }     <one> @block_comment_end     { tok (\p _ -> alex $ CommentEnd p) `andBegin` 0 }     <one> @block_comment_start   { tok (\p s -> alex $ CommentContents p s) `andBegin` two }-    <one> [^\*\(\)\/]+           { tok (\p s -> alex $ CommentContents p s) }+    <one> [^\*\(\)]+             { tok (\p s -> alex $ CommentContents p s) }     <one> @comment_in+ / [^\)]   { tok (\p s -> alex $ CommentContents p s) }     <one> @comment_general       { tok (\p s -> alex $ CommentContents p s) }     <two> @block_comment_end     { tok (\p s -> alex $ CommentContents p s) `andBegin` one }     <two> @block_comment_start   { tok (\p s -> alex $ CommentContents p s) `andBegin` three }-    <two> [^\*\(\)\/]+           { tok (\p s -> alex $ CommentContents p s) }+    <two> [^\*\(\)]+             { tok (\p s -> alex $ CommentContents p s) }     <two> @comment_in+ / [^\)]   { tok (\p s -> alex $ CommentContents p s) }     <two> @comment_general       { tok (\p s -> alex $ CommentContents p s) }     <three> @block_comment_end   { tok (\p s -> alex $ CommentContents p s) `andBegin` two }-    <three> @block_comment_start { tok (\_ _ -> alexError "Nested comments of depth > 3 are not supported.") }-    <three> [^\*\(\)\/]+         { tok (\p s -> alex $ CommentContents p s) }-    <three> @comment_in+ / [^\)] { tok (\p s -> alex $ CommentContents p s) }+    <three> @block_comment_start { tok (\p _ -> alexError ("at " <> show (pretty p) <> ": Nested comments of depth > 3 are not supported.")) }+    <three> [^\*\/]+             { tok (\p s -> alex $ CommentContents p s) }+    <three> @comment_in+ / [^\/] { tok (\p s -> alex $ CommentContents p s) }     <three> @comment_general     { tok (\p s -> alex $ CommentContents p s) }+    <one_c> @c_comment_end   { tok (\p _ -> alex $ CommentEnd p) `andBegin` 0 }+    <one_c> @c_comment_start { tok (\p _ -> alexError ("at " <> show (pretty p) <> ": Nested C comments of depth > 1 are not supported.")) }+    <one_c> [^\*\/]+             { tok (\p s -> alex $ CommentContents p s) }+    <one_c> @comment_in+ / [^\/] { tok (\p s -> alex $ CommentContents p s) }+    <one_c> @comment_general     { tok (\p s -> alex $ CommentContents p s) }     <0> "//".*                   { tok (\p s -> alex $ CommentLex p s) }+    <0> "//".*                   { tok (\p s -> alex $ CommentLex p s) }     <0> @c_block                 { tok (\p s -> alex $ CBlockLex p s) }     <0> "#define".*              { tok (\p s -> alex $ MacroBlock p s) }     <0> @if_block                { tok (\p s -> alex $ MacroBlock p s) }      @@ -470,6 +480,9 @@  instance Pretty Word where     pretty = text . show++instance Pretty AlexPosn where+    pretty (AlexPn _ line col) = pretty line <> ":" <> pretty col  instance Pretty Token where     pretty (SpecialIdentifier _ s) = text ('$' : s)

@@ -478,6 +478,8 @@      | viewContra { View $1 Minus }      | viewCo { View $1 Plus }      | vtype { VType (token_posn $1) (get_addendum $1) }+     | openParen Sort comma Sort closeParen { TupleSort $1 $2 $4 }+     | doubleParens { NamedSort "()" }      | IdentifierOr { NamedSort $1 }      | IdentifierOr plus { NamedSort ($1 <> "+") } @@ -902,9 +904,6 @@               | LexError String               deriving (Eq, Show, Generic, NFData) -instance Pretty AlexPosn where-    pretty (AlexPn _ line col) = pretty line <> ":" <> pretty col- unmatched :: AlexPosn -> String -> Doc unmatched l chr = "unmatched" <+> squotes (text chr) <+> "at" <+> pretty l <> linebreak  @@ -915,7 +914,7 @@ bear _ (x:xs) = x <> "," <+> bear True xs  instance Pretty ATSError where-    pretty = (red "Error:" <+>) . preErr+    pretty = (dullred "Error:" <+>) . preErr  preErr (OneOf p ss s) = pretty p <> linebreak <> (indent 2 $ "Unexpected" <+> squotes (text s) <> ", expected one of" <+> bear False (fmap (squotes . text) ss)) <> linebreak preErr (Expected p s1 s2) = pretty p <> linebreak <> (indent 2 $ "Unexpected" <+> squotes (text s2) <> ", expected:" <+> squotes (text s1)) <> linebreak@@ -923,7 +922,7 @@ preErr (Unknown (Special l "}")) = unmatched l "}" preErr (Unknown (Special l ">")) = unmatched l ">" preErr (Unknown t) = "unexpected token" <+> squotes (pretty t) <+> "at" <+> pretty (token_posn t) <> linebreak-preErr (LexError s) = red "Lexical error:" <+> text s+preErr (LexError s) = dullred "lexing:" <+> text s <> linebreak  left :: ATSError -> ParseSt b left = lift . Left

@@ -249,12 +249,13 @@             ("let" <+> pretty e <$> endLet e')  instance Eq a => Pretty (Sort a) where-    pretty (T0p ad)      = "t@ype" <> pretty ad-    pretty (Vt0p ad)     = "vt@ype" <> pretty ad-    pretty (NamedSort s) = text s-    pretty Addr          = "addr"-    pretty (View _ t)    = "view" <> pretty t-    pretty (VType _ a)   = "vtype" <> pretty a+    pretty (T0p ad)           = "t@ype" <> pretty ad+    pretty (Vt0p ad)          = "vt@ype" <> pretty ad+    pretty (NamedSort s)      = text s+    pretty Addr               = "addr"+    pretty (View _ t)         = "view" <> pretty t+    pretty (VType _ a)        = "vtype" <> pretty a+    pretty (TupleSort _ s s') = parens (pretty s <> "," <+> pretty s')  instance Eq a => Pretty (Type a) where     pretty = cata a where

@@ -221,6 +221,7 @@             | Addr             | VType a Addendum -- ^ @viewtype@ or @vtype@             | View a Addendum -- ^ @view@+            | TupleSort a (Sort a) (Sort a)             deriving (Show, Eq, Generic, NFData)  -- FIXME a type for sorts?