diff --git a/language-ats.cabal b/language-ats.cabal --- a/language-ats.cabal +++ b/language-ats.cabal @@ -1,5 +1,5 @@ name: language-ats -version: 0.2.0.2 +version: 0.2.0.3 synopsis: Parser and pretty-printer for ATS. description: Parser and pretty-printer for [ATS](http://www.ats-lang.org/), written with Happy and Alex. license: BSD3 diff --git a/src/Language/ATS/Lexer.x b/src/Language/ATS/Lexer.x --- a/src/Language/ATS/Lexer.x +++ b/src/Language/ATS/Lexer.x @@ -1,6 +1,6 @@ { - {-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-incomplete-uni-patterns #-} + {-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-incomplete-uni-patterns -fno-warn-unused-imports #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -28,7 +28,7 @@ } -%wrapper "posn" +%wrapper "monad" -- Digits $digit = 0-9 @@ -87,7 +87,7 @@ -- TODO should be followed by a space; symbols like @..@ should have their own -- thing. -@operator = "**" | "+" | "-" | "*" | "/" | ".." | "!=" | ">=" | "<=" | "==" | "=" | "~" | "%" | "&&" | "||" | ":=" | ".<" | ">." | "<" | ">" | ">>" | "?" | "?!" | "#[" | "->>" +@operator = "**" | "+" | "-" | "*" | "/" | ".." | "!=" | ">=" | "<=" | "==" | "=" | "~" | "%" | "&&" | "||" | ":=" | ".<" | ">." | "<" | ">" | ">>" | "?" | "?!" | "#[" @double_parens = "(" (@block_comment | $white+ | \n | "//".*)+ ")" | "()" @double_braces = "{" @block_comment "}" | "{}" @@ -97,136 +97,140 @@ @fixity_decl = "infixr" | "infixl" | "prefix" | "postfix" +@builtin = \$ (("effmask_" (wrt | all | ref)) | "extfcall" | "ldelay" | "delay" | "list_vt" | "tempenver" | "extype") + tokens :- $white+ ; - @block_comment { tok (\p s -> CommentLex p s) } - "//".* { tok (\p s -> CommentLex p s) } - "#define".* { tok (\p s -> MacroBlock p s) } - @if_block { tok (\p s -> MacroBlock p s) } - @c_block { tok (\p s -> CBlockLex p s) } - fun { tok (\p s -> Keyword p KwFun) } - fn { tok (\p s -> Keyword p KwFn) } - fnx { tok (\p s -> Keyword p KwFnx) } - and { tok (\p s -> Keyword p KwAnd) } - prval { tok (\p s -> Keyword p KwPrval) } - prfn { tok (\p s -> Keyword p KwPrfn) } - prfun { tok (\p s -> Keyword p KwPrfun) } - datatype { tok (\p s -> Keyword p KwDatatype) } - data @view type { tok (\p s -> Keyword p KwDatavtype) } - @view type { tok (\p s -> Keyword p (KwVtype None)) } - @view type"+" { tok (\p s -> Keyword p (KwVtype Plus)) } - @view type"-" { tok (\p s -> Keyword p (KwVtype Minus)) } - dataview { tok (\p s -> Keyword p KwDataview) } - dataprop { tok (\p s -> Keyword p KwDataprop) } - assume { tok (\p s -> Keyword p KwAssume) } - typedef { tok (\p s -> Keyword p KwTypedef) } - @view typedef { tok (\p s -> Keyword p KwVtypedef) } - absprop { tok (\p s -> Keyword p KwAbsprop) } - llam { tok (\p s -> Keyword p KwLinearLambda) } - lam { tok (\p s -> Keyword p KwLambda) } - staload { tok (\p s -> Keyword p (KwStaload False)) } - "#"staload { tok (\p s -> Keyword p (KwStaload True)) } - let { tok (\p s -> Keyword p KwLet) } - in { tok (\p s -> Keyword p KwIn) } - end { tok (\p s -> Keyword p KwEnd) } - case"+" { tok (\p s -> Keyword p (KwCase Plus)) } - case"-" { tok (\p s -> Keyword p (KwCase Minus)) } - case { tok (\p s -> Keyword p (KwCase None)) } - castfn { tok (\p s -> Keyword p KwCastfn) } - val"+" { tok (\p s -> Keyword p (KwVal Plus)) } - val"-" { tok (\p s -> Keyword p (KwVal Minus)) } - val { tok (\p s -> Keyword p (KwVal None)) } - var { tok (\p s -> Keyword p KwVar) } - if { tok (\p s -> Keyword p KwIf) } - sif { tok (\p s -> Keyword p KwSif) } - then { tok (\p s -> Keyword p KwThen) } - else { tok (\p s -> Keyword p KwElse) } - implement { tok (\p s -> Keyword p KwImplement) } - implmnt { tok (\p s -> Keyword p KwImplement) } - primplmnt { tok (\p s -> Keyword p KwProofImplement) } - primplement { tok (\p s -> Keyword p KwProofImplement) } - abst"@"ype { tok (\p s -> Keyword p (KwAbst0p None)) } - abst"@ype+" { tok (\p s -> Keyword p (KwAbst0p Plus)) } - abst"@type-" { tok (\p s -> Keyword p (KwAbst0p Minus)) } - abs@view"t@ype" { tok (\p s -> Keyword p (KwAbsvt0p None)) } - t"@"ype"+" { tok (\p s -> Keyword p (KwT0p Plus)) } - t"@"ype"-" { tok (\p s -> Keyword p (KwT0p Minus)) } - t"@"ype { tok (\p s -> Keyword p (KwT0p None)) } - @view"t@ype+" { tok (\p s -> Keyword p (KwVt0p Plus)) } - @view"t@ype-" { tok (\p s -> Keyword p (KwVt0p Minus)) } - @view"t@ype" { tok (\p s -> Keyword p (KwVt0p None)) } - abstype { tok (\p s -> Keyword p KwAbstype) } - abs @view type { tok (\p s -> Keyword p KwAbsvtype) } - absview { tok (\p s -> Keyword p KwAbsview) } - view { tok (\p s -> Keyword p (KwView None)) } - view"+" { tok (\p s -> Keyword p (KwView Plus)) } - view"-" { tok (\p s -> Keyword p (KwView Minus)) } - viewdef { tok (\p s -> Keyword p KwViewdef) } - "#"include { tok (\p s -> Keyword p KwInclude) } - when { tok (\p s -> Keyword p KwWhen) } - of { tok (\p s -> Keyword p KwOf) } - ifcase { tok (\p s -> Keyword p KwIfCase) } - stadef { tok (\p s -> Keyword p KwStadef) } - stacst { tok (\p s -> Keyword p KwStacst) } - local { tok (\p s -> Keyword p KwLocal) } - praxi { tok (\p s -> Keyword p KwPraxi) } - while { tok (\p s -> Keyword p KwWhile) } - where { tok (\p s -> Keyword p KwWhere) } - begin { tok (\p s -> Keyword p KwBegin) } - overload { tok (\p s -> Keyword p KwOverload) } - with { tok (\p s -> Keyword p KwWith) } - extern { tok (\p s -> Keyword p KwExtern) } - sortdef { tok (\p s -> Keyword p KwSortdef) } - propdef { tok (\p s -> Keyword p KwPropdef) } - tkindef { tok (\p s -> Keyword p KwTKind) } - typekindef { tok (\p s -> Keyword p KwTKind) } - "$raise" { tok (\p s -> Keyword p KwRaise) } - mod { tok (\p s -> Keyword p KwMod) } - "println!" { tok (\p s -> Identifier p s) } - "prerrln!" { tok (\p s -> Identifier p s) } - "fix@" { tok (\p s -> Keyword p KwFixAt) } - "lam@" { tok (\p s -> Keyword p KwLambdaAt) } - "addr" { tok (\p s -> Keyword p KwAddr) } - "addr@" { tok (\p s -> Keyword p KwAddrAt) } - "view@" { tok (\p s -> Keyword p KwViewAt) } - sta { tok (\p s -> Keyword p KwSta) } - symintr { tok (\p s -> Keyword p KwSymintr) } - absview { tok (\p s -> Keyword p KwAbsview) } - "$list" { tok (\p s -> Keyword p (KwListLit "")) } - "$list_vt" { tok (\p s -> Keyword p (KwListLit "_vt")) } - "fold@" { tok (\p s -> IdentifierSpace p s) } - "free@" { tok (\p s -> Identifier p s) } - @fixity_decl { tok (\p s -> FixityTok p s) } - @double_parens { tok (\p s -> DoubleParenTok p) } - @double_braces { tok (\p s -> DoubleBracesTok p) } - @double_brackets { tok (\p s -> DoubleBracketTok p) } - @char_lit { tok (\p s -> CharTok p (toChar s)) } - @lambda { tok (\p s -> Arrow p s) } - @func_type { tok (\p s -> FuncType p s) } - @time_lit { tok (\p s -> TimeTok p s) } - @integer { tok (\p s -> IntTok p (read s)) } -- FIXME shouldn't fail silenty on overflow - @float { tok (\p s -> FloatTok p (read s)) } - @at_brace { tok (\p s -> Operator p "@{") } -- FIXME this is kinda sloppy - $br / @ref_call { tok (\p s -> SpecialBracket p) } - @operator { tok (\p s -> Operator p s) } - @signature { tok (\p s -> SignatureTok p (tail s)) } - $special { tok (\p s -> Special p s) } - "effmask_all" { tok (\p s -> Identifier p s) } - "effmask_wrt" { tok (\p s -> Identifier p s) } - "extype" { tok (\p s -> Identifier p s) } - @identifier / " " { tok (\p s -> IdentifierSpace p s) } - @identifier { tok (\p s -> Identifier p s) } - @string { tok (\p s -> StringTok p s) } + @block_comment { tok (\p s -> alex $ CommentLex p s) } + "//".* { tok (\p s -> alex $ CommentLex p s) } + "#define".* { tok (\p s -> alex $ MacroBlock p s) } + @if_block { tok (\p s -> alex $ MacroBlock p s) } + @c_block { tok (\p s -> alex $ CBlockLex p s) } + fun { tok (\p s -> alex $ Keyword p KwFun) } + fn { tok (\p s -> alex $ Keyword p KwFn) } + fnx { tok (\p s -> alex $ Keyword p KwFnx) } + and { tok (\p s -> alex $ Keyword p KwAnd) } + prval { tok (\p s -> alex $ Keyword p KwPrval) } + prfn { tok (\p s -> alex $ Keyword p KwPrfn) } + prfun { tok (\p s -> alex $ Keyword p KwPrfun) } + datatype { tok (\p s -> alex $ Keyword p KwDatatype) } + data @view type { tok (\p s -> alex $ Keyword p KwDatavtype) } + @view type { tok (\p s -> alex $ Keyword p (KwVtype None)) } + @view type"+" { tok (\p s -> alex $ Keyword p (KwVtype Plus)) } + @view type"-" { tok (\p s -> alex $ Keyword p (KwVtype Minus)) } + dataview { tok (\p s -> alex $ Keyword p KwDataview) } + dataprop { tok (\p s -> alex $ Keyword p KwDataprop) } + assume { tok (\p s -> alex $ Keyword p KwAssume) } + typedef { tok (\p s -> alex $ Keyword p KwTypedef) } + @view typedef { tok (\p s -> alex $ Keyword p KwVtypedef) } + absprop { tok (\p s -> alex $ Keyword p KwAbsprop) } + llam { tok (\p s -> alex $ Keyword p KwLinearLambda) } + lam { tok (\p s -> alex $ Keyword p KwLambda) } + staload { tok (\p s -> alex $ Keyword p (KwStaload False)) } + "#"staload { tok (\p s -> alex $ Keyword p (KwStaload True)) } + let { tok (\p s -> alex $ Keyword p KwLet) } + in { tok (\p s -> alex $ Keyword p KwIn) } + end { tok (\p s -> alex $ Keyword p KwEnd) } + case"+" { tok (\p s -> alex $ Keyword p (KwCase Plus)) } + case"-" { tok (\p s -> alex $ Keyword p (KwCase Minus)) } + case { tok (\p s -> alex $ Keyword p (KwCase None)) } + castfn { tok (\p s -> alex $ Keyword p KwCastfn) } + val"+" { tok (\p s -> alex $ Keyword p (KwVal Plus)) } + val"-" { tok (\p s -> alex $ Keyword p (KwVal Minus)) } + val { tok (\p s -> alex $ Keyword p (KwVal None)) } + var { tok (\p s -> alex $ Keyword p KwVar) } + if { tok (\p s -> alex $ Keyword p KwIf) } + sif { tok (\p s -> alex $ Keyword p KwSif) } + then { tok (\p s -> alex $ Keyword p KwThen) } + else { tok (\p s -> alex $ Keyword p KwElse) } + implement { tok (\p s -> alex $ Keyword p KwImplement) } + implmnt { tok (\p s -> alex $ Keyword p KwImplement) } + primplmnt { tok (\p s -> alex $ Keyword p KwProofImplement) } + primplement { tok (\p s -> alex $ Keyword p KwProofImplement) } + abst"@"ype { tok (\p s -> alex $ Keyword p (KwAbst0p None)) } + abst"@ype+" { tok (\p s -> alex $ Keyword p (KwAbst0p Plus)) } + abst"@type-" { tok (\p s -> alex $ Keyword p (KwAbst0p Minus)) } + abs@view"t@ype" { tok (\p s -> alex $ Keyword p (KwAbsvt0p None)) } + t"@"ype"+" { tok (\p s -> alex $ Keyword p (KwT0p Plus)) } + t"@"ype"-" { tok (\p s -> alex $ Keyword p (KwT0p Minus)) } + t"@"ype { tok (\p s -> alex $ Keyword p (KwT0p None)) } + @view"t@ype+" { tok (\p s -> alex $ Keyword p (KwVt0p Plus)) } + @view"t@ype-" { tok (\p s -> alex $ Keyword p (KwVt0p Minus)) } + @view"t@ype" { tok (\p s -> alex $ Keyword p (KwVt0p None)) } + abstype { tok (\p s -> alex $ Keyword p KwAbstype) } + abs @view type { tok (\p s -> alex $ Keyword p KwAbsvtype) } + absview { tok (\p s -> alex $ Keyword p KwAbsview) } + view { tok (\p s -> alex $ Keyword p (KwView None)) } + view"+" { tok (\p s -> alex $ Keyword p (KwView Plus)) } + view"-" { tok (\p s -> alex $ Keyword p (KwView Minus)) } + viewdef { tok (\p s -> alex $ Keyword p KwViewdef) } + "#"include { tok (\p s -> alex $ Keyword p KwInclude) } + when { tok (\p s -> alex $ Keyword p KwWhen) } + of { tok (\p s -> alex $ Keyword p KwOf) } + ifcase { tok (\p s -> alex $ Keyword p KwIfCase) } + stadef { tok (\p s -> alex $ Keyword p KwStadef) } + stacst { tok (\p s -> alex $ Keyword p KwStacst) } + local { tok (\p s -> alex $ Keyword p KwLocal) } + praxi { tok (\p s -> alex $ Keyword p KwPraxi) } + while { tok (\p s -> alex $ Keyword p KwWhile) } + where { tok (\p s -> alex $ Keyword p KwWhere) } + begin { tok (\p s -> alex $ Keyword p KwBegin) } + overload { tok (\p s -> alex $ Keyword p KwOverload) } + with { tok (\p s -> alex $ Keyword p KwWith) } + extern { tok (\p s -> alex $ Keyword p KwExtern) } + sortdef { tok (\p s -> alex $ Keyword p KwSortdef) } + propdef { tok (\p s -> alex $ Keyword p KwPropdef) } + tkindef { tok (\p s -> alex $ Keyword p KwTKind) } + typekindef { tok (\p s -> alex $ Keyword p KwTKind) } + "$raise" { tok (\p s -> alex $ Keyword p KwRaise) } + macdef { tok (\p s -> alex $ Keyword p KwMacdef) } + mod { tok (\p s -> alex $ Keyword p KwMod) } + "println!" { tok (\p s -> alex $ Identifier p s) } + "prerrln!" { tok (\p s -> alex $ Identifier p s) } + "fix@" { tok (\p s -> alex $ Keyword p KwFixAt) } + "lam@" { tok (\p s -> alex $ Keyword p KwLambdaAt) } + "addr" { tok (\p s -> alex $ Keyword p KwAddr) } + "addr@" { tok (\p s -> alex $ Keyword p KwAddrAt) } + "view@" { tok (\p s -> alex $ Keyword p KwViewAt) } + sta { tok (\p s -> alex $ Keyword p KwSta) } + symintr { tok (\p s -> alex $ Keyword p KwSymintr) } + absview { tok (\p s -> alex $ Keyword p KwAbsview) } + "$list" { tok (\p s -> alex $ Keyword p (KwListLit "")) } + "$list_vt" { tok (\p s -> alex $ Keyword p (KwListLit "_vt")) } + "fold@" { tok (\p s -> alex $ IdentifierSpace p s) } + "free@" { tok (\p s -> alex $ Identifier p s) } + @fixity_decl { tok (\p s -> alex $ FixityTok p s) } + @double_parens { tok (\p s -> alex $ DoubleParenTok p) } + @double_braces { tok (\p s -> alex $ DoubleBracesTok p) } + @double_brackets { tok (\p s -> alex $ DoubleBracketTok p) } + @char_lit { tok (\p s -> alex $ CharTok p (toChar s)) } + @lambda { tok (\p s -> alex $ Arrow p s) } + @func_type { tok (\p s -> alex $ FuncType p s) } + @time_lit { tok (\p s -> alex $ TimeTok p s) } + @integer { tok (\p s -> alex $ IntTok p (read s)) } -- FIXME shouldn't fail silenty on overflow + @float { tok (\p s -> alex $ FloatTok p (read s)) } + @at_brace { tok (\p s -> alex $ Operator p "@{") } -- FIXME this is kinda sloppy + $br / @ref_call { tok (\p s -> alex $ SpecialBracket p) } + @operator { tok (\p s -> alex $ Operator p s) } + @signature { tok (\p s -> alex $ SignatureTok p (tail s)) } + @builtin { tok (\p s -> alex $ Identifier p s) } + $special { tok (\p s -> alex $ Special p s) } + @identifier / " " { tok (\p s -> alex $ IdentifierSpace p s) } + @identifier { tok (\p s -> alex $ Identifier p s) } + @string { tok (\p s -> alex $ StringTok p s) } { +alex :: a -> Alex a +alex = pure + deriving instance Generic AlexPosn deriving instance NFData AlexPosn deriving instance Data AlexPosn deriving instance Typeable AlexPosn -tok f p s = f p s +tok f (p,_,_,s) len = f p (take len s) -- | Determines the default behavior for incomplete pattern matches data Addendum = None @@ -314,6 +318,7 @@ | KwInfixl | KwStacst | KwListLit String + | KwMacdef deriving (Eq, Show, Generic, NFData) data Token = Identifier AlexPosn String @@ -337,6 +342,7 @@ | DoubleBracketTok AlexPosn | SpecialBracket AlexPosn | FixityTok AlexPosn String + | End deriving (Eq, Show, Generic, NFData) instance Pretty Addendum where @@ -417,6 +423,7 @@ pretty KwInfixr = "infixr" pretty KwInfixl = "infixl" pretty (KwListLit s) = "list" <> string s + pretty KwMacdef = "macdef" instance Pretty Token where pretty (Identifier _ s) = text s @@ -440,6 +447,7 @@ pretty DoubleBracketTok{} = "<>" pretty SpecialBracket{} = "<" pretty (FixityTok _ s) = text s + pretty End = mempty to_string (CommentLex _ s) = s to_string (Identifier _ s) = s @@ -467,6 +475,7 @@ token_posn (DoubleBracketTok p) = p token_posn (SpecialBracket p) = p token_posn (FixityTok p _) = p +token_posn End = undefined toChar :: String -> Char toChar "'\\n'" = '\n' @@ -474,8 +483,17 @@ toChar "'\\\\'" = '\\' toChar x = x !! 1 +alexEOF :: Alex Token +alexEOF = pure End + -- | This function turns a string into a stream of tokens for the parser. lexATS :: String -> [Token] -lexATS = alexScanTokens +lexATS str = either error id . runAlex str $ loop + +loop :: Alex [Token] +loop = do + tok' <- alexMonadScan + if tok' == End then pure [] + else (tok' :) <$> loop } diff --git a/src/Language/ATS/Parser.y b/src/Language/ATS/Parser.y --- a/src/Language/ATS/Parser.y +++ b/src/Language/ATS/Parser.y @@ -105,14 +105,15 @@ timeLit { TimeTok _ $$ } intLit { IntTok _ $$ } floatLit { FloatTok _ $$ } - effmaskWrt { Identifier $$ "effmask_wrt" } - effmaskAll { Identifier $$ "effmask_all" } - effmaskRef { Identifier $$ "effmask_ref" } - extfcall { Identifier $$ "extfcall" } - tempenver { Identifier $$ "tempenver" } - extype { Identifier $$ "extype" } - ldelay { Identifier $$ "ldelay" } - listVT { Identifier $$ "list_vt" } + effmaskWrt { Identifier $$ "$effmask_wrt" } + effmaskAll { Identifier $$ "$effmask_all" } + effmaskRef { Identifier $$ "$effmask_ref" } + extfcall { Identifier $$ "$extfcall" } + tempenver { Identifier $$ "$tempenver" } + extype { Identifier $$ "$extype" } + ldelay { Identifier $$ "$ldelay" } + delay { Identifier $$ "$delay" } + listVT { Identifier $$ "$list_vt" } foldAt { Identifier $$ "fold@" } identifier { $$@Identifier{} } identifierSpace { $$@IdentifierSpace{} } @@ -174,7 +175,7 @@ lspecial { SpecialBracket $$ } atbrace { Operator $$ "@{" } exp { Operator $$ "**" } - stabby { Operator $$ "->>" } + macdef { Keyword $$ KwMacdef } mod { Keyword $$ KwMod } fixAt { Keyword $$ KwFixAt } lamAt { Keyword $$ KwLambdaAt } @@ -331,6 +332,7 @@ | openParen Expression vbar Expression closeParen { ProofExpr $1 $2 $4 } | list_vt lbrace Type rbrace openParen ExpressionIn closeParen { ListLiteral $1 "vt" $3 $6 } | list lbrace Type rbrace openParen ExpressionIn closeParen { ListLiteral $1 "" $3 $6 } -- TODO is this legal?? + | comma openParen identifier closeParen { MacroVar $1 (to_string $3) } | begin Expression extern {% Left $ Expected $3 "end" "extern" } | Expression prfTransform underscore {% Left $ Expected $2 "Rest of expression or declaration" ">>" } @@ -489,7 +491,6 @@ -- | Parse a general name Name : identifier { Unqualified (to_string $1) } | underscore { Unqualified "_" } - | listVT { Unqualified "list_vt" } | foldAt { Unqualified "fold@" } | identifier dollar IdentifierOr { Unqualified (to_string $1 ++ ('$' : $3)) } | identifier dot identifier { FieldName (token_posn $1) (to_string $1) (to_string $3) } @@ -498,14 +499,15 @@ | dollar identifier dot identifier { Qualified $1 (to_string $4) (to_string $2) } | dollar identifier dot identifierSpace { Qualified $1 (to_string $4) (to_string $2) } | dollar identifier dot identifier dollar IdentifierOr { Qualified $1 (to_string $4 ++ ('$' : $6)) (to_string $2) } - | dollar effmaskWrt { SpecialName $1 "effmask_wrt" } - | dollar effmaskAll { SpecialName $1 "effmask_all" } - | dollar effmaskRef { SpecialName $1 "effmask_ref" } - | dollar extfcall { SpecialName $1 "extfcall" } - | dollar tempenver { SpecialName $1 "tempenver" } - | dollar extype { SpecialName $1 "effmask_all" } - | dollar listVT { SpecialName $1 "list_vt" } - | dollar ldelay { SpecialName $1 "ldelay" } -- FIXME there is probably a better way of doing this + | effmaskWrt { SpecialName $1 "effmask_wrt" } + | effmaskAll { SpecialName $1 "effmask_all" } + | effmaskRef { SpecialName $1 "effmask_ref" } + | extfcall { SpecialName $1 "extfcall" } + | tempenver { SpecialName $1 "tempenver" } + | extype { SpecialName $1 "effmask_all" } + | listVT { SpecialName $1 "list_vt" } + | ldelay { SpecialName $1 "ldelay" } -- FIXME there is probably a better way of doing this + | delay { SpecialName $1 "delay" } | dollar {% Left $ Expected $1 "Name" "$" } -- | Parse a list of values in a record @@ -697,7 +699,6 @@ -- FIXME adopt a principled approach Operator : identifierSpace { to_string $1 } | exp { "**" } - | stabby { "->>" } | mutateArrow { "->" } Operators : Operator { [$1] } @@ -725,6 +726,7 @@ | define identifier string { Define ($1 ++ " " ++ to_string $2 ++ $3) } -- FIXME better approach? | define identifierSpace intLit { Define ($1 ++ " " ++ to_string $2 ++ " " ++ show $3) } | cblock { CBlock $1 } + | macdef IdentifierOr openParen IdentifiersIn closeParen eq Expression { MacDecl $1 $2 $4 $7 } | lineComment { Comment (to_string $1) } | staload underscore eq string { Staload (get_staload $1) (Just "_") $4 } | staload string { Staload (get_staload $1) Nothing $2 } diff --git a/src/Language/ATS/PrettyPrint.hs b/src/Language/ATS/PrettyPrint.hs --- a/src/Language/ATS/PrettyPrint.hs +++ b/src/Language/ATS/PrettyPrint.hs @@ -75,21 +75,22 @@ pretty (Full _ v) = "=<" <> text v <> ">" instance Pretty BinOp where - pretty Mult = "*" - pretty Add = "+" - pretty Div = "/" - pretty Sub = "-" - pretty GreaterThan = ">" - pretty LessThan = "<" - pretty Equal = "=" - pretty NotEqual = "!=" - pretty LogicalAnd = "&&" - pretty LogicalOr = "||" - pretty LessThanEq = "<=" - pretty GreaterThanEq = ">=" - pretty StaticEq = "==" - pretty Mod = "%" - pretty NotEq = "<>" + pretty Mult = "*" + pretty Add = "+" + pretty Div = "/" + pretty Sub = "-" + pretty GreaterThan = ">" + pretty LessThan = "<" + pretty Equal = "=" + pretty NotEqual = "!=" + pretty LogicalAnd = "&&" + pretty LogicalOr = "||" + pretty LessThanEq = "<=" + pretty GreaterThanEq = ">=" + pretty StaticEq = "==" + pretty Mod = "%" + pretty NotEq = "<>" + pretty (SpecialInfix s) = text s splits :: BinOp -> Bool splits Mult = True @@ -127,6 +128,10 @@ prettyArgsProof (Just e) = prettyArgsG ("(" <> prettyArgsG mempty mempty (fmap pretty e) <+> "| ") ")" prettyArgsProof Nothing = prettyArgs +instance Pretty UnOp where + pretty Negate = "~" + pretty (SpecialOp s) = text s + instance Pretty Expression where pretty = cata a . rewriteATS where a (IfF e e' (Just e'')) = "if" <+> e <+> "then" <$> indent 2 e' <$> "else" <$> indent 2 e'' @@ -143,12 +148,12 @@ a (FloatLitF f) = pretty f a (StringLitF s) = text s -- FIXME escape indentation in multi-line strings. a (ParenExprF _ e) = parens e + a (UnaryF op e) = pretty op <> pretty e a (BinListF op@Add es) = prettyBinary (pretty op) es a (BinaryF op e e') | splits op = e pretty op <+> e' | otherwise = e <+> pretty op <+> e' a (IndexF _ n e) = pretty n <> "[" <> e <> "]" - a (UnaryF Negate e) = "~" <> e a (NamedValF nam) = pretty nam a (CallF nam [] [] Nothing []) = pretty nam <> "()" a (CallF nam [] [] e xs) = pretty nam <> prettyArgsProof e xs @@ -194,6 +199,7 @@ a (ViewAtF _ e) = "view@" <> e a (ListLiteralF _ s t es) = "list" <> string s <> "{" <> pretty t <> "}" <> prettyArgs es a (CommentExprF c e) = text c <$> e + a (MacroVarF _ s) = ",(" <> text s <> ")" a BinListF{} = undefined -- Shouldn't happen prettyImplicits = mconcat . fmap (prettyArgsU "<" ">") . reverse prettyIfCase [] = mempty @@ -262,7 +268,7 @@ a (StaticBoolF False) = "false" a (SCallF n cs) = pretty n <> parens (mconcat (punctuate "," . reverse . fmap pretty $ cs)) a (SPrecedeF e e') = e <> ";" <+> e' - a (SUnaryF Negate e) = "~" <> e + a (SUnaryF op e) = pretty op <> e a (SLetF _ e e') = flatAlt ("let" <$> indent 2 (pretty ((ATS . reverse) e)) <$> endLet e') ("let" <+> pretty ((ATS . reverse) e) <$> endLet e') @@ -576,4 +582,5 @@ pretty (TKind _ n s) = pretty n <+> "=" <+> text s pretty (SortDef _ s t) = "sortdef" <+> text s <+> "=" <+> either pretty pretty t pretty (AndD d (SortDef _ i t)) = pretty d <+> "and" <+> text i <+> "=" <+> either pretty pretty t + pretty (MacDecl _ n is e) = "macdef" <+> text n <> "(" <> mconcat (punctuate ", " (fmap text is)) <> ") =" <+> pretty e pretty AndD{} = undefined -- probably not valid syntax if we get to this point diff --git a/src/Language/ATS/Types.hs b/src/Language/ATS/Types.hs --- a/src/Language/ATS/Types.hs +++ b/src/Language/ATS/Types.hs @@ -119,6 +119,7 @@ -- uses an 'Int' because you fully deserve what you get if your -- fixity declarations overflow. | FixityDecl Fixity (Either String Int) [String] + | MacDecl AlexPosn String [String] Expression deriving (Show, Eq, Generic, NFData) data DataPropLeaf = DataPropLeaf [Universal] Expression (Maybe Expression) @@ -211,6 +212,7 @@ -- | @~@ is used to negate numbers in ATS data UnOp = Negate + | SpecialOp String deriving (Show, Eq, Generic, NFData) -- | Binary operators on expressions @@ -229,6 +231,7 @@ | StaticEq | Mod | NotEq + | SpecialInfix String deriving (Show, Eq, Generic, NFData) -- FIXME add position information? @@ -305,6 +308,7 @@ | LambdaAt StackFunction | ParenExpr AlexPosn Expression | CommentExpr String Expression + | MacroVar AlexPosn String deriving (Show, Eq, Generic, NFData) -- | An 'implement' declaration