diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for flp + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +The code in floorplan is released under the license below. + +The MIT License (MIT) + +Copyright (c) 2019,2020 Karl Cronburg. All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/LICENSE.language-rust b/LICENSE.language-rust new file mode 100644 --- /dev/null +++ b/LICENSE.language-rust @@ -0,0 +1,30 @@ +Copyright (c) 2016, Alec Theriault + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Alec Theriault nor the names of other + 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 COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,81 @@ +# Floorplan compiler + +A language for specifying the layout of a one-dimensional address space, particularly +for garbage collectors and manual memory managers written in Rust. + +## Building and running + +Floorplan is written in Haskell and must be [built with stack](https://docs.haskellstack.org/en/stable/README/). +Once you have stack installed on your system, you should be able to run the build +command and everything should just work: + +```bash +$ stack build +... +Completed 2 action(s). +``` + +At which point you can compile the file `examples/immix/layout.flp` with +the `build-immix` script: + +```bash +$ ./build-immix +... + Compiling immix_rust v0.0.1 (/home/karl/w/flp/examples/immix) + Finished dev [unoptimized + debuginfo] target(s) in 4.56s +``` + +This script ensures the Floorplan compiler is built, installs it for your current +user, and then builds the Immix project which itself invokes the Floorplan compiler +to build the file `examples/immix/src/heap/layout.flp`. + +In order to run the compiler against some other `.flp` file, the compiler can +be run directly as follows: + +```bash +stack exec flp [path/to/layout.flp] [path/to/generated.rs] +``` + +Note that in order to subsequently build a Rust file generated in this manner, +you must include the `flp-framework` to your Cargo dependencies, and `flp-compiler` +to your cargo build-dependencies. The later is simply a wrapper for calling out +to the (already stack-installed) flp compiler, and the framework crate contains +necessary macros and address types that generated Rust code uses. + +The skeleton of a Rust cargo project is given in the `gen/` directory of this +repo, which can be copied over and modified to support the needs of a memory +manager other than immix-rust. + +## Dependencies + +A customized version of the [language-rust](https://github.com/harpocrates/language-rust) +package is included in the `deps/` directory of this repo, which adds support for +directly splicing of host language expressions into quasiquoted Rust code. This is the +mechanism by which Floorplan generates Rust code. + +## Testing and contributing + +If you want to help maintain or contribute new code to this project, feel free to +make a pull request or better yet start an issue in the the Issues tracker so that +you can get our feedback along the way. A number of avenues for work on the compiler +exist, including but not limited to: + +- More example Rust allocators implemented with a Floorplan layout. +- Rust templates for allocating on alignment boundaries. +- Extensively document the interfaces generated. +- Better error messages. +- Integrating the core semantics (`app/semantics.hs`) directly into the project + `src/` hierarchy. +- Calling out to a SMT library to verify alignment and size constraints. +- Targeting both C and Rust. +- Support for non-64-bit architectures. +- Generating debugging assertions. +- Dynamic tracking of type information for each piece of the heap. +- Cleaning up the dependencies by integrating the Rust splicing support directly + into [the upstream repository](https://github.com/harpocrates/language-rust), + e.g. as a separate quasiquoter. +- Generate cargo-based Rust documentation alongside generated functions, indicating + why a certain function was generated and how it might be used. +- Repairing the Coq proofs in the `proofs/*.v` files. +- Better Rust integration and downstream crates. + diff --git a/app/floorplan.hs b/app/floorplan.hs new file mode 100644 --- /dev/null +++ b/app/floorplan.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +module Main where +import Prelude hiding (putStrLn) +import qualified Prelude as P +import System.Environment +import System.IO hiding (putStr, putStrLn, hGetLine) +import System.Exit (exitSuccess, exitFailure) +import Control.Exception (assert) + +import Language.Rust.Syntax (SourceFile(..)) +import Language.Rust.Data.Position (Span(..)) +import Language.Rust.Pretty (pretty') + +import Language.Floorplan +import qualified Language.Floorplan.Rust.Compiler as RC + +--import qualified Language.Floorplan.Parser as P +import qualified Language.Floorplan.Parser as P +import qualified Language.Floorplan.Syntax as S +import qualified Language.Floorplan.Core.Compiler as CC +import qualified Language.Floorplan.Core.Syntax as CS + +usage = do + pName <- getProgName + P.putStrLn $ pName ++ " [file.flp] [path/to/dest.rs]" + +doResult :: String -> FilePath -> [Demarc] -> IO () +doResult compiler outDir result = do + let grafted :: [S.Demarc] = map (CC.grafting result) result + core_flp :: [CS.BaseExp] = map CC.compile grafted + sf :: SourceFile Span = RC.genRust core_flp + --print $ pretty' sf + assert ((CC.countGrafting grafted) == 0) (return ()) + case compiler of + "rust" -> (RC.writeModule outDir) sf + _ -> usage + exitSuccess + +oops s = P.putStr s >> exitFailure + +main = do + args <- getArgs + case args of + (flpFile : outDir : rst) -> + do contents <- readFile flpFile + let r = P.parseLayers contents + doResult "rust" outDir r + _ -> usage + + diff --git a/app/semantics.hs b/app/semantics.hs new file mode 100644 --- /dev/null +++ b/app/semantics.hs @@ -0,0 +1,177 @@ +import Data.Maybe (fromJust) +import Text.Pretty.Simple (pPrint) +import System.Environment +import System.IO hiding (putStr, putStrLn, hGetLine) +import System.Exit (exitSuccess, exitFailure) +import Control.Exception (assert) + +--import Language.Rust.Syntax (SourceFile(..)) +--import Language.Rust.Data.Position (Span(..)) +--import Language.Rust.Pretty (pretty') +-- +--import Language.Floorplan +--import qualified Language.Floorplan.Parser as P +--import qualified Language.Floorplan.Syntax as S +--import qualified Language.Floorplan.Core.Compiler as CC +--import qualified Language.Floorplan.Core.Syntax as CS + +type LayerID = String +type FormalID = String +type FieldID = String +type FlagID = String + +ex_code :: Demarc +ex_code = Layer "K" ["n"] (Just $ PrimOp (Just $ LitInt 5) BytesTy) Nothing $ + Seq [ Field "hd" $ Count "n" (Size $ PrimOp (Just $ LitInt 1) BytesTy) + , Field "tl" $ Count "n" $ + Seq [ Field "lft" $ Size $ PrimOp (Just $ LitInt 1) BytesTy + , Field "rgt" $ Hash (Size $ PrimOp Nothing BytesTy) + ] + ] + +data DemarcVal = + Hash DemarcVal + | Count FormalID DemarcVal + | Seq [Demarc] + | Union [Demarc] + | Ptr (Either LayerID FieldID) + | Enum [FlagID] + | Bits [BitsExp] + | Size SizeArith + deriving (Eq, Ord, Show) + +type Mag = SizeArith +type Align = SizeArith + +data Demarc = + Field FieldID DemarcVal + | Layer LayerID [FormalID] (Maybe Mag) (Maybe Align) DemarcVal + | DV DemarcVal + deriving (Eq, Ord, Show) + +type BitsExp = (FieldID, SizeArith) + +data PrimTy = BitsTy | BytesTy | WordsTy | PagesTy + deriving (Eq, Ord, Show) + +data SizeArith = + PrimOp (Maybe LitArith) PrimTy + | SizePlus SizeArith SizeArith + | SizeMinus SizeArith SizeArith + deriving (Eq, Ord, Show) + +data LitArith = + LitBin Int + | LitInt Int + | LitPlus LitArith LitArith + | LitMinus LitArith LitArith + | LitTimes LitArith LitArith + | LitDiv LitArith LitArith + | LitExponent LitArith LitArith + deriving (Eq, Ord, Show) + +data Exp = + Plus Exp Exp + | Or Exp Exp + | Prim Int + | Con Int Exp + | HasType String Exp + | Exists String Exp + | Pound String Exp + | Align Exp Int + deriving (Eq, Ord, Show) + +data Tree = + T Tree Tree + | N String Tree + | B0 | B1 + deriving (Eq, Ord, Show) + +-- Compilation rules. TODO: f_0!!! +cV :: DemarcVal -> Exp +cV (Hash dv) = Exists "f_0" (Pound "f_0" (cV dv)) +cV (Count f_0 dv) = Pound f_0 (cV dv) +cV (Seq (d:ds)) = foldl Plus (c d) (map c ds) +cV (Union (d:ds)) = foldl Or (c d) (map c ds) +cV (Ptr id) = Prim 8 +cV (Enum fs) = undefined +cV (Bits bes) = undefined +cV (Size sa) = Prim 1 -- TODO: Prim 1! + +formals :: [FormalID] -> Exp -> Exp +formals (f:fs) e = Exists f (formals fs e) +formals [] e = e + +-- TODO: Con 5! Align error! +c :: Demarc -> Exp +c (Field f dv) = HasType f (cV dv) +c (Layer lid fs Nothing Nothing dv) = HasType lid $ formals fs $ cV dv +c (Layer lid fs (Just mag) Nothing dv) = HasType lid $ formals fs $ Con 5 $ cV dv +c (Layer lid fs Nothing (Just aln) dv) = HasType lid $ formals fs $ Align (cV dv) (error "TODO") +c (Layer lid fs (Just mag) (Just aln) dv) = HasType lid $ formals fs $ Con 5 $ Align (cV dv) (error "TODO") +c (DV dv) = cV dv + +d0 = g 0 5 [] (Prim 5) +d1 = addStep ("Choose m=5") $ g 0 5 [] $ + HasType "K" $ Exists "n" $ Con 5 $ Plus + (HasType "hd" $ Pound "n" $ Prim 1) + $ HasType "tl" $ Pound "n" $ Plus + (HasType "lft" (Prim 1)) + (HasType "rgt" (Exists "f_1" $ Pound "f_1" $ Prim 1)) + +leaves (T t1 t2) = leaves t1 + leaves t2 +leaves (N _ t) = leaves t +leaves B0 = 0 +leaves B1 = 1 + +addStep s xs = map (\(r,d) -> (r, s : d)) xs + +-- Gamma +g p0 p1 p2 p3 = let + g' a m theta (Plus e1 e2) = + let params = \r1 -> (a + leaves r1, m - leaves r1, theta, e2) + in + [ (T r1 r2, ("Plus: i = 0.." ++ show m ++ ", Pause (g " ++ show (params r1) ++ ")") : deriv1 + ++ ["Resume (g " ++ show (params r1) ++ ")" ++ ", leaves r1 = " ++ show (leaves r1)] ++ deriv2) + | (r1, deriv1) <- concat [ addStep ("Plus_r1: Choose i=" ++ show i) $ g a i theta e1 | i <- [0..m]] + , (r2, deriv2) <- addStep ("Plus_r2: leaves(" ++ show e1 ++ ")=" ++ show (leaves r1)) $ g (a + leaves r1) (m - leaves r1) theta e2 + ] + g' a m theta (Or _ _) = error "nope" + g' a m theta (Prim n) + | m == n = [(foldl T B0 (take n $ repeat B1), ["Prim: Evaluate " ++ show n ++ "-leaf tree"])] + | otherwise = [] + g' a m theta (Con n e) + | m == n = addStep ("Con: " ++ show n) (g a m theta e) + | m /= n = [] + g' a m theta (Align e aln) = undefined + g' a m theta (HasType l e) = + [ (N l r, ("HasType: " ++ l) : deriv) + | (r, deriv) <- g a m theta e + ] + g' a m theta (Exists f e) = concat + [ addStep ("Exists: Choose " ++ f ++ "=" ++ show i) + $ g a m ((f, i) : theta) e | i <- [0 .. m] ] + g' a m theta (Pound f e) + | (Just m) == lookup f theta && m == 0 = [(T B0 B0, ["Pound: m = 0"])] + | (Just 0) == lookup f theta = [] + | otherwise = let -- Implies lookup theta f > 0 + params = \r1 -> (a + leaves r1, m - leaves r1, (f, (fromJust $ lookup f theta) - 1) : theta, Pound f e) + in case lookup f theta of + Nothing -> error "Nothing" + Just thetaF -> [ (T r1 r2, ("Pound: theta(" ++ f ++ ")=" ++ show thetaF ++ ", Pause (g " ++ show (params r1)) : deriv1 + ++ ["Resume (g " ++ show (params r1) ++ ")"] ++ deriv2) + | (r1, deriv1) <- concat [addStep ("Pound_r1: Choose i=" ++ show i) $ g a i theta e | i <- [0..m]] + , (r2, deriv2) <- addStep ("Pound_r2: leaves(" ++ show e ++ ")=" ++ show (leaves r1)) $ + g (a + leaves r1) (m - leaves r1) ((f, (fromJust $ lookup f theta) - 1) : theta) (Pound f e) + ] + + addLabel (r, d:ds) = (r, (d ++ "[[g " ++ show (p0, p1, p2, p3) ++ "]] ") : ds) + + in map addLabel (g' p0 p1 p2 p3) + +main = do + args <- getArgs + case args of + (flpFile : rest) -> undefined + _ -> pPrint d1 + diff --git a/examples/app.flp b/examples/app.flp new file mode 100644 --- /dev/null +++ b/examples/app.flp @@ -0,0 +1,8 @@ +// Parser test: nested groups (union and seq) with +// fixed-width fields. + +Block -> union { + A -> seq { a : Cell<$ 0 $>, b : 2 words } + | B -> seq { a : 0 words, c : 2 words } +} + diff --git a/examples/arith.flp b/examples/arith.flp new file mode 100644 --- /dev/null +++ b/examples/arith.flp @@ -0,0 +1,4 @@ +// Parser test + +Arith ||7 bytes|| -> (4 / 2 * 3 + 1) bytes + diff --git a/examples/arith_id.flp b/examples/arith_id.flp new file mode 100644 --- /dev/null +++ b/examples/arith_id.flp @@ -0,0 +1,7 @@ +// Parser test: arithmetic expressions with identifiers + +Block -> union { + A -> seq { a : 0 words, b : n words } + | B -> seq { a : n words, c : k words } +} + diff --git a/examples/arith_power.flp b/examples/arith_power.flp new file mode 100644 --- /dev/null +++ b/examples/arith_power.flp @@ -0,0 +1,7 @@ +// Parser test: exponentiation in arithmetic inside a field. + +Block -> union { + A -> seq { a : 0 words, b : 2^2 words } + | B -> seq { a : 0 words, c : 2^4 words } +} + diff --git a/examples/bits.flp b/examples/bits.flp new file mode 100644 --- /dev/null +++ b/examples/bits.flp @@ -0,0 +1,9 @@ +// Parser test + +RefBits -> bits { + SHORT_ENCODE : 1 bits, + OBJ_START : 1 bits, + REF : 6 bits, + MORE : (2 + 2) bits + 4 bits +} + diff --git a/examples/bump.flp b/examples/bump.flp new file mode 100644 --- /dev/null +++ b/examples/bump.flp @@ -0,0 +1,12 @@ + +Bump ||2^16 bytes|| @(2^16 bytes)@ -> seq { + union { + Partial ||7 * 2^13 bytes|| @(2^13 bytes)@ -> seq { + cells : # Cell, + cursor : # words, + limit : 0 words + } + | # Allocd -> 1 words + } +} + diff --git a/examples/dyn_choice.flp b/examples/dyn_choice.flp new file mode 100644 --- /dev/null +++ b/examples/dyn_choice.flp @@ -0,0 +1,7 @@ +// Parser test: dynamic union of two fixed-width fields. + +Union ||2 bytes|| @(2 bytes)@ -> # union { + a : 1 bytes + | b : 1 bytes +} + diff --git a/examples/dyn_seq.flp b/examples/dyn_seq.flp new file mode 100644 --- /dev/null +++ b/examples/dyn_seq.flp @@ -0,0 +1,7 @@ +// Parser test: dynamic sequence with fixed-width fields. + +Seq ||2 bytes|| @(2 bytes)@ -> # seq { + a : 1 bytes, + b : 1 bytes +} + diff --git a/examples/dynamic_prim.flp b/examples/dynamic_prim.flp new file mode 100644 --- /dev/null +++ b/examples/dynamic_prim.flp @@ -0,0 +1,7 @@ +// Parser test: dynamic primitive in arithmetic + +Seq -> seq { + a : # bytes, + b : 1 bytes +} + diff --git a/examples/empty.flp b/examples/empty.flp new file mode 100644 --- /dev/null +++ b/examples/empty.flp @@ -0,0 +1,6 @@ +// Mostly empty file + +// Ok. + +Foo -> Bar + diff --git a/examples/enum.flp b/examples/enum.flp new file mode 100644 --- /dev/null +++ b/examples/enum.flp @@ -0,0 +1,7 @@ +// Parser test: basic enum + +LineMark -> enum { + Free | Live | FreshAlloc + | ConservLive | PrevLive +} + diff --git a/examples/enum_bad0.flp b/examples/enum_bad0.flp new file mode 100644 --- /dev/null +++ b/examples/enum_bad0.flp @@ -0,0 +1,7 @@ +// Parser test: basic enum failure due to lower-case ID (prevLive) + +LineMark -> enum { + Free | Live | FreshAlloc + | ConservLive | prevLive +} + diff --git a/examples/layer.flp b/examples/layer.flp new file mode 100644 --- /dev/null +++ b/examples/layer.flp @@ -0,0 +1,7 @@ +// Parser test + +Seq -> seq { + Oops -> Bar, + Foo -> Baz ptr +} + diff --git a/examples/map_bits.flp b/examples/map_bits.flp new file mode 100644 --- /dev/null +++ b/examples/map_bits.flp @@ -0,0 +1,7 @@ +// Compiler test: mapping bits to bits code gen + +Foo -> seq { + count bytes, + count Bar ||2 bytes|| -> 2 bytes +} + diff --git a/examples/named_ref.flp b/examples/named_ref.flp new file mode 100644 --- /dev/null +++ b/examples/named_ref.flp @@ -0,0 +1,11 @@ +// Parser test: a named reference to a flp type specified elsewhere + +Seq -> seq { + a : # A, + b : B +} + +A -> 1 words + +B -> 2 bytes + diff --git a/examples/nested.flp b/examples/nested.flp new file mode 100644 --- /dev/null +++ b/examples/nested.flp @@ -0,0 +1,8 @@ +// Parser test: nested groups (union and seq) with +// fixed-width fields. + +Block -> union { + A -> seq { a : 0 words, b : 2 words } + | B -> seq { a : 0 words, c : 2 words } +} + diff --git a/examples/nested_union.flp b/examples/nested_union.flp new file mode 100644 --- /dev/null +++ b/examples/nested_union.flp @@ -0,0 +1,10 @@ +// Parser test: union in various places (both in a flake and in a field) + +Block -> union { + A -> seq { + a : union { 1 words | 1 words } + , b : 2^2 words + } + | B -> seq { a : 0 words, c : (2^4) words } +} + diff --git a/examples/parens.flp b/examples/parens.flp new file mode 100644 --- /dev/null +++ b/examples/parens.flp @@ -0,0 +1,5 @@ + +Bar -> 1 words - 1 bytes + +Foo -> (1 words - 1 bytes) + diff --git a/examples/seq.flp b/examples/seq.flp new file mode 100644 --- /dev/null +++ b/examples/seq.flp @@ -0,0 +1,7 @@ +// Parser test: basic sequence with fixed-width fields. + +Seq -> seq { + a : Oops, + b : Oops ptr +} + diff --git a/examples/union.flp b/examples/union.flp new file mode 100644 --- /dev/null +++ b/examples/union.flp @@ -0,0 +1,7 @@ +// Parser test: basic union test. + +Union -> union { + Oops + | Oops ptr +} + diff --git a/examples/uniq_fail.flp b/examples/uniq_fail.flp new file mode 100644 --- /dev/null +++ b/examples/uniq_fail.flp @@ -0,0 +1,13 @@ + +Outer -> seq { + foo : 1 words, + bar : 2 words, + Inner -> seq { + Outer -> 2 words + } +} + +Other -> seq { + foo : 2 words +} + diff --git a/flp.cabal b/flp.cabal new file mode 100644 --- /dev/null +++ b/flp.cabal @@ -0,0 +1,157 @@ +cabal-version: 1.12 +name: flp +version: 0.1.0.0 +license: MIT +license-file: LICENSE +copyright: 2019 Karl Cronburg +maintainer: karl@cs.tufts.edu +author: Karl Cronburg +homepage: https://github.com/RedlineResearch/floorplan#readme +bug-reports: https://github.com/RedlineResearch/floorplan/issues +synopsis: A layout spec language for memory managers implemented in Rust. +description: + Please see the README on GitHub at +category: Compiler +build-type: Simple +extra-source-files: + README.md + LICENSE + LICENSE.language-rust + ChangeLog.md + examples/app.flp + examples/arith.flp + examples/arith_id.flp + examples/arith_power.flp + examples/bits.flp + examples/bump.flp + examples/dynamic_prim.flp + examples/dyn_choice.flp + examples/dyn_seq.flp + examples/empty.flp + examples/enum_bad0.flp + examples/enum.flp + examples/layer.flp + examples/map_bits.flp + examples/named_ref.flp + examples/nested.flp + examples/nested_union.flp + examples/parens.flp + examples/seq.flp + examples/union.flp + examples/uniq_fail.flp + +source-repository head + type: git + location: https://github.com/RedlineResearch/floorplan + +library + exposed-modules: + Language.Floorplan + Language.Floorplan.Core.Compiler + Language.Floorplan.Core.Syntax + Language.Floorplan.Parser + Language.Floorplan.Rust + Language.Floorplan.Rust.Common + Language.Floorplan.Rust.Compiler + Language.Floorplan.Rust.Mapping + Language.Floorplan.Rust.Types + Language.Floorplan.Semantics + Language.Floorplan.Syntax + Language.Floorplan.Token + Language.Rust.Data.Ident + Language.Rust.Data.InputStream + Language.Rust.Data.Position + Language.Rust.Parser + Language.Rust.Parser.Internal + Language.Rust.Parser.Lexer + Language.Rust.Parser.Literals + Language.Rust.Parser.NonEmpty + Language.Rust.Parser.ParseMonad + Language.Rust.Parser.Reversed + Language.Rust.Pretty + Language.Rust.Pretty.Internal + Language.Rust.Pretty.Literals + Language.Rust.Pretty.Resolve + Language.Rust.Pretty.Util + Language.Rust.Quote + Language.Rust.Syntax + Language.Rust.Syntax.AST + Language.Rust.Syntax.Token + build-tools: alex -any, happy -any + hs-source-dirs: src + other-modules: + Paths_flp + default-language: Haskell2010 + build-depends: + array >=0.5.3.0 && <0.6, + base >=4.7 && <5, + containers >=0.6.0.1 && <0.7, + deepseq >=1.4.4.0 && <1.5, + haskell-src-meta >=0.8.3 && <0.9, + prettyprinter >=1.2.1.1 && <1.3, + template-haskell >=2.14.0.0 && <2.15, + th-lift >=0.8.1 && <0.9, + transformers >=0.5.6.2 && <0.6 + +executable flp + main-is: floorplan.hs + build-tools: alex -any, happy -any + hs-source-dirs: app + other-modules: + Paths_flp + default-language: Haskell2010 + build-depends: + array >=0.5.3.0 && <0.6, + base >=4.7 && <5, + containers >=0.6.0.1 && <0.7, + deepseq >=1.4.4.0 && <1.5, + flp -any, + haskell-src-meta >=0.8.3 && <0.9, + prettyprinter >=1.2.1.1 && <1.3, + template-haskell >=2.14.0.0 && <2.15, + th-lift >=0.8.1 && <0.9, + transformers >=0.5.6.2 && <0.6 + +executable sem + main-is: semantics.hs + build-tools: alex -any, happy -any + hs-source-dirs: app + other-modules: + Paths_flp + default-language: Haskell2010 + build-depends: + array >=0.5.3.0 && <0.6, + base >=4.7 && <5, + containers >=0.6.0.1 && <0.7, + deepseq >=1.4.4.0 && <1.5, + flp -any, + haskell-src-meta >=0.8.3 && <0.9, + pretty-simple >=2.2.0.1 && <2.3, + prettyprinter >=1.2.1.1 && <1.3, + template-haskell >=2.14.0.0 && <2.15, + th-lift >=0.8.1 && <0.9, + transformers >=0.5.6.2 && <0.6 + +test-suite parser + type: exitcode-stdio-1.0 + main-is: Main.hs + build-tools: alex -any, happy -any + hs-source-dirs: test/parser + other-modules: + Paths_flp + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + HUnit ==1.6.*, + array >=0.5.3.0 && <0.6, + base >=4.7 && <5, + containers >=0.6.0.1 && <0.7, + deepseq >=1.4.4.0 && <1.5, + flp -any, + haskell-src-meta >=0.8.3 && <0.9, + prettyprinter >=1.2.1.1 && <1.3, + template-haskell >=2.14.0.0 && <2.15, + test-framework ==0.8.*, + test-framework-hunit ==0.3.*, + th-lift >=0.8.1 && <0.9, + transformers >=0.5.6.2 && <0.6 diff --git a/src/Language/Floorplan.hs b/src/Language/Floorplan.hs new file mode 100644 --- /dev/null +++ b/src/Language/Floorplan.hs @@ -0,0 +1,9 @@ +module Language.Floorplan + ( module Language.Floorplan.Syntax + , module Language.Floorplan.Parser + , module Language.Floorplan.Token + ) where +import Language.Floorplan.Syntax +import Language.Floorplan.Parser +import Language.Floorplan.Token + diff --git a/src/Language/Floorplan/Core/Compiler.hs b/src/Language/Floorplan/Core/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Language/Floorplan/Core/Compiler.hs @@ -0,0 +1,171 @@ +module Language.Floorplan.Core.Compiler where +import Language.Floorplan.Core.Syntax hiding (accum) +import Language.Floorplan.Syntax +import qualified Data.Map.Strict as M +import Data.List (sort) +import Data.Maybe (fromJust, isJust) + +-- | Build the dictionary / map of layer (and field) identifiers to their inner Demarc. +-- Todo: warning when multiple layers have the same name (which one `union` picks is undefined behavior) +buildMap :: Demarc -> M.Map String Demarc +buildMap (Enum{}) = M.empty +buildMap (Bits{}) = M.empty +buildMap (Union ds) = M.unions $ map buildMap ds +buildMap (Seq ds) = M.unions $ map buildMap ds +buildMap (PtrF{}) = M.empty +buildMap (PtrL{}) = M.empty +buildMap (Blob{}) = M.empty +buildMap (Graft{}) = M.empty +buildMap f@(Field name d) = M.insert name d (buildMap d) +buildMap (Pound d) = buildMap d +buildMap (Repetition _ d) = buildMap d +buildMap l@(Layer{}) = M.insert (name l) l (buildMap $ rhs l) + +getNames :: Demarc -> [String] +getNames = let + gN (Field n _) = Just n + gN (Layer { name = n }) = Just n + gN _ = Nothing + in accum gN + +-- | Grafting pre-processing pass +grafting' :: M.Map String Demarc -> Demarc -> Demarc +grafting' ds demarc = let + + lookup lid = + case M.lookup lid ds of + Nothing -> error $ "Undefined symbol '" ++ lid ++ "' during graft pre-processing phase." + Just d -> d + + -- | Bool is whether or not we changed the input value + gr (Graft (lid, args)) = + case lookup lid of + (Field _ d) -> (d, True) + l@(Layer{}) -> (l, True) -- TODO: replace formals with args (no partial application) + gr d = (d, False) + + in case fmapD gr demarc of + (d, True) -> grafting' ds d + (d, False) -> d + +grafting :: [Demarc] -> Demarc -> Demarc +grafting ds demarc = grafting' (M.unions $ map buildMap ds) demarc + +-- | This can be done before or after grafting phase. It checks that every @Layer@ and @Field@ +-- has a globally unique name, reporting an error when the name is not unique. +checkUniqNames :: [Demarc] -> [String] +checkUniqNames ds = + let ns = foldr (\a b -> getNames a ++ b) [] ds + + -- Assumes the input list is already sorted (duplicates are adjacent) + getDups [] = [] + getDups (x:[]) = [] + getDups (x:y:ys) + | x == y = y : getDups (dropWhile (== y) ys) + | otherwise = getDups (y:ys) + + in getDups $ sort ns + +countGrafting :: [Demarc] -> Int +countGrafting = let + fn (Graft{}) = True + fn _ = False + in sum . map (countMatches fn) + +-- | How many bytes are required for an Enum containing the given fields. +-- This computes ceiling(log_2(length(flags)) / 8). +enumBytes :: [FlagID] -> Int +enumBytes fs + | len == 1 = 1 + | otherwise = (bytes 1) + where len = length fs + bytes acc + | len <= acc = 0 + | otherwise = 1 + (bytes (acc * 256)) + +-- | TODO: parametrized delta_prim for architecture-dependent types +delta_prim :: Primitive -> Int +delta_prim Bit = 1 +delta_prim Byte = 8 +delta_prim Word = 8 * (delta_prim Byte) +delta_prim Page = 4096 * (delta_prim Byte) + +pow :: Int -> Int -> Int +pow b e + | e < 0 = error "exponentiation with negative exponent" + | e == 0 && b == 0 = error "indeterminate exponent" + | e == 0 = 1 + | e > 0 = b * (pow b (e - 1)) + +-- | Computes over arithmetic expressions in terms of literals +delta_lit :: LitArith -> Int +delta_lit (Plus l r) = (+) (delta_lit l) (delta_lit r) +delta_lit (Minus l r) = (-) (delta_lit l) (delta_lit r) +delta_lit (Times l r) = (*) (delta_lit l) (delta_lit r) +delta_lit (Div l r) = quot (delta_lit l) (delta_lit r) +delta_lit (Exponent b e) = pow (delta_lit b) (delta_lit e) +delta_lit (Lit l) = l + +-- | Computes number of bits +delta :: SizeArith -> Int +delta (SizePlus l r) = (+) (delta l) (delta r) +delta (SizeMinus l r) = (-) (delta l) (delta r) +delta (SizeLit Nothing p) = delta_prim p +delta (SizeLit (Just lit) p) = (delta_lit lit) * (delta_prim p) + +delta_bits = delta + +bits2bytesUP v + | v == 0 = 0 + | v <= 8 = 1 + | otherwise = 1 + bits2bytesUP (v - 8) + +-- | Rounds up @SizeArith@ to the nearest whole byte. +delta_bytes :: SizeArith -> Int +delta_bytes sz = bits2bytesUP (delta sz) + +fresh :: Demarc -> FormalID +fresh d = head (dropWhile (flip elem $ free_vars d) $ map (("var_" ++) . show) [0..]) + +compile :: Demarc -> BaseExp +compile (Enum fs) = Attr (BaseType $ EnumBT fs) (Prim $ enumBytes fs) +compile (Bits fs) = let fs' = zip (map fst fs) $ map (delta_bits . snd) fs + in Attr (BaseType $ BitsBT fs') (Prim $ bits2bytesUP $ sum $ map snd fs') +compile (Union []) = Prim 0 +compile (Union (d:ds)) = foldl (:||) (compile d) $ map compile ds +compile (Seq []) = Prim 0 +compile (Seq (d:ds)) = foldl (:+) (compile d) $ map compile ds +compile (PtrF field) = Attr (BaseType $ PtrBT field) $ compile (Blob $ SizeLit Nothing Word) +compile (PtrL layer) = Attr (BaseType $ PtrBT layer) $ compile (Blob $ SizeLit Nothing Word) +compile (Blob sz) = Attr (BaseType $ SizeBT sz) $ Prim $ delta_bytes sz +compile (Field f d) = (:::) f (compile d) +compile (Pound d) = let f = fresh d + in Exists f $ f :# (compile d) +compile (Repetition f d) = f :# (compile d) +compile l@(Layer + { name = n + , formals = fs + , magnitude = m + , alignment = a + , magAlign = ma + , contains = cs + , rhs = d + }) = n ::: (exists $ mag $ align $ contains $ compile d) + where exists :: BaseExp -> BaseExp + exists e + | null fs = e + | otherwise = foldr Exists (Exists (head fs) e) (tail fs) + mag + | isJust m = Con (delta_bytes $ fromJust m) + | isJust ma = Con (delta_bytes $ fromJust ma) + | otherwise = id + align + | isJust a = (flip (:@)) (delta_bytes $ fromJust a) + | isJust ma = (flip (:@)) (delta_bytes $ fromJust ma) + | otherwise = id + contains :: BaseExp -> BaseExp + contains e + | null cs = e + | otherwise = foldr Attr (Attr (Contains $ head cs) e) (map Contains $ tail cs) +compile (Graft _) = error "Grafting is illegal during the compile phase." + diff --git a/src/Language/Floorplan/Core/Syntax.hs b/src/Language/Floorplan/Core/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/Floorplan/Core/Syntax.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Language.Floorplan.Core.Syntax where + +import Data.Maybe (maybeToList) + +import Language.Floorplan.Syntax (LayerID, FormalID, FlagID, FieldID, SizeArith(..)) + +type Nat = Int -- >= 0 +type Align = Int -- >= 1 + +type ExistsID = String -- ^ Formal identifiers (bound by Exists) +type NameID = String -- ^ Names of bound layers and fields + +data Exp a + = Prim Nat -- ^ Primitive number of bytes + | Con Nat (Exp a) -- ^ Constrained + | (:@) (Exp a) Align -- ^ Alignment + | (:+) (Exp a) (Exp a) -- ^ Sequencing + | (:||) (Exp a) (Exp a) -- ^ Union / alternation + | (:::) NameID (Exp a) -- ^ Layer (and field) name binding + | Exists ExistsID (Exp a) -- ^ Formal name binding + | (:#) ExistsID (Exp a) -- ^ Repetitions + | Attr a (Exp a) -- ^ Extensible attributes + deriving (Eq, Ord, Show) + +data Attribute ty + = Contains NameID + | BaseType ty + deriving (Eq, Ord, Show) + +data BaseType + = EnumBT [FlagID] + | BitsBT [(NameID, Int)] + | PtrBT NameID + | SizeBT SizeArith + deriving (Eq, Ord, Show) + +-- | Default core expression type for FLP compiler targeting Rust library +-- (with contains(...) attibutes): +type BaseExp = Exp (Attribute BaseType) + +-- | Accumulate the results of applying some function to +-- every node in the Exp AST. +accum :: (Exp a -> Maybe b) -> Exp a -> [b] +accum fn e@(Prim{}) = maybeToList (fn e) +accum fn e1@(Con _ e2) = maybeToList (fn e1) ++ accum fn e2 +accum fn e1@(e2 :@ _) = maybeToList (fn e1) ++ accum fn e2 +accum fn e1@(e2 :+ e3) = maybeToList (fn e1) ++ accum fn e2 ++ accum fn e3 +accum fn e1@(e2 :|| e3) = maybeToList (fn e1) ++ accum fn e2 ++ accum fn e3 +accum fn e1@(_ ::: e2) = maybeToList (fn e1) ++ accum fn e2 +accum fn e1@(Exists _ e2) = maybeToList (fn e1) ++ accum fn e2 +accum fn e1@(_ :# e2) = maybeToList (fn e1) ++ accum fn e2 +accum fn e1@(Attr _ e2) = maybeToList (fn e1) ++ accum fn e2 + +-- | Call the given function on all subexpressions. Good for fixedpoint +-- functions calling on themselves in recursive case where they don't +-- care which type they see. This is slightly dangerous in the case where +-- something gets added to the core calculus. If this happens, PLEASE +-- check all callers of this function to see if they should handle the +-- new case personally. +callSub :: (Exp a -> [b]) -> Exp a -> [b] +callSub fn (Prim{}) = [] +callSub fn (Con _ e) = fn e +callSub fn (e :@ _) = fn e +callSub fn (e1 :+ e2) = fn e1 ++ fn e2 +callSub fn (e1 :|| e2) = fn e1 ++ fn e2 +callSub fn (_ ::: e) = fn e +callSub fn (Exists _ e) = fn e +callSub fn (_ :# e) = fn e +callSub fn (Attr _ e) = fn e + +plus :: Maybe Int -> Maybe Int -> Maybe Int +plus a b = do + a' <- a + b' <- b + return $ a' + b' + +-- | Conservatively computes the size of the given expression, +-- returning Nothing when a fixed size isn't easily known. +expSize :: Exp a -> Maybe Int +expSize (Prim n) = return n +expSize (Con n _) = return n +expSize (e :@ _) = expSize e +expSize (e1 :+ e2) = expSize e1 `plus` expSize e2 +expSize (e1 :|| e2) = + let s1 = expSize e1 + s2 = expSize e2 + in if s1 == s2 then s1 else Nothing +expSize (_ ::: e) = expSize e +expSize (Exists _ e) = expSize e +expSize (_ :# _) = Nothing -- Conservative assumption +expSize (Attr _ e) = expSize e + +-- | Just like @accum@, but also tracks the number of bytes of memory +-- that come before the subexpression for which we call the fncn. +l2r :: forall a b. (Maybe Nat -> Exp a -> Maybe b) -> Exp a -> [b] +l2r fn e' = let + + mTL :: Maybe Nat -> Exp a -> [b] + mTL i = maybeToList . fn i + + lr :: Maybe Nat -> Exp a -> [b] + lr i e@(Prim{}) = mTL i e + lr i e1@(Con _ e2) = mTL i e1 ++ lr i e2 + lr i e1@(e2 :@ _) = mTL i e1 ++ lr i e2 + lr i e1@(e2 :+ e3) = mTL i e1 ++ (lr i e2 ++ lr (i `plus` expSize e2) e3) + lr i e1@(e2 :|| e3) = mTL i e1 ++ (lr i e2 ++ lr i e3) + lr i e1@(_ ::: e2) = mTL i e1 ++ lr i e2 + lr i e1@(Exists _ e2) = mTL i e1 ++ lr i e2 + lr i e1@(_ :# e2) = mTL i e1 ++ lr Nothing e2 + lr i e1@(Attr _ e2) = mTL i e1 ++ lr i e2 + + in lr (Just 0) e' + diff --git a/src/Language/Floorplan/Parser.y b/src/Language/Floorplan/Parser.y new file mode 100644 --- /dev/null +++ b/src/Language/Floorplan/Parser.y @@ -0,0 +1,188 @@ +{ +module Language.Floorplan.Parser where + +import Language.Floorplan.Syntax +import Language.Floorplan.Token +} + +%name layers +%tokentype { Token } +%error { parseError } + +%token + seq { TokenSeq } + union { TokenUnion } + 'contains' { TokenContains } + bits { TokenBits } + bytes { TokenBytes } + words { TokenWords } + pages { TokenPages } + 'ptr' { TokenPtr } + enum { TokenEnum } + '->' { TokenArrow } + '@(' { TokenAtParen } + ')@' { TokenParenAt } + '@|' { TokenAtBar } + '|@' { TokenBarAt } + '(' { TokenLParen } + ')' { TokenRParen } + '<' { TokenLess } + '>' { TokenGreater } + '<$' { TokenLessD } + '$>' { TokenGreaterD } + '|' { TokenBar } + '||' { TokenBarBar } + '{' { TokenLCurl } + '}' { TokenRCurl } + '#' { TokenPound } + ':' { TokenColon } + ',' { TokenComma } + '+' { TokenPlus } + '-' { TokenMinus } + '*' { TokenTimes } + '/' { TokenDiv } + '^' { TokenExponent } + literal { TokenNum $$ } + UpperID { TokenUpperID $$ } + LowerID { TokenLowerID $$ } + +-- %left '+' '-' +-- %left '*' '/' +-- %left '^' +%% + +{- ------------------------------------------------------------------------- -} +{- Floorplan layers -} + +layers : {- empty -} { [] } + | layers layer { $2 : $1 } + +layerID : UpperID { $1 } +fieldID : LowerID { $1 } +formalID : LowerID { $1 } +flagID : UpperID { $1 } + +layer : layerSimple { $1 } + | '(' layerSimple ')' { $2 } + +layerSimple : layerID formals mag align contains '->' demarc { Layer $1 $2 $3 $4 Nothing $5 $7 } + | layerID formals align mag contains '->' demarc { Layer $1 $2 $4 $3 Nothing $5 $7 } + | layerID formals magAlign contains '->' demarc { Layer $1 $2 Nothing Nothing $3 $4 $6 } + | layerID formals mag contains '->' demarc { Layer $1 $2 $3 Nothing Nothing $4 $6 } + | layerID formals align contains '->' demarc { Layer $1 $2 Nothing $3 Nothing $4 $6 } + | layerID formals contains '->' demarc { Layer $1 $2 Nothing Nothing Nothing $3 $5 } + +mag : '||' sizeArith '||' { Just $2 } + +align : '@(' sizeArith ')@' { Just $2 } + +magAlign : '@|' sizeArith '|@' { Just $2 } + +contains : {- empty -} { [] } + | contains 'contains' '(' layerID ')' { $4 : $1 } + +formals : {- empty -} { [] } + | '<' formalsInner '>' { reverse $2 } + | '<' formalsInner ',' '>' { reverse $2 } + +formalsInner : formalID { [$1] } + | formalsInner ',' formalID { $3 : $1 } + +{- ------------------------------------------------------------------------- -} + +demarcVal : enum '{' enumExps '}' { Enum (reverse $3) } + | enum '{' enumExps '|' '}' { Enum (reverse $3) } + | bits '{' bitsExps '}' { Bits (reverse $3) } + | bits '{' bitsExps ',' '}' { Bits (reverse $3) } + | union '{' unionExps '}' { Union (reverse $3) } + | union '{' unionExps '|' '}' { Union (reverse $3) } + | seq '{' seqExps '}' { Seq (reverse $3) } + | seq '{' seqExps ',' '}' { Seq (reverse $3) } + | sizeArith { Blob $1 } + | grafting { Graft $1 } + | ptr { $1 } + | field { $1 } + | layer { $1 } + +seqExps : demarc { [$1] } + | seqExps ',' demarc { $3 : $1 } + +unionExps : demarc { [$1] } + | unionExps '|' demarc { $3 : $1 } + +demarc : '#' demarcVal { Pound $2 } + | demarcVal { $1 } + | formalID demarcVal { Repetition $1 $2 } + +field : fieldID ':' demarc { Field $1 $3 } + +ptr : layerID 'ptr' { PtrL $1 } + | fieldID 'ptr' { PtrF $1 } + +grafting : layerID '<$' args '$>' { ($1, reverse $3) } + | layerID '<$' args ',' '$>' { ($1, reverse $3) } + | layerID { ($1, []) } + +args : formalID { [ArgF $1] } + | literal { [ArgL $1] } + | args ',' formalID { (ArgF $3) : $1 } + | args ',' literal { (ArgL $3) : $1 } + +-- formalOrLiteral { [$1] } +-- | args ',' formalOrLiteral { $3 : $1 } +-- +--formalOrLiteral : formalID { ArgF $1 } +-- | literal { ArgL $1 } + +enumExps : flagID { [$1] } + | enumExps '|' flagID { $3 : $1 } + +bitsExps : bitsExp { [$1] } + | bitsExps ',' bitsExp { $3 : $1 } + +bitsExp : flagID ':' sizeArith { ($1, $3) } + +{- ------------------------------------------------------------------------- -} + +sizePrim : prim { $1 } + | archPrim { $1 } + +prim : bits { Bit } + | bytes { Byte } + +archPrim : words { Word } + | pages { Page } + +litArith : litArith '+' term { Plus $1 $3 } + | litArith '-' term { Minus $1 $3 } + | term { $1 } + +term : term '*' factor { Times $1 $3 } + | term '/' factor { Div $1 $3 } + | factor { $1 } + +factor : factor '^' exponent { Exponent $1 $3 } + | exponent { $1 } + +exponent : '(' litArith ')' { $2 } + | literal { Lit $1 } + +sizeArith : '(' sizeArith ')' { $2 } + | sizeArith '+' termSz { SizePlus $1 $3 } + | sizeArith '-' termSz { SizeMinus $1 $3 } + | termSz { $1} + +termSz : litArith sizePrim { SizeLit (Just $1) $2 } + | sizePrim { SizeLit Nothing $1 } + +{- ------------------------------------------------------------------------- -} + +{ + +parseError :: [Token] -> a +parseError xs = error $ "Parse error with remaining input: " ++ show xs + +parseLayers :: String -> [Demarc] +parseLayers = reverse . layers . scanTokens +} + diff --git a/src/Language/Floorplan/Rust.hs b/src/Language/Floorplan/Rust.hs new file mode 100644 --- /dev/null +++ b/src/Language/Floorplan/Rust.hs @@ -0,0 +1,5 @@ +module Language.Floorplan.Rust + ( module Language.Floorplan.Rust.Compiler + ) where +import Language.Floorplan.Rust.Compiler + diff --git a/src/Language/Floorplan/Rust/Common.hs b/src/Language/Floorplan/Rust/Common.hs new file mode 100644 --- /dev/null +++ b/src/Language/Floorplan/Rust/Common.hs @@ -0,0 +1,170 @@ +module Language.Floorplan.Rust.Common + where +{- Functions and names applicable to all code gen phases / passes + -} + +import Language.Rust.Parser as P +import Language.Rust.Syntax as R +import Language.Rust.Quote +import Language.Rust.Data.Ident +import Language.Rust.Data.Position + +import Language.Floorplan.Core.Syntax + +import Data.Functor ( ($>) ) +import Data.Ord (comparing) +import Data.List (sortBy, nub) +import Data.Char (toUpper, toLower) + +import Language.Floorplan.Rust.Types +import qualified Debug.Trace as D + +bytesInWord :: Int +bytesInWord = 8 + +bitsInByte :: Int +bitsInByte = 8 + +isPow2 k = elem k $ map (2 ^) [0..k] + +-- | Log base `i` of `n` rounded up. +log' :: Int -> Int -> Int +log' i n = length (takeWhile (< n) (iterate (* 2) 1)) + +log2 :: Int -> Int +log2 = log' 2 + +-- TODO: Introduce spans based on position in these Haskell files. +fakeSpan = Span (Position 0 0 0) (Position 0 0 0) +fS = fakeSpan + +-- TODO: put Language.Rust.* accessors in their own module: +-- | Makes a Rust expression of from an integer +mkIntExp :: Int -> R.Expr Span +mkIntExp i = P.parse' $ P.inputStreamFromString $ show i + +mkBin' i + | i == 0 = [] + | i `mod` 2 == 0 = '0' : mkBin' (i `div` 2) + | i `mod` 2 == 1 = '1' : mkBin' (i `div` 2) + +mkBinU8 i + | i >= 256 = error $ "Cannot make u8 from i=" ++ show i + | otherwise = take (8 - (length $ mkBin' i)) (repeat '0') ++ (reverse $ mkBin' i) + +mkBinExp :: Int -> R.Expr Span +mkBinExp i = P.parse' $ P.inputStreamFromString $ "0b" ++ mkBinU8 i + +offsetName :: NameID -> String +offsetName n + = allUpper n ++ "_OFFSET_BYTES" + +containsFnName :: NameID -> String +containsFnName ns + = "contains_" ++ firstLower ns + +firstLower [] = error "empty NameID!" +firstLower (n:ns) = toLower n : ns + +firstUpper [] = error "empty NameID!" +firstUpper (n:ns) = toUpper n : ns + +allUpper = map toUpper + +initSeqName :: [NameID] -> String +initSeqName _ = "init_canonical_sequence" + +bumpAllocName :: NameID -> String +bumpAllocName n + = "bump_new_" ++ n + +bumpValidName :: NameID -> NameID -> String +bumpValidName n1 n2 + = firstLower n1 ++ "_is_validly_before_" ++ firstLower n2 + +initAfterName :: NameID -> NameID -> String +initAfterName n1 n2 + = "init_" ++ firstLower n2 ++ "_after_" ++ firstLower n1 + +memsetUntilName :: NameID -> NameID -> String +memsetUntilName n1 n2 + = "memset_" ++ firstLower n1 ++ "_until_" ++ firstLower n2 + +castFromName :: NameID -> NameID -> String +castFromName from to + = "cast_" ++ firstLower from ++ "_to_" ++ firstLower to + +fromIdxName :: NameID -> String +fromIdxName from + = firstLower from ++ "_from_idx" + +toIdxName :: NameID -> String +toIdxName from + = firstLower from ++ "_to_idx" + +logBytesName :: NameID -> String +logBytesName n + = "LOG_" ++ bytesName n + +bytesName :: NameID -> String +bytesName n + = "BYTES_IN_" ++ allUpper n + +-- | All named entities get an addrName: +addrName xs = firstUpper xs ++ "Addr" + +addrEndName n = firstUpper n ++ "AddrEnd" + +enumName xs = "__FLP_IDX_" ++ map toUpper xs + +-- | Only for (known to be) fixed-width things: +structName xs = firstUpper xs -- ++ "Struct" + +getterName xs = firstLower xs + +reverseGetterName xs = "from_" ++ firstLower xs + +skipperName ns = "skip_bytes_to_" ++ firstUpper ns + +jumperName ns = "jump_to_" ++ firstUpper ns + +nextName ns = "next_" ++ firstUpper ns + +bitsGetterName sz xs + | sz == 1 = "get_" ++ xs ++ "_bit" + | otherwise = "get_" ++ xs ++ "_bits" + +bitsFromerName _ [] = error "empty NameID!" +bitsFromerName sz (x:xs) + | sz == 1 = "set_" ++ x : xs ++ "_from_bool" + | otherwise = "set_" ++ x : xs ++ "_from_u8" + +firstGetterName xs = "get_first_" ++ firstLower xs + +mkTy :: NameID -> Ty Span +mkTy s = P.parse' $ P.inputStreamFromString s + +bytesAlignName n = allUpper n ++ "_BYTES_ALIGN" + +logAlignName n = allUpper n ++ "_LOG_BYTES_ALIGN" + +fieldPtrGetterName fs = "load_" ++ firstUpper fs ++ "Addr" +fieldPtrSetterName fs = "store_" ++ firstUpper fs ++ "Addr" + +fieldStructGetterName fs = "load_" ++ firstUpper fs +fieldStructSetterName fs = "store_" ++ firstUpper fs + +-- | Determine all existential-bound names brought into +-- scope by this expression. Alignment and Constrained +-- can be traversed because only a ":#" can refer to names. +findExists :: BaseExp -> [BaseExp] +findExists (Prim{}) = [] +findExists (Con _ e) = findExists e +findExists (e :@ _) = findExists e +findExists (_ :+ _) = [] +findExists (_ :|| _) = [] +findExists (_ ::: _) = [] +findExists e@(Exists _ e') = e : findExists e' +findExists (_ :# _) = [] +findExists (Attr _ e) = findExists e + diff --git a/src/Language/Floorplan/Rust/Compiler.hs b/src/Language/Floorplan/Rust/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Language/Floorplan/Rust/Compiler.hs @@ -0,0 +1,908 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, BangPatterns #-} +module Language.Floorplan.Rust.Compiler + ( genRust, writeModule + ) where + +import System.IO (IOMode(..), openFile, hClose) +import Data.Typeable (Typeable(..)) + +import Language.Rust.Parser as P +import Language.Rust.Syntax as R +import Language.Rust.Quote +import Language.Rust.Data.Ident +import Language.Rust.Data.Position + +import Language.Floorplan.Core.Syntax + +import Data.Bifunctor ( bimap ) +import Data.Functor ( ($>) ) +import Data.Ord (comparing) +import Data.List (sortBy, nub, inits) +import Data.Char (toUpper, toLower) +import Data.Maybe (isJust, fromMaybe) +import Data.Bits +import qualified Debug.Trace as D + +import Language.Rust.Pretty (writeSourceFile) +import Language.Floorplan.Rust.Types +import Language.Floorplan.Rust.Mapping +import Language.Floorplan.Rust.Common +import Language.Floorplan.Syntax(SizeArith(..), Primitive(..), FlagID(..)) + +moduleToItems :: RustItem -> [Item Span] +moduleToItems (RustImpl n is outer_is) = + nub outer_is ++ + [ Impl [] InheritedV Final Normal Positive + (Generics [] [] (WhereClause [] fS) fS) Nothing (mkTy n) (nub is) fS + ] +moduleToItems (TopLevel is) = is + +--(mkIdent n) (Just $ nub is) fakeSpan + +-- | TODO: modules with same name should be merged into one. +mergeImpls :: [RustItem] -> [Item Span] +mergeImpls ms = let + + merge [] = [] + merge (x:[]) = [x] + merge (x@(RustImpl xN xIS xOuter):y@(RustImpl yN yIS yOuter):ys) + | xN == yN = merge $ (RustImpl xN (xIS ++ yIS) (xOuter ++ yOuter)) : ys + | otherwise = x : merge (y:ys) + merge (x@(TopLevel ns):y@(TopLevel ns'):ys) = + merge $ (TopLevel $ ns ++ ns') : ys + merge (x:y:ys) = x : merge (y : ys) + + in concatMap moduleToItems $ merge $ sortBy (comparing rustItemComparator) ms + +genRust :: [BaseExp] -> SourceFile Span +genRust bes = + SourceFile Nothing headerAttrs $ + headerItems + ++ genFixedWidthStructs bes + ++ (mergeImpls $ + genStaticOffsets bes + ++ genEnumAll' bes + ++ genFieldPtrGetters bes + ++ genMaps bes + ++ genContainsMethods bes + ++ genGetFirstMethods bes + ++ genBitsAccessors bes + ++ genDynamicSkippers bes + ++ genAddrAddr bes + ++ genNeighborParents bes + ++ genDistributeContainsAttr bes + ++ genEnumAccessors bes + ++ genShadowAlloc bes + ++ genStoreWord bes + -- TODO: Check whether a RemainderAddr occurs *after* a LimitAddr, i.e. when the LHS + -- of two sequential named fields occurs at an address greater than the address of + -- the thing on the RHS, it's clearly malformed (i.e. the RTS speculatively made + -- a new address, but realized that it's not allowed - TODO: eventually want some + -- way to enforce, e.g. with types, the developer turns a "Speculative" address + -- into a "Real" one, and that speculative addresses get generated for methods here + -- that can't know for sure they'll produce pointers to valid things, but that + -- can be "marked" as valid by doing a check). + ) + +-- | Must return a nonempty list +findAlignment :: BaseExp -> [Int] +findAlignment (Prim{}) = [1] +findAlignment (Con _ e) = findAlignment e +findAlignment (_ :@ align) = [align] +findAlignment (e :+ _) = findAlignment e -- Alignment of first thing +findAlignment (e1 :|| e2) = + let a1 = findAlignment e1 + a2 = findAlignment e2 + in a1 ++ a2 +findAlignment (_ ::: e) = findAlignment e +findAlignment (Exists _ e) = findAlignment e +findAlignment (_ :# e) = findAlignment e -- Alignment of first repetition +findAlignment (Attr _ e) = findAlignment e + +-- | Generate the items associated with an Impl, as necessary for +-- making a new e.g. `FooAddr` type. +genAssocItems :: NameID -> BaseExp -> [Item Span] +genAssocItems n e = + let nAddr = addrName n + nAddrEnd = addrEndName n + -- TODO: Alignment should conservatively be a list, not just the smallest one found + -- (to detect alignment errors from a pointer as precisely as possible, + -- though non-power-of-two alignments are rare / uncommon, so choosing + -- the smallest one is likely sufficient for most use cases): + bytesAlign = bytesAlignName n + + sz = expSize e + (Just sz') = expSize e + + bytes = [items| pub const ${i| bytesName n |} : usize = ${e| mkIntExp sz' |}; |] + + consAlign = foldl mini 0 $ findAlignment e + + alignConst = [items| pub const $bytesAlign : usize = 1 << ${i| logAlignName n |}; // ${e| mkIntExp consAlign |}; |] + alignConst' = [items| pub const $bytesAlign : usize = ${e| mkIntExp consAlign |}; |] + + logAlign + | isPow2 consAlign = [items| pub const ${i| logAlignName n |} : usize = ${e| mkIntExp $ log2 consAlign |}; |] ++ alignConst + | otherwise = alignConst' + + logBytes + | isJust sz && isPow2 sz' = + bytes + ++ [items| pub const ${i| logBytesName n |} : usize = ${e| mkIntExp $ log2 sz' |}; + |] + | isJust sz = bytes + | otherwise = [] + + -- | Ignore the zero + mini x 0 = x + mini 0 x = x + mini x y = min x y + + in logAlign ++ + [items| #[repr (C)] + #[derive(Copy, Clone, Eq, Hash)] + pub struct $nAddr(usize); + deriveAddr!($nAddr, $bytesAlign); + + #[repr (C)] + #[derive(Copy, Clone, Eq, Hash)] + pub struct $nAddrEnd(usize); + deriveAddr!($nAddrEnd, 1); + |] ++ logBytes + +genEnumAll :: (Int, (NameID, BaseExp)) -> RustItem +genEnumAll (i, (n, e)) = + let nEnum = enumName n + in RustImpl (addrName n) [] + [items| pub const $nEnum : u8 = ${e| mkIntExp i |}; + |] + +mkNameStringExp :: (NameID, BaseExp) -> Expr Span +mkNameStringExp (n, _) = Lit [] (Str (allUpper n) Cooked Unsuffixed fakeSpan) fakeSpan + +genFLPArray :: [(NameID, BaseExp)] -> RustItem +genFLPArray nes = TopLevel + [items| pub const __FLP_IDX_UNMAPPED : u8 = 0; + pub const __FLP_TYPES: &'static [&'static str] = & ${e| Vec [] + (mkNameStringExp ("UNMAPPED", undefined) : map mkNameStringExp nes) fakeSpan |}; |] + +genStoreWord :: [BaseExp] -> [RustItem] +genStoreWord bes = let + gSW :: BaseExp -> Maybe RustItem + gSW (n ::: e) = do + sz <- expSize e + if sz == bytesInWord then return + (RustImpl (addrName n) + (snd [implItems| + pub fn store_word(&self, val: usize) { + self.store::(val); + } + |]) + []) + else Nothing + gSW rest = Nothing + + genStoreStruct :: BaseExp -> Maybe RustItem + genStoreStruct (n ::: e) = do + sz <- expSize e + let sN = structName n + let store_struct = fieldStructSetterName n + let load_struct = fieldStructGetterName n + return (RustImpl (addrName n) + (snd [implItems| + pub fn $store_struct(&self, val: $sN) { + self.store::<$sN>(val); + } + pub fn $load_struct(&self) -> $sN { + self.load::<$sN>() + } |]) []) + genStoreStruct _ = Nothing + in concatMap (accum genStoreStruct) bes ++ concatMap (accum gSW) bes + +genEnumAll' :: [BaseExp] -> [RustItem] +genEnumAll' bes = + let findNames :: BaseExp -> Maybe (NameID, BaseExp) + findNames (n ::: e) = Just (n, e) + findNames _ = Nothing + in genFLPArray (nub $ concatMap (accum findNames) bes) + : map genEnumAll (zip [1 :: Int .. ] (nub $ concatMap (accum findNames) bes)) + +-- [Item ()] +genStaticOffsets :: [BaseExp] -> [RustItem] +genStaticOffsets bes = + let + --(NameID, [ImplItem Span]) + findSO :: BaseExp -> Maybe RustItem + findSO (n ::: e2) = Just $ RustImpl (addrName n) (concat $ l2r (mkN n) e2) (genAssocItems n e2) + findSO _ = Nothing + + -- Finds all "neighboring" named subexpressions that are a static + -- distance from the beginning of the subexpression. + mkN :: NameID -> Maybe Nat -> BaseExp -> Maybe [ImplItem Span] + mkN _ Nothing _ = Nothing + mkN nOuter (Just k) (n ::: _) = Just $ + let aN = addrName n + oN = offsetName n + gN = getterName n + rev_gN = reverseGetterName n + aNOuter = addrName nOuter in + -- TODO: [items| |] quasiquoter for multiple items + snd [implItems| + pub const ${i|oN|}: usize = ${e| mkIntExp k |}; + pub fn $gN(&self) -> $aN { + self.plus::<$aN>($aNOuter :: $oN) + } + pub fn $rev_gN(addr: $aN) -> $aNOuter { + addr.sub::<$aNOuter>($aNOuter :: $oN) + } + |] + --[item| const FOO: usize = 22; |] + mkN _ _ _ = Nothing + + in concatMap (accum findSO) bes + +genFieldPtrGetters :: [BaseExp] -> [RustItem] +genFieldPtrGetters bes = let + + findFieldPtr :: BaseExp -> Maybe RustItem + findFieldPtr (n ::: (Attr (BaseType (PtrBT field)) blob)) = + let aN = addrName n + get_field = fieldPtrGetterName field + set_field = fieldPtrSetterName field + newAddr = addrName field in + Just $ RustImpl (addrName n) + (snd $ [implItems| + pub fn $get_field(self) -> $newAddr { + let ret = self.load::<$newAddr>(); + //backtraceHere!(ret); + ret + } + pub fn $set_field(self, val : $newAddr) { + //backtraceHere!(val); + self.store::<$newAddr>(val) + } + |]) + [] + findFieldPtr _ = Nothing + + in concatMap (accum findFieldPtr) bes + +-- | Distribute the 'contains(...)' attributes on layers onto all of the named fields +-- (and other layers) one-level-deep (don't traverse the AST through names), such that +-- we get out conversion functions to/from the "contained" thing and the inner names found. +-- These casting functions get associated with the container itself, not the addresses +-- being cast so as to keep how the contains() attribute works simple to understand. +-- +-- TODO: We can do *all* sorts of assertions here, such as checking alignment constraints +-- e.g. if you cast an immix Cell to an immix Line, then that Cell *should* have started +-- on an aligned-Line. If this was not the case, either there was an error, or we should +-- provide support for optional types that fail when alignment fails. It's probably better +-- for now though to just require that the system developer check alignment constraints +-- on there own and have FLP print out an error message when alignments are broken, that way +-- we can figure out what to do with bad alignments when we have an actual example. +genDistributeContainsAttr :: [BaseExp] -> [RustItem] +genDistributeContainsAttr bes = let + + findNamed :: BaseExp -> Maybe RustItem + findNamed (n ::: e) = Just $ RustImpl (structName n) (mkDistr e) [] + findNamed _ = Nothing + + mkDistr :: BaseExp -> [ImplItem Span] + mkDistr (Attr (Contains nCont) e) = distribute nCont e ++ mkDistr e -- Distribute 'contains()' things + mkDistr (n ::: _) = [] -- Only go one level of naming deep. + mkDistr e = callSub mkDistr e -- Recursive call on subexpressions + + distribute :: NameID -> BaseExp -> [ImplItem Span] + distribute nCont (nInner ::: eInner) = let + cast_from1 = castFromName nCont nInner + cast_from2 = castFromName nInner nCont + nContA = addrName nCont + nInnerA = addrName nInner + in (snd $ + [implItems| + pub fn $cast_from1(addr : $nContA) -> $nInnerA { $nInnerA::from_usize(addr.as_usize()) } + pub fn $cast_from2(addr : $nInnerA) -> $nContA { $nContA::from_usize(addr.as_usize()) } + |]) ++ distribute nCont eInner + distribute nCont e = callSub (distribute nCont) e + + in concatMap (accum findNamed) bes + +genContainsMethods :: [BaseExp] -> [RustItem] +genContainsMethods bes = let + + findNamed :: BaseExp -> Maybe RustItem + findNamed (n ::: e) = Just $ RustImpl (addrName n) (concat $ l2r (mkContains n) e) [] + findNamed _ = Nothing + + -- Make the 'name_contains()' methods for appropriate subexpressions + mkContains :: NameID -> Maybe Nat -> BaseExp -> Maybe [ImplItem Span] + mkContains nOuter sz (nInner ::: _) = Just $ + let containsFn = containsFnName nInner + innerAddr = addrName nInner + outerAddrEnd = addrEndName nOuter + in snd $ + [implItems| pub fn $containsFn(&self, addr: $innerAddr, end: $outerAddrEnd) -> bool { + addr.as_usize() >= self.as_usize() && addr.as_usize() < end.as_usize() + } + |] + mkContains _ _ _ = Nothing + + in concatMap (accum findNamed) bes + +genBitsAccessors :: [BaseExp] -> [RustItem] +genBitsAccessors bes = let + + -- overall size (bytes) -> (curr offset, accumulated) -> (Field Name, Field Size (bits)) -> Result + -- (b -> a -> b) + singleField :: Nat -> (Int, [ImplItem Span]) -> (NameID, Int) -> (Int, [ImplItem Span]) + singleField sz (curr_offset, accum) (fieldName, bits) + | bits == 0 = (curr_offset, accum) -- No bits - continue on (no accessor). + | bits < bitsInByte && sz == 1 = -- 1-7 bits, no byte-offsets required (because sz==1): + let getter = bitsGetterName bits fieldName + fieldNameLow = fieldName ++ "_LOW_BIT" + fieldNameBits = fieldName ++ "_NUM_BITS" + fieldNameMask = fieldName ++ "_MASK" + fromer = bitsFromerName bits fieldName + getterItem + | bits == 1 = + [implItems| pub fn $getter(&self) -> bool { ((self.0[0]) & Self::$fieldNameMask) > 0 } + pub fn $fromer(b : bool) -> Self { Self([(b as u8) << Self::$fieldNameLow]) } + |] + | otherwise = + [implItems| pub fn $getter(&self) -> u8 { (self.0[0]) & Self::$fieldNameMask } + pub fn $fromer(v : u8) -> Self { Self([v]) } + |] + in (curr_offset + bits, (snd $ + [implItems| + pub const $fieldNameLow : usize = ${e| mkIntExp curr_offset |}; + pub const $fieldNameBits : usize = ${e| mkIntExp bits |}; + pub const $fieldNameMask : u8 = ${e| mkBinExp $ ((1 `shiftL` (curr_offset + bits)) - 1) .&. (complement ((1 `shiftL` curr_offset) - 1)) |}; + |]) ++ snd getterItem ++ accum) + | bits == bitsInByte && sz == 1 = -- No offset required, whole byte: + let getter = bitsGetterName bits fieldName + fromer = bitsFromerName bits fieldName + fieldNameBits = fieldName ++ "_NUM_BITS" + in (curr_offset + bits, (snd $ + [implItems| pub fn $getter(&self) -> u8 { self.0[0] } + pub fn $fromer(v : u8) -> Self { Self([v]) } + pub const $fieldNameBits : usize = ${e| mkIntExp bits |}; + |]) ++ accum) + | otherwise = error $ "TODO: sz=" ++ show sz ++ ", bits=" ++ show bits + + -- Returns ([inside the impl], [outside the impl]) + findBitsExp :: BaseExp -> Maybe ([ImplItem Span], [Item Span]) + findBitsExp (Con _ e) = findBitsExp e + findBitsExp (e :@ _) = findBitsExp e + findBitsExp (Exists _ e) = findBitsExp e + findBitsExp (Attr (BaseType (BitsBT fs)) (Prim sz)) + | sz > 0 = Just $ (snd $ foldl (singleField sz) (0, []) fs, []) + | otherwise = Nothing + findBitsExp _ = Nothing + + findNamedBitsExps (name ::: e) = (uncurry $ RustImpl (structName name)) <$> findBitsExp e + findNamedBitsExps _ = Nothing + + in concatMap (accum findNamedBitsExps) bes + +genEnumAccessors :: [BaseExp] -> [RustItem] +genEnumAccessors bes = let + + findEnums :: BaseExp -> Maybe [RustItem] + findEnums (n ::: (Attr (BaseType (EnumBT fs)) (Prim sz))) = Just $ [ RustImpl (structName n) (mkEnumFns fs sz) [] ] + findEnums _ = Nothing + + mkEnumFns :: [FlagID] -> Nat -> [ImplItem Span] + mkEnumFns fs sz = let + valType + | sz == 1 = "u8" + | sz == 2 = "u16" + | sz == 4 = "u32" + | sz == 8 = "u64" + | otherwise = error $ "Unhandled size=" ++ show sz + in snd + [implItems| + #[inline(always)] + pub fn from_enum(val : $valType) -> Self { Self([val]) } + #[inline(always)] + pub fn to_enum(&self) -> $valType { self.0[0] } + |] + + in concat $ concatMap (accum findEnums) bes +-- pub fn from_enum(val : u8) -> Self { LineMark([val]) } + +genDynamicSkippers :: [BaseExp] -> [RustItem] +genDynamicSkippers bes = let + + findDynamic :: BaseExp -> Maybe [RustItem] + findDynamic (_ :# e) = Just $ iterators (expSize e) (names e) (names e) + findDynamic _ = Nothing + + names (e1 :|| e2) = names e1 ++ names e2 + names (n ::: e) = n : names e + names (Con _ e) = names e + names (e :@ _) = names e + names (e1 :+ e2) + | expSize e2 == Just 0 = names e1 + | otherwise = [] + names (Exists _ e) = names e + names (_ :# _) = [] + names (Attr _ e) = names e + names (Prim{}) = [] + + iterators _ _ [] = [] + iterators s@Nothing ns (n':ns') = let + skipper name = + let addrN = addrName name + skName = skipperName name + in snd $ [implItems| pub fn $skName(&self, bytes : usize) -> $addrN { self.plus(bytes) } |] + in (RustImpl (addrName n') (concatMap skipper ns) []) : (iterators s ns ns') + iterators s@(Just sz) ns (n':ns') = let + jumper name = + let addrN = addrName name + jmpName = jumperName name + bytesInThing = bytesName n' + logBytesInThing = logBytesName n' + in snd $ + if isPow2 sz + then [implItems| + pub fn $jmpName(&self, count : usize) -> $addrN { + self.plus(count << $logBytesInThing) + } |] + else [implItems| + pub fn $jmpName(&self, count : usize) -> $addrN { + self.plus($bytesInThing * count) + } |] + in (RustImpl (addrName n') (concatMap jumper ns) []) : (iterators s ns ns') + + + findNamed :: BaseExp -> Maybe [RustItem] + findNamed (n ::: e) = innerPound n e + findNamed _ = Nothing + + innerPound :: NameID -> BaseExp -> Maybe [RustItem] + innerPound n (Exists _ e) = innerPound n e + innerPound n (_ :# e) = Just $ [ RustImpl (addrName n) (fixedSzIters e) [] ] + innerPound _ _ = Nothing + + fixedSzIters :: BaseExp -> [ImplItem Span] + fixedSzIters (Attr (BaseType (PtrBT ptrT)) _) = + let aName = addrName ptrT + aaName = addrName aName + nxtName = nextName ptrT + firstName = firstGetterName aaName + in snd $ + [implItems| pub fn $nxtName(ptr: $aaName) -> $aaName { ptr.plus(BYTES_IN_WORD) } + pub fn $firstName(&self) -> $aaName { $aaName(self.as_usize()) } + |] + fixedSzIters (e1 :|| e2) = fixedSzIters e1 ++ fixedSzIters e2 + fixedSzIters (n ::: _) = [] + fixedSzIters (Con _ e) = fixedSzIters e + fixedSzIters (e1 :+ e2) + | expSize e2 == Just 0 = fixedSzIters e1 + | otherwise = [] + fixedSzIters (Exists _ e) = fixedSzIters e + fixedSzIters (_ :# _) = [] + fixedSzIters (Prim {}) = [] + fixedSzIters (Attr _ e) = fixedSzIters e + + in (concat $ concatMap (accum findDynamic) bes) ++ (concat $ concatMap (accum findNamed) bes) + +genAddrAddr :: [BaseExp] -> [RustItem] +genAddrAddr bes = let + + findPtrBT (Attr (BaseType (PtrBT ptrT)) _) = + let aName = addrName ptrT + aaName = addrName aName + bytesAlign = bytesAlignName aName + getter = getterName aName + in Just $ RustImpl aaName + (snd $ [implItems| + pub fn $getter(&self) -> $aName { self.load() } + |]) + [items| #[repr (C)] + #[derive(Copy, Clone, Eq, Hash)] + pub struct $aaName(usize); + pub const $bytesAlign : usize = 1; + deriveAddr!($aaName, $bytesAlign); |] + findPtrBT _ = Nothing + + in concatMap (accum findPtrBT) bes + +-- | Finds all the NameIDs for which the first (possibly only) instance of some NameID +-- occurs flush with the beginning of the top-level expression (zero bytes distance +subexpFirsts :: BaseExp -> [NameID] +subexpFirsts be = let + + -- INVARIANT of sF: never call on a subexpression that doesn't *start* at the + -- beginning of the outer-most expression 'be'. + sF (n ::: e) = n : sF e + sF (Attr (Contains n) e) = n : sF e + sF (Attr (BaseType (SizeBT (SizeLit Nothing p))) (Prim{})) = [show p] + sF (Prim{}) = [] + sF (Con _ e) = sF e + sF (e :@ _) = sF e + sF (e1 :+ e2) + | expSize e1 == Just 0 = sF e1 ++ sF e2 + | otherwise = sF e1 -- Conservative approximation (ignore things in e2 even though expSize is conservative) + sF (e1 :|| e2) = sF e1 ++ sF e2 + sF (Exists _ e) = sF e + sF (_ :# e) = sF e -- First instances of 'e' is in 'subexpFirsts be' + sF (Attr _ e) = sF e + + in sF be + +genGetFirstMethods :: [BaseExp] -> [RustItem] +genGetFirstMethods bes = let + + findNamed :: BaseExp -> Maybe RustItem + findNamed (n ::: e) = Just $ RustImpl (addrName n) (concatMap mkGetFirst $ subexpFirsts e) [] + findNamed _ = Nothing + + mkGetFirst n = let + get_first = firstGetterName n + aN = addrName n + in snd [implItems| + pub fn $get_first(self) -> $aN { + $aN::from_usize(self.as_usize()) + } |] + + in concatMap (accum findNamed) bes + +type NamedE = (NameID, BaseExp) +type Neighbors = (NamedE, NamedE) + +-- | Makes a plain-vanilla pass-by-value paramument with the given type: +mkParam :: BindingMode -> String -> String -> Arg Span +mkParam mode var ty = Arg (Just $ IdentP mode (mkIdent var) Nothing fS) (PathTy Nothing (Path False [PathSegment (mkIdent ty) Nothing fS] fS) fS) fS + +mkSelf = SelfRegion Nothing Immutable fS + +-- | Makes a plain-vanilla type from a name +mkRustTy :: String -> Ty Span +mkRustTy name = PathTy Nothing (Path False [PathSegment (mkIdent name) Nothing fS] fS) fS + +-- List is /all/ the ancestral parents in bottom-up order. NamedE is the child who +-- has the ancesters. +type Ancestry = ([NamedE], NamedE) + +genShadowAlloc :: [BaseExp] -> [RustItem] +genShadowAlloc bes = let + + findParentList :: BaseExp -> [Ancestry] + findParentList be = let + -- acc is list of parents accumulator along the path from the root to the given BaseExp + fPL :: [NamedE] -> BaseExp -> [Ancestry] + fPL acc (prnt ::: e) = (acc, (prnt, e)) : (fPL ((prnt,e) : acc) e) + fPL acc e = callSub (fPL acc) e + in fPL [] be + + filterAncestry :: [Ancestry] -> [Ancestry] + filterAncestry [] = [] + filterAncestry ((prnts, (cN, cE)) : rest) = let + + matchingRest :: [Ancestry] + matchingRest = filter ((== cN) . fst . snd) rest + + notMatchingRest :: [Ancestry] + notMatchingRest = filter ((/= cN) . fst . snd) rest + + allPrnts = (prnts ++ (concatMap fst matchingRest)) + in (nub allPrnts, (cN, cE)) : filterAncestry notMatchingRest + + mkShadowAlloc :: Ancestry -> [RustItem] + mkShadowAlloc (prnts, child) = let + nBytesIn = bytesName (fst child) + flp_IDX_NAME = enumName (fst child) + mkRustName :: NameID -> Expr Span + mkRustName n = [expr| $n |] + mkInner = + -- Static u8 (indices / IDXs) array of the parents of this child + snd [implItems| + pub const __FLP_IDX : u8 = $flp_IDX_NAME; + pub const __FLP_PARENTS : &'static [u8] = & ${e| Vec [] + (map mkRustName $ (map (enumName . fst) prnts) ++ [enumName "UNMAPPED"]) fakeSpan |}; |] + ++ (case expSize (snd child) of + Nothing -> -- Variable-size child - caller needs to indicate size + snd [implItems| + pub fn shadow_alloc_from(&self, bytes: usize, vec_IDX: Vec) { + //assert!(Self::__FLP_PARENTS.contains(&IDX)); + //for i in 0 .. bytes { + // let offset = self.as_usize() + i; + // check_expect_pc!(offset, &vec_IDX); + //} + } + |] + Just sz -> if sz == 0 then [] -- Cannot actually shadow allocate something of zero size (no-op) + else -- Fixed-size child: caller need not indicate the size + snd [implItems| + pub fn shadow_alloc_from(&self, vec_IDX: Vec) { + //assert!(Self::__FLP_PARENTS.contains(&IDX)); + //for i in 0 .. $nBytesIn { + // let offset = self.as_usize() + i; + // check_expect_pc!(offset, &vec_IDX); + //} + } |]) + + in [RustImpl (addrName $ fst child) mkInner [] ] + + in concatMap mkShadowAlloc (filterAncestry $ concatMap findParentList bes) + -- in undefined -- concat $ concatMap (accum findParentList) bes + +-- | Generate all things pertaining to neighboring names, along with their common parent name. +genNeighborParents :: [BaseExp] -> [RustItem] +genNeighborParents bes = let + + findParent :: BaseExp -> Maybe [RustItem] + findParent (prnt ::: e) = Just $ mkItems prnt (findNeighbors e) + ++ fromMaybe [] (mkSeqFns prnt <$> (findSeqs False e)) + ++ mkAddrEndDiff prnt + ++ fromMaybe [] (mkAllocShadow prnt <$> (findSeqs True e)) + findParent _ = Nothing + + -- Find the canonical sequence of named things + findSeqs :: Bool -> BaseExp -> Maybe [NamedE] + findSeqs unwrapAll be = let + findS :: BaseExp -> Maybe [NamedE] + findS (Con _ e) = findS e + findS (e :@ _) = findS e + findS (Exists _ e) = findS e + findS (Attr _ e) = findS e + findS (e1 :+ e2) = findS e1 >>= \a -> findS e2 >>= \b -> pure (a ++ b) + findS (n ::: e) = Just $ [ (n,e) ] + findS (e1 :|| e2) + | unwrapAll = findS e1 >>= \a -> findS e2 >>= \b -> pure (a ++ b) + | otherwise = Nothing + findS (_ :# e) + | unwrapAll = findS e + | otherwise = Nothing + findS (Prim{}) = Nothing + in findS be + + -- | Individually named shadow_alloc_from_*() functions, i.e. for each parent. + mkAllocShadow :: NameID -> [NamedE] -> [RustItem] + mkAllocShadow prnt nes = let + + shadow_alloc_fn = "shadow_alloc_from_" ++ firstLower prnt + + mkImpl ne = RustImpl (addrName $ fst ne) (inner ne) [] + + prntConstFLP = enumName prnt + + inner (n, e) = + let nConstFLP = enumName n + nBytesIn = bytesName n + in case expSize e of + Nothing -> + [implItem| + pub fn $shadow_alloc_fn(&self, bytes: usize) { + //for i in 0..bytes { + // let offset = self.as_usize() + i; + // //check_expect_pc!(offset, vec![$prntConstFLP]); + //} + } |] : [] + Just sz -> if sz == 0 then [] else + [implItem| + pub fn $shadow_alloc_fn(&self) { + //for i in 0..$nBytesIn { + // let offset = self.as_usize() + i; + // //check_expect_pc!(offset, vec![$prntConstFLP]); + //} + } |] : [] + + in map mkImpl nes + + -- Functions pertaining to sequences of named things within a parent + mkSeqFns :: NameID -> [NamedE] -> [RustItem] + mkSeqFns prnt nes = let + + init_sequence = initSeqName (map fst nes) + + paramNames = map (\i -> "a" ++ show i) [1 .. length nes] + paramTypes = map (const "usize") (map fst nes) + + prntEndName = addrEndName prnt + + plusE :: [(String, NamedE)] -> Expr Span + plusE [] = [expr| self |] + plusE ((paramName, (fieldName, coreExpr)):ns) = + [expr| ${e| plusE ns |}.plus::<$fieldName>($paramName) |] + + newParams = mkSelf : map (uncurry $ mkParam (ByValue Immutable)) (zip paramNames paramTypes) + newRetTy = TupTy (map (mkRustTy . addrName . fst) nes + ++ [mkRustTy prntEndName]) fS + newStmts = let + exprs = (map (plusE . reverse) $ tail $ inits $ zip ("a0" : paramNames) ((map (bimap addrName id)) nes)) + + exprLast = [expr| ${e| last exprs |}.plus::<$prntEndName>(${i| last $ paramNames |}) |] + + in [stmts| + let a0 : usize = 0; + let ret = ${e| TupExpr [] (exprs ++ [exprLast]) fS |}; + return ret; + |] + + -- (FnDecl [Param a] (Maybe (Ty a)) Bool a) + bareFn = case [implItem| pub fn $init_sequence() -> (Int,) { (3,) } |] of + (MethodI a1 a2 a3 a4 a5 (MethodSig c1 c2 c3 (FnDecl params (Just ty) bool spn)) (Block stmts b2 b3) a8) -> + MethodI a1 a2 a3 a4 a5 (MethodSig c1 c2 c3 (FnDecl newParams (Just newRetTy) bool spn)) (Block newStmts b2 b3) a8 + _ -> error "Compiler incompatibility with your version of language-rust package." + + mSF = [ bareFn ] + + in [ RustImpl (addrName prnt) mSF [] + ] + + -- parent name -> [neighbors] -> rust items + mkItems :: NameID -> [Neighbors] -> [RustItem] + mkItems prnt ns = + let !_ = D.traceShowId (prnt, ns) + in ( RustImpl (structName prnt) (concatMap mkNeighborFns ns) [] + ) : concatMap mkNeighborAddrEndFns ns + + mkNeighborAddrEndFns :: Neighbors -> [RustItem] + mkNeighborAddrEndFns ((n1, e1), (n2, e2)) = let + + n1EndA = addrEndName n1 + toEndN = "to_" ++ firstUpper n1EndA + fromEndN = "from_" ++ firstUpper n1EndA + n2A = addrName n2 + + mkN2 = snd $ [implItems| + pub fn $toEndN(self) -> $n1EndA { $n1EndA::from_usize(self.as_usize()) } + pub fn $fromEndN(ptr : $n1EndA) -> $n2A { $n2A::from_usize(ptr.as_usize()) } + |] + + toN2FnN = "to_" ++ firstUpper n2A + fromN2FnN = "from_" ++ firstUpper n2A + + mkN1End = snd $ [implItems| + pub fn $toN2FnN(&self) -> $n2A { $n2A::from_usize(self.as_usize()) } + pub fn $fromN2FnN(ptr : $n2A) -> $n1EndA { $n1EndA::from_usize(ptr.as_usize()) } + |] + + in [ RustImpl n1EndA mkN1End [] + , RustImpl n2A mkN2 [] + ] + + mkAddrEndDiff :: NameID -> [RustItem] + mkAddrEndDiff n = let + nEndA = addrEndName n + nA = addrName n + in + [ RustImpl nA + (snd [implItems| pub fn size_of(&self, end : $nEndA) -> usize { + debug_assert!(end.as_usize() >= self.as_usize()); + end.diff(*self) + } |]) [] + ] + + mkNeighborFns :: Neighbors -> [ImplItem Span] + mkNeighborFns ((n1, e1), (n2, e2)) = let + + n1A = addrName n1 + n2A = addrName n2 + + init_after = initAfterName n1 n2 + + -- | Looks for all (depth = 1) named entities that consume the entire space of the BaseExp + -- (can't dig into ':+' expressions): + findWholeChunks :: BaseExp -> [NameID] + findWholeChunks be = let + fWC (n ::: _) = [n] -- Don't recurse because depth=1 + fWC (e1 :+ e2) + | expSize e2 == Just 0 = fWC e1 + | expSize e1 == Just 0 = fWC e2 + | otherwise = [] -- Doesn't consume the entire space + fWC (_ :# e) = [] -- Doesn't consume the entire space + fWC e = callSub fWC e -- All other recursive cases + in fWC be + + poundLeftBumpFn n = + let bump_new_thing = bumpAllocName n + aN = addrName n + in snd $ + [implItems| pub fn $bump_new_thing(rhs : $n2A, bytes : usize) -> ($aN, $n2A) { + (rhs.plus(0), rhs.plus(bytes)) + } + |] + + bump_valid = bumpValidName n1 n2 + bumpValid = snd $ + [implItems| pub fn $bump_valid(p1 : $n1A, p2 : $n2A) -> bool { p1.lte(p2) } |] + + -- Checks that the LHS (e1) was exactly a field containing an array of things, and + -- makes the function that allows you to bump-allocate a new entry in that array + -- past the *current* end of the array. + poundLeftBumpFns = case e1 of + (Exists _ (_ :# e)) -> concatMap poundLeftBumpFn (findWholeChunks e) + _ -> [] + + -- The right-hand neighbor is null-sized + --emptyRight = case expSize e2 of + -- (Just 0) -> + -- _ -> [] + + memset_until = memsetUntilName n1 n2 + n1Bytes = bytesName n1 + + memsetRange = case expSize e1 of + Just sz | sz > 0 -> snd [implItems| + pub fn $memset_until(val : u8, base : $n1A) { + base.memset(val, $n1Bytes) + } |] + | otherwise -> [] + Nothing -> snd [implItems| + pub fn $memset_until(val : u8, base : $n1A, mx : $n2A) { + debug_assert!(mx.greater(base)); + base.memset(val, mx.diff(base)) + } |] + + initAfterFn = (snd $ case expSize e1 of + Just sz | sz == 0 -> [implItems| pub fn $init_after(p1 : $n1A) -> $n2A { $n2A::from_usize(p1.as_usize()) } |] + | otherwise -> [implItems| pub fn $init_after(p1 : $n1A) -> $n2A { p1.plus($n1Bytes) } |] + Nothing -> [implItems| pub fn $init_after(p1 : $n1A, bytes : usize) -> $n2A { p1.plus(bytes) } |]) + + in memsetRange ++ poundLeftBumpFns ++ initAfterFn ++ bumpValid + + findNeighbors :: BaseExp -> [Neighbors] + findNeighbors be = let + + most :: ((BaseExp, BaseExp) -> BaseExp) -> BaseExp -> [NamedE] + most fn = let + most' (n ::: e) = [(n,e)] -- We don't find nested-names (names are boundaries) + most' (e1 :+ e2) = most' (fn (e1,e2)) + most' (Attr _ e) = most' e + most' (Prim{}) = [] + most' (Con _ e) = most' e + most' (e :@ _) = most' e + most' (e1 :|| e2) = [] + most' (Exists _ e) = most' e + most' (_ :# e) = [] + in most' + + left_most :: BaseExp -> [NamedE] + left_most = most fst + right_most :: BaseExp -> [NamedE] + right_most = most snd + + fN :: [NamedE] -> BaseExp -> [NamedE] -> [Neighbors] + fN left (e1 :+ e2) right = fN left e1 (left_most e2) ++ fN (right_most e1) e2 right + fN left (n ::: e) right = (zip left (repeat (n,e))) ++ (zip (repeat (n,e)) right) + fN l (Attr _ e) r = fN l e r + fN l (Prim{}) r = [] + fN l (Con _ e) r = fN l e r + fN l (e :@ _) r = fN l e r + fN l (e1 :|| e2) r = fN [] e1 [] ++ fN [] e2 [] -- We throw away neighbors at unions (for simplicity) + fN l (Exists _ e) r = fN l e r + fN l (_ :# e) r = fN [] e [] -- Throw away neighbors at repetitions, because not every instance inside '#' is left-most or right-most + in nub $ fN [] be [] + + in concat $ concatMap (accum findParent) bes + +-- | TODO: Remove allow(dead_code) and allow(unused_imports) +(SourceFile _ headerAttrs headerItems) = [sourceFile| + #![allow(non_camel_case_types)] + #![allow(non_snake_case)] + #![allow(dead_code)] + #![allow(unused_imports)] + #![allow(unused_variables)] + extern crate libc; + extern crate flp_framework; + use std::cmp; + use std::fmt; + use std::mem::size_of as size_of; + use self::libc::size_t as size_t; + + pub use self::flp_framework::*; +|] +-- #[macro_use] +-- pub mod address; +-- use self::address::*; + +-- writeSourceFile :: (Monoid a, Typeable a) => Handle -> SourceFile a -> IO () +writeModule :: (Monoid a, Typeable a) => FilePath -> SourceFile a -> IO () +writeModule outdir sf = do + fd <- openFile outdir WriteMode + writeSourceFile fd sf + hClose fd + diff --git a/src/Language/Floorplan/Rust/Mapping.hs b/src/Language/Floorplan/Rust/Mapping.hs new file mode 100644 --- /dev/null +++ b/src/Language/Floorplan/Rust/Mapping.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, BangPatterns #-} +module Language.Floorplan.Rust.Mapping + where +{- Code generator for mappings due to same-named repetitions in a FLP spec. + -} + +import Language.Rust.Parser as P +import Language.Rust.Syntax as R hiding (Byte) +import Language.Rust.Quote +import Language.Rust.Data.Ident +import Language.Rust.Data.Position + +import Language.Floorplan.Syntax(SizeArith(..), Primitive(..)) +import Language.Floorplan.Core.Syntax +import Language.Floorplan.Rust.Types +import Language.Floorplan.Rust.Common + +import Data.Functor ( ($>) ) +import Data.Ord (comparing) +import Data.List (sortBy, nub) +import Data.Char (toUpper, toLower) +import qualified Debug.Trace as D + +genFixedWidthStructs :: [BaseExp] -> [Item Span] +genFixedWidthStructs bes = let + + gFWS (n ::: e) = let sN = structName n in Just $ case expSize e of + Nothing -> [items| #[derive(Copy, Clone)] + pub struct $sN( () ); // Unit type!!! + |] + Just sz -> [items| + #[derive(Copy, Clone)] + pub struct $sN([u8; ${e| mkIntExp sz |}]); + + impl PartialEq for $sN { + #[inline(always)] fn eq(&self, other: &$sN) -> bool { + for i in 0..(size_of::<$sN>()) { + if self.0[i] != other.0[i] { return false; } + } + return true; + } + #[inline(always)] fn ne(&self, other: &$sN) -> bool { + for i in 0..(size_of::<$sN>()) { + if self.0[i] != other.0[i] { return true; } + } + return false; + } + } + |] + gFWS _ = Nothing + + in nub $ concat $ concatMap (accum gFWS) bes + +genMaps :: [BaseExp] -> [RustItem] +genMaps bes = + let findExistBind :: BaseExp -> Maybe [RustItem] + findExistBind (outerName ::: e) = + Just $ concatMap (mkMapFns outerName) (findExists e) + findExistBind _ = Nothing + + -- [ImplItem Span] + mkMapFns :: NameID -> BaseExp -> [RustItem] + mkMapFns oN (Exists n e) = let + + nameOf Byte = "Byte" -- "u8" TODO: replace all bytes with 'u8' + nameOf x = show x + + -- TODO: mkMF should be a more principled pre-processing pass (find pairs that work): + mkMF (Attr (BaseType (SizeBT (SizeLit Nothing p1))) e1 + , Attr (BaseType (SizeBT (SizeLit Nothing p2))) e2) = mkMF' (nameOf p1) e1 (nameOf p2) e2 + mkMF (Attr (BaseType (SizeBT (SizeLit Nothing p1))) e1, n2 ::: e2) = mkMF' (nameOf p1) e1 n2 e2 + mkMF (n1 ::: e1, (Attr (BaseType (SizeBT (SizeLit Nothing p2))) e2)) = mkMF' n1 e1 (nameOf p2) e2 + mkMF (Attr _ e1, e2) = mkMF (e1, e2) + mkMF (e1, Attr _ e2) = mkMF (e1, e2) + mkMF (n1 ::: e1, n2 ::: e2) = mkMF' n1 e1 n2 e2 + mkMF _ = [] + + mkMF' n1 e1 n2 e2 = let + + (Just sz1) = expSize e1 + (Just sz2) = expSize e2 + + tsfm = n1 ++ "2" ++ n2 + startNameAddr = addrName n1 + toNameAddr = addrName n2 + toName = structName n2 + + outerAddr = addrName oN + + idxExpr + | isPow2 sz1 = [expr| (elem.as_usize() - base.as_usize()) >> ${e| mkIntExp $ log2 sz1 |} |] + | otherwise = [expr| (elem.as_usize() - base.as_usize()) / ${e| mkIntExp sz1 |} |] + + tsfmExpr + | isPow2 sz1 = [expr| (idx << ${e| mkIntExp $ log2 sz1 |}) |] + | otherwise = [expr| (idx * sz1) |] + idxTsfm = + [implItem| + #[inline(always)] + pub fn $thing_from_idx(base: $startNameAddr, idx: usize) -> $startNameAddr { + let result = $startNameAddr::from_usize(base.as_usize() + ${e| tsfmExpr |}); + result + } + |] + + assocItems = [items| + pub struct $tsfm + { pub fromStart : $startNameAddr + , pub toStart : $toNameAddr + } + |] + + thing_from_idx = fromIdxName n1 + idx_from_thing = toIdxName n1 + + innerItems = idxTsfm : snd [implItems| + #[inline(always)] + pub fn new(fromStart: $startNameAddr, toStart: $toNameAddr) -> $tsfm { + $tsfm { fromStart, toStart } + } + + #[inline(always)] + pub fn set(&self + , fromAddr : $startNameAddr + , value : $toName) { Self::map_set(self.fromStart, self.toStart, fromAddr, value) } + + #[inline(always)] + pub fn getAddr(&self + , fromAddr : $startNameAddr + ) -> $toNameAddr { Self::map_getAddr(self.fromStart, self.toStart, fromAddr) } + + #[inline(always)] + pub fn get(&self + , fromAddr : $startNameAddr + ) -> $toName { Self::map_get(self.fromStart, self.toStart, fromAddr) } + + #[inline(always)] + pub fn idx(base : $startNameAddr, elem : $startNameAddr) -> usize { + debug_assert!(elem >= base); + //LET Sz1 = ${e| mkIntExp sz1 |}; + // This can be checked on addresses themselves to enforce alignment as-is: + //debug_assert!(((elem.as_usize() - base.as_usize()) % sz1) == 0); + let result = ${e| idxExpr |}; + result + } + + #[inline(always)] + pub fn map_set( fromStart : $startNameAddr + , toStart : $toNameAddr + , fromAddr : $startNameAddr + , value : $toName) { + let idxV = $tsfm::idx(fromStart, fromAddr); + toStart.offset::<$toName, $toNameAddr>(idxV).store(value) + } + + #[inline(always)] + pub fn map_set_idx( + toStart : $toNameAddr + , idxV : usize + , value : $toName) { + toStart.offset::<$toName, $toNameAddr>(idxV).store(value) + } + + #[inline(always)] + pub fn map_get_idx( + toStart : $toNameAddr + , idxV : usize) -> $toName { + toStart.offset::<$toName, $toNameAddr>(idxV).load() + } + + #[inline(always)] + pub fn map_getAddr( fromStart : $startNameAddr + , toStart : $toNameAddr + , fromAddr : $startNameAddr + ) -> $toNameAddr { + let idxV = $tsfm::idx(fromStart, fromAddr); + toStart.offset::<$toName, $toNameAddr>(idxV) + } + + #[inline(always)] + pub fn map_get( fromStart : $startNameAddr + , toStart : $toNameAddr + , fromAddr : $startNameAddr + ) -> $toName { + let idxV = $tsfm::idx(fromStart, fromAddr); + toStart.offset::<$toName, $toNameAddr>(idxV).load() + } + |] + -- #[inline(always)] + -- let result = 3; //${e|idxExpr|}; + -- debug_assert!(((elem.as_usize() - base.as_usize()) % (${e| mkIntExp sz1 |})) == 0); + -- result + -- + in [ RustImpl tsfm innerItems assocItems ] + + in concatMap mkMF $ D.traceShowId $ allPairs n e + + allPairs :: NameID -> BaseExp -> [(BaseExp, BaseExp)] + allPairs n e = let + + -- Find references to a repetition with the given name, + -- without crossing shadowed scope boundaries: + findRep (Prim{}) = [] + findRep (Con _ e2) = findRep e2 + findRep (e2 :@ _) = findRep e2 + findRep (e2 :+ e3) = findRep e2 ++ findRep e3 + findRep (e2 :|| e3) = findRep e2 ++ findRep e3 + findRep (_ ::: e2) = findRep e2 + findRep (Exists n2 e2) + | n == n2 = [] + | otherwise = findRep e2 + findRep e2@(n2 :# e3) + | n == n2 = e3 : findRep e3 + | otherwise = findRep e3 + findRep (Attr _ e2) = findRep e2 + + xs = findRep e + in [ (x,y) + | (x,i) <- zip xs [1..length xs] + , (y,j) <- zip xs [1..length xs] + , expSize x /= Nothing + , expSize y /= Nothing + , i /= j + ] + + in concat $ concatMap (accum findExistBind) bes + diff --git a/src/Language/Floorplan/Rust/Types.hs b/src/Language/Floorplan/Rust/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Floorplan/Rust/Types.hs @@ -0,0 +1,24 @@ +module Language.Floorplan.Rust.Types + where +import Language.Rust.Parser as P +import Language.Rust.Syntax as R +import Language.Rust.Quote +import Language.Rust.Data.Ident +import Language.Rust.Data.Position + +import Language.Floorplan.Core.Syntax + +-- | Stripped-down Rust Impl item with just the pieces we +-- care about (name and item entries) so that we can merge lists of impls +-- together by NameID equality. +data RustItem = + RustImpl + NameID -- ^ e.g. "CellAddr" + [ImplItem Span] -- ^ Contents of the Impl + [Item Span] -- ^ Associated Items that go *outside* the `impl` + | TopLevel [Item Span] + deriving (Show) + +rustItemComparator (RustImpl n _ _) = n +rustItemComparator (TopLevel _) = "______________________FLP__" -- TODO + diff --git a/src/Language/Floorplan/Semantics.hs b/src/Language/Floorplan/Semantics.hs new file mode 100644 --- /dev/null +++ b/src/Language/Floorplan/Semantics.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveDataTypeable #-} +module Language.Floorplan.Semantics where + +import Data.Maybe (fromJust) +import Language.Floorplan.Core.Syntax + +data Tree = + T Tree Tree + | N String Tree + | B0 | B1 + deriving (Eq, Ord, Show) + +leaves (T t1 t2) = leaves t1 + leaves t2 +leaves (N _ t) = leaves t +leaves B0 = 0 +leaves B1 = 1 + +addStep s xs = map (\(r,d) -> (r, s : d)) xs + +g p0 p1 p2 p3 = let + + g' a m theta ((:+) e1 e2) = + let params = \r1 -> (a + leaves r1, m - leaves r1, theta, e2) + in + [ (T r1 r2, ("Plus: i = 0.." ++ show m ++ ", Pause (g " ++ show (params r1) ++ ")") : deriv1 + ++ ["Resume (g " ++ show (params r1) ++ ")" ++ ", leaves r1 = " ++ show (leaves r1)] ++ deriv2) + | (r1, deriv1) <- concat [ addStep ("Plus_r1: Choose i=" ++ show i) $ g a i theta e1 | i <- [0..m]] + , (r2, deriv2) <- addStep ("Plus_r2: leaves(" ++ show e1 ++ ")=" ++ show (leaves r1)) $ g (a + leaves r1) (m - leaves r1) theta e2 + ] + g' a m theta ((:||) e1 e2) = let + r1 = addStep ("Or_e1") (g a m theta e1) + r2 = addStep ("Or_e2") (g a m theta e2) + in r1 ++ r2 + g' a m theta (Prim n) + | m == n = [(foldl T B0 (take n $ repeat B1), ["Prim: Evaluate " ++ show n ++ "-leaf tree"])] + | otherwise = [] + g' a m theta (Con n e) + | m == n = addStep ("Con: " ++ show n) (g a m theta e) + | m /= n = [] + g' a m theta ((:@) e aln) + | a `mod` aln == 0 = g a m theta e + | otherwise = [] + g' a m theta ((:::) l e) = + [ (N l r, ("HasType: " ++ l) : deriv) + | (r, deriv) <- g a m theta e + ] + g' a m theta (Exists f e) = concat + [ addStep ("Exists: Choose " ++ f ++ "=" ++ show i) + $ g a m ((f, i) : theta) e | i <- [0 .. m] ] + g' a m theta ((:#) f e) + | (Just m) == lookup f theta && m == 0 = [(T B0 B0, ["Pound: m = 0"])] + | (Just 0) == lookup f theta = [] + | otherwise = let -- Implies lookup theta f > 0 + params = \r1 -> (a + leaves r1, m - leaves r1, (f, (fromJust $ lookup f theta) - 1) : theta, (:#) f e) + in case lookup f theta of + Nothing -> error "Nothing" + Just thetaF -> [ (T r1 r2, ("Pound: theta(" ++ f ++ ")=" ++ show thetaF ++ ", Pause (g " ++ show (params r1)) : deriv1 + ++ ["Resume (g " ++ show (params r1) ++ ")"] ++ deriv2) + | (r1, deriv1) <- concat [addStep ("Pound_r1: Choose i=" ++ show i) $ g a i theta e | i <- [0..m]] + , (r2, deriv2) <- addStep ("Pound_r2: leaves(" ++ show e ++ ")=" ++ show (leaves r1)) $ + g (a + leaves r1) (m - leaves r1) ((f, (fromJust $ lookup f theta) - 1) : theta) ((:#) f e) + ] + + addLabel (r, d:ds) = (r, (d ++ "[[g " ++ show (p0, p1, p2, p3) ++ "]] ") : ds) + + in map addLabel (g' p0 p1 p2 p3) + diff --git a/src/Language/Floorplan/Syntax.hs b/src/Language/Floorplan/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/Floorplan/Syntax.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveDataTypeable #-} +module Language.Floorplan.Syntax where + +import Data.Maybe (maybeToList) + +type LayerID = String -- upper +type FormalID = String -- lower +type FlagID = String -- upper +type FieldID = String -- lower + +data Primitive = Page | Word | Byte | Bit + deriving (Eq, Ord, Show) + +lexeme2prim "page" = Just Page +lexeme2prim "pages" = Just Page +lexeme2prim "word" = Just Word +lexeme2prim "words" = Just Word +lexeme2prim "byte" = Just Byte +lexeme2prim "bytes" = Just Byte +lexeme2prim "bit" = Just Bit +lexeme2prim "bits" = Just Bit +lexeme2prim _ = Nothing + +instance Read Primitive where + readsPrec _ input = case lexeme2prim input of + Just x -> [(x,"")] + Nothing -> [] + +data Demarc = + Enum [FlagID] + | Bits [(FieldID, SizeArith)] + | Union [Demarc] + | Seq [Demarc] + | PtrF FieldID + | PtrL LayerID + | Blob SizeArith + | Graft (LayerID, [Arg]) + | Field FieldID Demarc + | Pound Demarc + | Repetition FormalID Demarc + | Layer + { name :: LayerID + , formals :: [FormalID] + , magnitude :: Maybe SizeArith + , alignment :: Maybe SizeArith + , magAlign :: Maybe SizeArith + , contains :: [LayerID] + , rhs :: Demarc + } + deriving (Eq, Ord, Show) + +free_vars :: Demarc -> [FormalID] +free_vars d@(Enum{}) = [] +free_vars d@(Bits{}) = [] +free_vars d@(Union ds) = concatMap free_vars ds +free_vars d@(Seq ds) = concatMap free_vars ds +free_vars d@(PtrF{}) = [] +free_vars d@(PtrL{}) = [] +free_vars d@(Blob{}) = [] +free_vars d@(Graft{}) = [] +free_vars f@(Field _ d) = free_vars d +free_vars p@(Pound d) = free_vars d +free_vars r@(Repetition f d) = f : free_vars d +free_vars d@(Layer{}) = + [ fv + | fv <- free_vars (rhs d) + , fv `notElem` formals d + ] + +accum :: (Demarc -> Maybe a) -> Demarc -> [a] +accum fn d@(Enum{}) = maybeToList (fn d) +accum fn d@(Bits{}) = maybeToList (fn d) +accum fn d@(Union ds) = maybeToList (fn d) ++ concatMap (accum fn) ds +accum fn d@(Seq ds) = maybeToList (fn d) ++ concatMap (accum fn) ds +accum fn d@(PtrF{}) = maybeToList (fn d) +accum fn d@(PtrL{}) = maybeToList (fn d) +accum fn d@(Blob{}) = maybeToList (fn d) +accum fn d@(Graft{}) = maybeToList (fn d) +accum fn f@(Field _ d) = maybeToList (fn f) ++ accum fn d +accum fn p@(Pound d) = maybeToList (fn p) ++ accum fn d +accum fn r@(Repetition _ d) = maybeToList (fn r) ++ accum fn d +accum fn d@(Layer{}) = maybeToList (fn d) ++ accum fn (rhs d) + +countMatches :: (Demarc -> Bool) -> Demarc -> Int +countMatches fn demarc = length $ (flip accum) demarc $ \d -> if fn d then Just 1 else Nothing + +-- | Bool is whether or not anything was changed (so no need to do Eq check in fixed-point transformations) +fmapD :: (Demarc -> (Demarc, Bool)) -> Demarc -> (Demarc, Bool) +fmapD fncn d@(Enum{}) = fncn d +fmapD fncn d@(Bits{}) = fncn d +fmapD fncn d@(Union ds) = let ds' = map (fmapD fncn) ds + (d', b) = fncn (Union $ map fst ds') + in (d', or (b : map snd ds')) +fmapD fncn d@(Seq ds) = let ds' = map (fmapD fncn) ds + (d', b) = fncn (Seq $ map fst ds') + in (d', or (b : map snd ds')) +fmapD fncn d@(PtrF{}) = fncn d +fmapD fncn d@(PtrL{}) = fncn d +fmapD fncn d@(Blob{}) = fncn d +fmapD fncn d@(Graft{}) = fncn d +fmapD fncn (Field f d) = let (d', b') = fmapD fncn d + (d'', b'') = fncn (Field f d') + in (d'', b' || b'') +fmapD fncn (Pound d) = let (d', b') = fmapD fncn d + (d'', b'') = fncn (Pound d') + in (d'', b' || b'') +fmapD fncn (Repetition f d) = let (d', b') = fmapD fncn d + (d'', b'') = fncn (Repetition f d') + in (d'', b' || b'') +fmapD fncn d@(Layer{}) = let (rhs', b') = fmapD fncn $ rhs d + (d'', b'') = fncn (d { rhs = rhs' }) + in (d'', b' || b'') + +data Arg = + ArgL Literal + | ArgF FormalID + deriving (Eq, Ord, Show) + +type Literal = Int + +bin2int :: String -> Int +bin2int ('0':'b':xs) = let + b2i [] = 0 + b2i (b:bs) = (read [b]) + (2 * b2i bs) + in b2i $ reverse xs + +data LitArith = + Plus LitArith LitArith + | Minus LitArith LitArith + | Times LitArith LitArith + | Div LitArith LitArith + | Exponent LitArith LitArith + | Lit Literal + deriving (Eq, Ord, Show) + +data SizeArith = + SizePlus SizeArith SizeArith + | SizeMinus SizeArith SizeArith + | SizeLit (Maybe LitArith) Primitive + deriving (Eq, Ord, Show) + diff --git a/src/Language/Floorplan/Token.x b/src/Language/Floorplan/Token.x new file mode 100644 --- /dev/null +++ b/src/Language/Floorplan/Token.x @@ -0,0 +1,95 @@ +{ +{-# OPTIONS_GHC -w #-} +module Language.Floorplan.Token (Token(..), scanTokens) where +import Language.Floorplan.Syntax +} + +%wrapper "basic" + +$digit = 0-9 +$alpha = [a-zA-Z] +$eol = [\n] + +tokens :- + $eol ; + $white+ ; + "//".* ; + seq { \s -> TokenSeq } + union { \s -> TokenUnion } + contains { \s -> TokenContains } + bits { \s -> TokenBits } + bytes { \s -> TokenBytes } + words { \s -> TokenWords } + pages { \s -> TokenPages } + ptr { \s -> TokenPtr } + enum { \s -> TokenEnum } + "->" { \s -> TokenArrow } + "@(" { \s -> TokenAtParen } + ")@" { \s -> TokenParenAt } + "@|" { \s -> TokenAtBar } + "|@" { \s -> TokenBarAt } + "<$" { \s -> TokenLessD } + "$>" { \s -> TokenGreaterD } + \( { \s -> TokenLParen } + \) { \s -> TokenRParen } + \< { \s -> TokenLess } + \> { \s -> TokenGreater } + \| { \s -> TokenBar } + \|\| { \s -> TokenBarBar } + \{ { \s -> TokenLCurl } + \} { \s -> TokenRCurl } + \# { \s -> TokenPound } + \: { \s -> TokenColon } + \, { \s -> TokenComma } + [\+] { \s -> TokenPlus } + [\-] { \s -> TokenMinus } + [\*] { \s -> TokenTimes } + [\/] { \s -> TokenDiv } + [\^] { \s -> TokenExponent } + $digit+ { \s -> TokenNum (read s) } + 0b [01]+ { \s -> TokenNum (bin2int s) } + [a-z] [$alpha $digit \_]* { \s -> TokenLowerID s } + [A-Z] [$alpha $digit \_]* { \s -> TokenUpperID s} + +{ +data Token = + TokenSeq + | TokenUnion + | TokenContains + | TokenBits + | TokenBytes + | TokenWords + | TokenPages + | TokenPtr + | TokenEnum + | TokenArrow + | TokenAtParen + | TokenParenAt + | TokenAtBar + | TokenBarAt + | TokenLParen + | TokenRParen + | TokenLess + | TokenGreater + | TokenLessD + | TokenGreaterD + | TokenBar + | TokenBarBar + | TokenLCurl + | TokenRCurl + | TokenPound + | TokenColon + | TokenComma + | TokenPlus + | TokenMinus + | TokenTimes + | TokenDiv + | TokenExponent + | TokenNum Int + | TokenUpperID String + | TokenLowerID String + deriving (Eq, Ord, Show) + +scanTokens = alexScanTokens +} + diff --git a/src/Language/Rust/Data/Ident.hs b/src/Language/Rust/Data/Ident.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Data/Ident.hs @@ -0,0 +1,94 @@ +{-| +Module : Language.Rust.Data.Ident +Description : Identifiers +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : portable + +Data structure behind identifiers. +-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Language.Rust.Data.Ident (Ident(..), mkIdent, Name, IdentName(..) ) where + +import GHC.Generics ( Generic ) + +import Control.DeepSeq ( NFData ) +import Data.Data ( Data ) +import Data.Typeable ( Typeable ) + +import Data.List ( foldl' ) +import Data.Char ( ord ) +import Data.String ( IsString(..) ) +--import Data.Semigroup as Sem + +-- | An identifier +data Ident + = Ident { name :: IdentName -- ^ payload of the identifier + , raw :: Bool -- ^ whether the identifier is raw + , hash :: {-# UNPACK #-} !Int -- ^ hash for quick comparision + } deriving (Data, Typeable, Generic, NFData) + +-- | Shows the identifier as a string (for use with @-XOverloadedStrings@) +instance Show Ident where + show = show . name + +instance IsString Ident where + fromString = mkIdent + +-- | Uses 'hash' to short-circuit +instance Eq Ident where + i1 == i2 = hash i1 == hash i2 && name i1 == name i2 && raw i1 == raw i2 + i1 /= i2 = hash i1 /= hash i2 || name i1 /= name i2 || raw i1 /= raw i2 + +-- | Uses 'hash' to short-circuit +instance Ord Ident where + compare i1 i2 = case compare i1 i2 of + EQ -> compare (raw i1, name i1) (raw i2, name i2) + rt -> rt + +-- | "Forgets" about whether either argument was raw +instance Monoid Ident where + mappend = (<>) + mempty = mkIdent "" + +-- | "Forgets" about whether either argument was raw +-- <<<<<<< HEAD +instance Semigroup Ident where + Ident (Name n1) _ _ <> Ident (Name n2) _ _ = mkIdent (n1 <> n2) + Ident (HaskellName n1) _ _ <> Ident (HaskellName n2) _ _ = mkIdent (n1 <> n2) + Ident (Name n1) _ _ <> Ident (HaskellName n2) _ _ = mkIdent (n1 <> n2) + Ident (HaskellName n1) _ _ <> Ident (Name n2) _ _ = mkIdent (n1 <> n2) +-- ======= +-- instance Sem.Semigroup Ident where +-- Ident n1 _ _ <> Ident n2 _ _ = mkIdent (n1 <> n2) +-- >>>>>>> upstream/master + +-- | Smart constructor for making an 'Ident'. +mkIdent :: String -> Ident +mkIdent ('$':'{':'i':'|':ss) = Ident (HaskellName $ init $ init ss) False (hashString $ init $ init ss) +mkIdent s = Ident (Name s) False (hashString s) + +-- | Hash a string into an 'Int' +hashString :: String -> Int +hashString = foldl' f golden + where f m c = fromIntegral (ord c) * magic + m + magic = 0xdeadbeef + golden = 1013904242 + +-- | The payload of an identifier +type Name = String + +data IdentName = + Name Name + | HaskellName String + deriving (Eq, Ord, Data, Typeable, Generic, NFData) + +instance Show IdentName where + show (Name n) = show n + show (HaskellName n) = "${i|" ++ n ++ "|}" + diff --git a/src/Language/Rust/Data/InputStream.hs b/src/Language/Rust/Data/InputStream.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Data/InputStream.hs @@ -0,0 +1,170 @@ +{-| +Module : Language.Rust.Data.InputStream +Description : Interface to the underlying input of parsing +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : portable + +These are the only functions that need to be implemented in order to use the parser. Whether this +wraps 'BS.ByteString' or 'String' depends on whether the @useByteStrings@ option is on or not (it is +by default). Using 'BS.ByteString' means better handling of weird characters ('takeByte' for plain +'String' fails badly if you try to take a byte that doesn't fall on a character boundary), but it +means incurring a dependency on the [utf8-string](https://hackage.haskell.org/package/utf8-string) +package. +-} +{-# LANGUAGE CPP #-} + +module Language.Rust.Data.InputStream ( + -- * InputStream type + InputStream, + countLines, + inputStreamEmpty, + + -- * Introduction forms + readInputStream, + hReadInputStream, + inputStreamFromString, + + -- * Elimination forms + inputStreamToString, + takeByte, + takeChar, + peekChars, +) where + +import Data.Word ( Word8 ) +import Data.Coerce ( coerce ) +import Data.String ( IsString(..) ) +import System.IO + +#ifdef USE_BYTESTRING +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as BE +#else +import qualified Data.Char as Char +#endif + +-- | Read an encoded file into an 'InputStream' +readInputStream :: FilePath -> IO InputStream +{-# INLINE readInputStream #-} + +-- | Read an 'InputStream' from a 'Handle' +hReadInputStream :: Handle -> IO InputStream +{-# INLINE hReadInputStream #-} + +-- | Convert 'InputStream' to 'String'. +inputStreamToString :: InputStream -> String +{-# INLINE inputStreamToString #-} + +-- | Convert a 'String' to an 'InputStream'. +inputStreamFromString :: String -> InputStream +{-# INLINE inputStreamFromString #-} + +-- | Uses 'inputStreamFromString' +instance IsString InputStream where fromString = inputStreamFromString + +-- | Read the first byte from an 'InputStream' and return that byte with what remains of the +-- 'InputStream'. Behaviour is undefined when 'inputStreamEmpty' returns 'True'. +-- +-- >>> takeByte "foo bar" +-- (102, "oo bar") +-- +-- >>> takeByte "Ĥăƨĸëļļ" +-- (196, "\ETX\168\&8\235<<") +-- +takeByte :: InputStream -> (Word8, InputStream) +{-# INLINE takeByte #-} + +-- | Read the first character from an 'InputStream' and return that 'Char' with what remains of the +-- 'InputStream'. Behaviour is undefined when 'inputStreamEmpty' returns 'True'. +-- +-- >>> takeChar "foo bar" +-- ('f', "oo bar") +-- +-- >>> takeChar "Ĥăƨĸëļļ" +-- ('Ĥ', "ăƨĸëļļ") +-- +takeChar :: InputStream -> (Char, InputStream) +{-# INLINE takeChar #-} + +-- | Return @True@ if the given input stream is empty. +-- +-- >>> inputStreamEmpty "" +-- True +-- +-- >>> inputStreamEmpty "foo" +-- False +-- +inputStreamEmpty :: InputStream -> Bool +{-# INLINE inputStreamEmpty #-} + +-- | Returns the first @n@ characters of the given input stream, without removing them. +-- +-- >>> peekChars 5 "foo bar" +-- "foo ba" +-- +-- >>> peekChars 5 "foo" +-- "foo" +-- +-- >>> peekChars 3 "Ĥăƨĸëļļ" +-- "Ĥăƨ" +-- +peekChars :: Int -> InputStream -> String +{-# INLINE peekChars #-} + +-- | Returns the number of text lines in the given 'InputStream' +-- +-- >>> countLines "" +-- 0 +-- +-- >>> countLines "foo" +-- 1 +-- +-- >>> countLines "foo\n\nbar" +-- 3 +-- +-- >>> countLines "foo\n\nbar\n" +-- 3 +-- +countLines :: InputStream -> Int +{-# INLINE countLines #-} + +#ifdef USE_BYTESTRING + +-- | Opaque input type. +newtype InputStream = IS BS.ByteString deriving (Eq, Ord) +takeByte bs = (BS.head (coerce bs), coerce (BS.tail (coerce bs))) +takeChar bs = maybe (error "takeChar: no char left") coerce (BE.uncons (coerce bs)) +inputStreamEmpty = BS.null . coerce +peekChars n = BE.toString . BE.take n . coerce +readInputStream f = coerce <$> BS.readFile f +hReadInputStream h = coerce <$> BS.hGetContents h +inputStreamToString = BE.toString . coerce +inputStreamFromString = IS . BE.fromString +countLines = length . BE.lines . coerce + +instance Show InputStream where + show (IS bs) = show bs + +#else + +-- | Opaque input type. +newtype InputStream = IS String deriving (Eq, Ord) +takeByte (IS ~(c:str)) + | Char.isLatin1 c = let b = fromIntegral (Char.ord c) in b `seq` (b, IS str) + | otherwise = error "takeByte: not a latin-1 character" +takeChar (IS ~(c:str)) = (c, IS str) +inputStreamEmpty (IS str) = null str +peekChars n (IS str) = take n str +readInputStream f = IS <$> readFile f +hReadInputStream h = IS <$> hGetContents h +inputStreamToString = coerce +inputStreamFromString = IS +countLines (IS str) = length . lines $ str + +instance Show InputStream where + show (IS bs) = show bs + +#endif diff --git a/src/Language/Rust/Data/Position.hs b/src/Language/Rust/Data/Position.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Data/Position.hs @@ -0,0 +1,220 @@ +{-| +Module : Language.Rust.Data.Position +Description : Positions and spans in files +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : GHC + +Everything to do with describing a position or a contiguous region in a file. +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Language.Rust.Data.Position ( + -- * Positions in files + Position(..), + prettyPosition, + maxPos, + minPos, + initPos, + incPos, + retPos, + incOffset, + + -- * Spans in files + Span(..), + unspan, + prettySpan, + subsetOf, + (#), + Spanned(..), + Located(..), +) where + +import GHC.Generics ( Generic ) + +import Control.DeepSeq ( NFData ) +import Data.Data ( Data ) +import Data.Typeable ( Typeable ) + +import Language.Rust.Parser.NonEmpty ( NonEmpty(..) ) +import Data.Monoid as Mon +import Data.Semigroup as Sem + +-- | A position in a source file. The row and column information is kept only for its convenience +-- and human-readability. Analogous to the information encoded in a cursor. +data Position = Position { + absoluteOffset :: {-# UNPACK #-} !Int, -- ^ absolute offset the source file. + row :: {-# UNPACK #-} !Int, -- ^ row (line) in the source file. + col :: {-# UNPACK #-} !Int -- ^ column in the source file. + } + | NoPosition + deriving (Eq, Ord, Data, Typeable, Generic, NFData) + +-- | Field names are not shown +instance Show Position where + showsPrec _ NoPosition = showString "NoPosition" + showsPrec p (Position a r c) = showParen (p >= 11) + ( showString "Position" + . showString " " . showsPrec 11 a + . showString " " . showsPrec 11 r + . showString " " . showsPrec 11 c ) + +-- | Pretty print a 'Position' +prettyPosition :: Position -> String +prettyPosition NoPosition = "???" +prettyPosition (Position _ r c) = show r ++ ":" ++ show c + +-- | Maximum of two positions, bias for actual positions. +-- +-- >>> maxPos (Position 30 5 8) (Position 37 5 15) +-- Position 37 5 15 +-- +-- >>> maxPos NoPosition (Position 30 5 8) +-- Position 30 5 8 +-- +{-# INLINE maxPos #-} +maxPos :: Position -> Position -> Position +maxPos NoPosition p2 = p2 +maxPos p1 NoPosition = p1 +maxPos p1@(Position a1 _ _) p2@(Position a2 _ _) = if a1 > a2 then p1 else p2 + +-- | Maximum and minimum positions, bias for actual positions. +-- +-- >>> minPos (Position 30 5 8) (Position 37 5 15) +-- Position 30 5 8 +-- +-- >>> minPos NoPosition (Position 30 5 8) +-- Position 30 5 8 +-- +{-# INLINE minPos #-} +minPos :: Position -> Position -> Position +minPos NoPosition p2 = p2 +minPos p1 NoPosition = p1 +minPos p1@(Position a1 _ _) p2@(Position a2 _ _) = if a1 < a2 then p1 else p2 + +-- | Starting position in a file. +{-# INLINE initPos #-} +initPos :: Position +initPos = Position 0 1 0 + +-- | Advance column a certain number of times. +{-# INLINE incPos #-} +incPos :: Position -> Int -> Position +incPos NoPosition _ = NoPosition +incPos p@Position{ absoluteOffset = a, col = c } offset = p { absoluteOffset = a + offset, col = c + offset } + +-- | Advance to the next line. +{-# INLINE retPos #-} +retPos :: Position -> Position +retPos NoPosition = NoPosition +retPos (Position a r _) = Position { absoluteOffset = a + 1, row = r + 1, col = 1 } + +-- | Advance only the absolute offset, not the row and column information. Only use this if you +-- know what you are doing! +{-# INLINE incOffset #-} +incOffset :: Position -> Int -> Position +incOffset NoPosition _ = NoPosition +incOffset p@Position{ absoluteOffset = a } offset = p { absoluteOffset = a + offset } + +-- | Spans represent a contiguous region of code, delimited by two 'Position's. The endpoints are +-- inclusive. Analogous to the information encoded in a selection. +data Span = Span { lo, hi :: !Position } + deriving (Eq, Ord, Data, Typeable, Generic, NFData) + +-- | Field names are not shown +instance Show Span where + showsPrec p (Span l h) = showParen (p >= 11) + ( showString "Span" + . showString " " . showsPrec 11 l + . showString " " . showsPrec 11 h ) + + +-- | Check if a span is a subset of another span +subsetOf :: Span -> Span -> Bool +Span l1 h1 `subsetOf` Span l2 h2 = minPos l1 l2 == l1 && maxPos h1 h2 == h2 + +-- | Convenience function lifting 'Mon.<>' to work on all 'Located' things +{-# INLINE (#) #-} +(#) :: (Located a, Located b) => a -> b -> Span +left # right = spanOf left Mon.<> spanOf right + +-- | smallest covering 'Span' +instance Sem.Semigroup Span where + {-# INLINE (<>) #-} + Span l1 h1 <> Span l2 h2 = Span (l1 `minPos` l2) (h1 `maxPos` h2) + +instance Mon.Monoid Span where + {-# INLINE mempty #-} + mempty = Span NoPosition NoPosition + + {-# INLINE mappend #-} + mappend = (Sem.<>) + +-- | Pretty print a 'Span' +prettySpan :: Span -> String +prettySpan (Span lo' hi') = show lo' ++ " - " ++ show hi' + +-- | A "tagging" of something with a 'Span' that describes its extent. +data Spanned a = Spanned a {-# UNPACK #-} !Span + deriving (Eq, Ord, Data, Typeable, Generic, NFData) + +-- | Extract the wrapped value from 'Spanned' +{-# INLINE unspan #-} +unspan :: Spanned a -> a +unspan (Spanned x _) = x + +instance Functor Spanned where + {-# INLINE fmap #-} + fmap f (Spanned x s) = Spanned (f x) s + +instance Applicative Spanned where + {-# INLINE pure #-} + pure x = Spanned x mempty + + {-# INLINE (<*>) #-} + Spanned f s1 <*> Spanned x s2 = Spanned (f x) (s1 Sem.<> s2) + +instance Monad Spanned where + return = pure + Spanned x s1 >>= f = let Spanned y s2 = f x in Spanned y (s1 Sem.<> s2) + +instance Show a => Show (Spanned a) where + show = show . unspan + + +-- | Describes nodes that can be located - their span can be extracted from them. In general, we +-- expect that for a value constructed as @Con x y z@ where @Con@ is an arbitrary constructor +-- +-- prop> (spanOf x <> spanOf y <> spanOf z) `subsetOf` spanOf (Con x y z) == True +-- +class Located a where + spanOf :: a -> Span + +instance Located Span where + {-# INLINE spanOf #-} + spanOf = id + +instance Located (Spanned a) where + {-# INLINE spanOf #-} + spanOf (Spanned _ s) = s + +instance Located a => Located (Maybe a) where + {-# INLINE spanOf #-} + spanOf = foldMap spanOf + +-- | /O(n)/ time complexity +instance Located a => Located [a] where + {-# INLINE spanOf #-} + spanOf = foldMap spanOf + +-- | /O(n)/ time complexity +instance Located a => Located (NonEmpty a) where + {-# INLINE spanOf #-} + spanOf = foldMap spanOf + + diff --git a/src/Language/Rust/Parser.hs b/src/Language/Rust/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Parser.hs @@ -0,0 +1,153 @@ +{-| +Module : Language.Rust.Parser +Description : Parsing and lexing +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : GHC + +Selecting the right parser may require adding an annotation or using @-XTypeApplications@ to avoid +an "Ambiguous type variable" error. + +Using 'Control.Monad.void' (as in the examples below) exploits the fact that most AST nodes are +instances of 'Functor' to discard the 'Span' annotation that is attached to most parsed AST nodes. +Conversely, if you wish to extract the 'Span' annotation, the 'Language.Rust.Syntax.AST.Located' +typeclass provides a 'Language.Rust.Syntax.AST.spanOf' method. + +The examples below assume the following GHCi flags and imports: + +>>> :set -XTypeApplications -XOverloadedStrings +>>> import Language.Rust.Syntax.AST +>>> import Control.Monad ( void ) +>>> import System.IO + +-} +{-# LANGUAGE FlexibleInstances #-} + +module Language.Rust.Parser ( + -- * Parsing + parse, + parse', + readSourceFile, + readTokens, + Parse(..), + P, + execParser, + execParserTokens, + initPos, + Span, + + -- * Lexing + lexToken, + lexNonSpace, + lexTokens, + translateLit, + + -- * Input stream + readInputStream, + hReadInputStream, + inputStreamToString, + inputStreamFromString, + + -- * Error reporting + lexicalError, + parseError, + ParseFail(..), +) where + +import Language.Rust.Syntax + +import Language.Rust.Data.InputStream +import Language.Rust.Data.Position ( Position, Span, Spanned, initPos ) + +import Language.Rust.Parser.Internal +import Language.Rust.Parser.Lexer ( lexToken, lexNonSpace, lexTokens, lexicalError ) +import Language.Rust.Parser.Literals ( translateLit ) +import Language.Rust.Parser.ParseMonad ( P, execParser, parseError, pushToken, ParseFail(..) ) + +import Control.Exception ( throw ) +import Data.Foldable ( traverse_ ) +import System.IO ( Handle ) + +-- | Parse something from an input stream (it is assumed the initial position is 'initPos'). +-- +-- >>> fmap void $ parse @(Expr Span) "x + 1" +-- Right (Binary [] AddOp (PathExpr [] Nothing (Path False [PathSegment "x" Nothing ()] ()) ()) +-- (Lit [] (Int Dec 1 Unsuffixed ()) ()) +-- ()) +-- +-- >>> fmap void $ parse @(Expr Span) "x + " +-- Left (parse failure at 1:4 (Syntax error: unexpected `' (expected an expression))) +-- +parse :: Parse a => InputStream -> Either ParseFail a +parse is = execParser parser is initPos + +-- | Same as 'parse', but throws a 'ParseFail' exception if it cannot parse. This function is +-- intended for situations in which you are already stuck catching exceptions - otherwise you should +-- prefer 'parse'. +-- +-- >>> void $ parse' @(Expr Span) "x + 1" +-- Binary [] AddOp (PathExpr [] Nothing (Path False [PathSegment "x" Nothing ()] ()) ()) +-- (Lit [] (Int Dec 1 Unsuffixed ()) ()) +-- () +-- +-- >>> void $ parse' @(Expr Span) "x + " +-- *** Exception: parse failure at 1:4 (Syntax error: unexpected `' (expected an expression)) +-- +parse' :: Parse a => InputStream -> a +parse' = either throw id . parse + +-- | Same as 'execParser', but working from a list of tokens instead of an 'InputStream'. +execParserTokens :: P a -> [Spanned Token] -> Position -> Either ParseFail a +execParserTokens p toks = execParser (pushTokens toks *> p) (inputStreamFromString "") + where pushTokens = traverse_ pushToken . reverse + +-- | Given a handle to a Rust source file, read that file and parse it into a 'SourceFile' +-- +-- >>> writeFile "empty_main.rs" "fn main() { }" +-- >>> fmap void $ withFile "empty_main.rs" ReadMode readSourceFile +-- SourceFile Nothing [] [Fn [] InheritedV "main" +-- (FnDecl [] Nothing False ()) +-- Normal NotConst Rust +-- (Generics [] [] (WhereClause [] ()) ()) +-- (Block [] Normal ()) ()] +-- +readSourceFile :: Handle -> IO (SourceFile Span) +readSourceFile hdl = parse' <$> hReadInputStream hdl + +-- | Given a path pointing to a Rust source file, read that file and lex it (ignoring whitespace) +-- +-- >>> writeFile "empty_main.rs" "fn main() { }" +-- >>> withFile "empty_main.rs" ReadMode readTokens +-- [fn,main,(,),{,}] +-- +readTokens :: Handle -> IO [Spanned Token] +readTokens hdl = do + inp <- hReadInputStream hdl + case execParser (lexTokens lexNonSpace) inp initPos of + Left pf -> throw pf + Right x -> pure x + +-- | Describes things that can be parsed +class Parse a where + -- | Complete parser (fails if not all of the input is consumed) + parser :: P a + +instance Parse (Lit Span) where parser = parseLit +instance Parse (Attribute Span) where parser = parseAttr +instance Parse (Ty Span) where parser = parseTy +instance Parse (Pat Span) where parser = parsePat +instance Parse (Expr Span) where parser = parseExpr +instance Parse (Stmt Span) where parser = parseStmt +instance Parse (Item Span) where parser = parseItem +instance Parse (SourceFile Span) where parser = parseSourceFile +instance Parse TokenTree where parser = parseTt +instance Parse TokenStream where parser = parseTokenStream +instance Parse (Block Span) where parser = parseBlock +instance Parse (ImplItem Span) where parser = parseImplItem +instance Parse (TraitItem Span) where parser = parseTraitItem +instance Parse (TyParam Span) where parser = parseTyParam +instance Parse (LifetimeDef Span) where parser = parseLifetimeDef +instance Parse (Generics Span) where parser = parseGenerics +instance Parse (WhereClause Span) where parser = parseWhereClause diff --git a/src/Language/Rust/Parser/Internal.y b/src/Language/Rust/Parser/Internal.y new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Parser/Internal.y @@ -0,0 +1,2123 @@ +{ +{-| +Module : Language.Rust.Parser.Internal +Description : Rust parser +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : GHC + +The parsers in this file are all re-exported to 'Language.Rust.Parser' via the 'Parse' class. The +parsers are based off of: + + * primarily the reference @rustc@ [implementation][0] + * some documentation on [rust-lang][2] + * drawing a couple ideas from a slightly outdated [ANTLR grammar][1] + +To get information about transition states and such, run + +> happy --info=happyinfo.txt -o /dev/null src/Language/Rust/Parser/Internal.y + + [0]: https://github.com/rust-lang/rust/blob/master/src/libsyntax/parse/parser.rs + [1]: https://github.com/rust-lang/rust/blob/master/src/grammar/parser-lalr.y + [2]: https://doc.rust-lang.org/grammar.html +-} +{-# OPTIONS_HADDOCK hide, not-home #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} + +module Language.Rust.Parser.Internal ( + -- * Parsers + parseAttr, + parseBlock, + parseExpr, + parseGenerics, + parseImplItem, + parseItem, + parseLifetimeDef, + parseLit, + parsePat, + parseSourceFile, + parseStmt, + parseTokenStream, + parseTraitItem, + parseTt, + parseTy, + parseTyParam, + parseWhereClause, + parseStmts, + parseItems, + parseImplItems, +) where + +import Language.Rust.Syntax + +import Language.Rust.Data.Ident ( Ident(..), mkIdent, IdentName(..) ) +import Language.Rust.Data.Position + +import Language.Rust.Parser.Lexer ( lexNonSpace, lexShebangLine ) +import Language.Rust.Parser.ParseMonad ( pushToken, getPosition, P, parseError ) +import Language.Rust.Parser.Literals ( translateLit ) +import Language.Rust.Parser.Reversed + +import Data.Foldable ( toList ) +import Data.List ( (\\), isSubsequenceOf, sort ) +import Data.Semigroup ( (<>) ) + +import Text.Read ( readMaybe ) + +import Language.Rust.Parser.NonEmpty ( NonEmpty(..), (<|), (|>), (|:) ) +import qualified Language.Rust.Parser.NonEmpty as N +} + +-- in order to document the parsers, we have to alias them +%name parseLit lit +%name parseAttr export_attribute +%name parseTy ty +%name parsePat pat +%name parseStmt stmt +%name parseExpr expr +%name parseItem mod_item +%name parseSourceFileContents source_file +%name parseBlock export_block +%name parseImplItem impl_item +%name parseTraitItem trait_item +%name parseTt token_tree +%name parseTokenStream token_stream +%name parseTyParam ty_param +%name parseLifetimeDef lifetime_def +%name parseWhereClause where_clause +%name parseGenerics generics + +%name parseStmts stmts +%name parseItems mod_items +%name parseImplItems impl_items + +%tokentype { Spanned Token } +%lexer { lexNonSpace >>= } { Spanned Eof _ } +%monad { P } { >>= } { return } + +%errorhandlertype explist +%error { expParseError } + +%expect 0 + +%token + + -- Expression-operator symbols. + '=' { Spanned Equal _ } + '<' { Spanned Less _ } + '>' { Spanned Greater _ } + '!' { Spanned Exclamation _ } + '~' { Spanned Tilde _ } + + '+' { Spanned Plus _ } + '-' { Spanned Minus _ } + '*' { Spanned Star _ } + '/' { Spanned Slash _ } + '%' { Spanned Percent _ } + '^' { Spanned Caret _ } + '&' { Spanned Ampersand _ } + '|' { Spanned Pipe _ } + + -- Structural symbols. + '@' { Spanned At _ } + '...' { Spanned DotDotDot _ } + '..=' { Spanned DotDotEqual _ } + '..' { Spanned DotDot _ } + '.' { Spanned Dot _ } + ',' { Spanned Comma _ } + ';' { Spanned Semicolon _ } + '::' { Spanned ModSep _ } + ':' { Spanned Colon _ } + '->' { Spanned RArrow _ } + '<-' { Spanned LArrow _ } + '=>' { Spanned FatArrow _ } + '#' { Spanned Pound _ } + '$' { Spanned Dollar _ } + '?' { Spanned Question _ } + '#!' { Spanned Shebang _ } + + '||' { Spanned PipePipe _ } + '&&' { Spanned AmpersandAmpersand _ } + '>=' { Spanned GreaterEqual _ } + '>>=' { Spanned GreaterGreaterEqual _ } + '<<' { Spanned LessLess _ } + '>>' { Spanned GreaterGreater _ } + + '==' { Spanned EqualEqual _ } + '!=' { Spanned NotEqual _ } + '<=' { Spanned LessEqual _ } + '<<=' { Spanned LessLessEqual _ } + '-=' { Spanned MinusEqual _ } + '&=' { Spanned AmpersandEqual _ } + '|=' { Spanned PipeEqual _ } + '+=' { Spanned PlusEqual _ } + '*=' { Spanned StarEqual _ } + '/=' { Spanned SlashEqual _ } + '^=' { Spanned CaretEqual _ } + '%=' { Spanned PercentEqual _ } + + '(' { Spanned (OpenDelim Paren) _ } + '[' { Spanned (OpenDelim Bracket) _ } + '{' { Spanned (OpenDelim Brace) _ } + ')' { Spanned (CloseDelim Paren) _ } + ']' { Spanned (CloseDelim Bracket) _ } + '}' { Spanned (CloseDelim Brace) _ } + + -- Embedded code + EMBEDDED_EXPR { Spanned (EmbeddedCode _) _ } + EMBEDDED_IDENT { Spanned (EmbeddedIdent _) _ } + + -- Literals. + byte { Spanned (LiteralTok ByteTok{} _) _ } + char { Spanned (LiteralTok CharTok{} _) _ } + int { Spanned (LiteralTok IntegerTok{} _) _ } + float { Spanned (LiteralTok FloatTok{} _) _ } + str { Spanned (LiteralTok StrTok{} _) _ } + byteStr { Spanned (LiteralTok ByteStrTok{} _) _ } + rawStr { Spanned (LiteralTok StrRawTok{} _) _ } + rawByteStr { Spanned (LiteralTok ByteStrRawTok{} _) _ } + + -- Strict keywords used in the language + as { Spanned (IdentTok "as") _ } + box { Spanned (IdentTok "box") _ } + break { Spanned (IdentTok "break") _ } + const { Spanned (IdentTok "const") _ } + continue { Spanned (IdentTok "continue") _ } + crate { Spanned (IdentTok "crate") _ } + else { Spanned (IdentTok "else") _ } + enum { Spanned (IdentTok "enum") _ } + extern { Spanned (IdentTok "extern") _ } + false { Spanned (IdentTok "false") _ } + fn { Spanned (IdentTok "fn") _ } + for { Spanned (IdentTok "for") _ } + if { Spanned (IdentTok "if") _ } + impl { Spanned (IdentTok "impl") _ } + in { Spanned (IdentTok "in") _ } + let { Spanned (IdentTok "let") _ } + loop { Spanned (IdentTok "loop") _ } + match { Spanned (IdentTok "match") _ } + mod { Spanned (IdentTok "mod") _ } + move { Spanned (IdentTok "move") _ } + mut { Spanned (IdentTok "mut") _ } + pub { Spanned (IdentTok "pub") _ } + ref { Spanned (IdentTok "ref") _ } + return { Spanned (IdentTok "return") _ } + Self { Spanned (IdentTok "Self") _ } + self { Spanned (IdentTok "self") _ } + static { Spanned (IdentTok "static") _ } + struct { Spanned (IdentTok "struct") _ } + super { Spanned (IdentTok "super") _ } + trait { Spanned (IdentTok "trait") _ } + true { Spanned (IdentTok "true") _ } + type { Spanned (IdentTok "type") _ } + unsafe { Spanned (IdentTok "unsafe") _ } + use { Spanned (IdentTok "use") _ } + where { Spanned (IdentTok "where") _ } + while { Spanned (IdentTok "while") _ } + do { Spanned (IdentTok "do") _ } + + -- Keywords reserved for future use + abstract { Spanned (IdentTok "abstract") _ } + alignof { Spanned (IdentTok "alignof") _ } + become { Spanned (IdentTok "become") _ } + final { Spanned (IdentTok "final") _ } + macro { Spanned (IdentTok "macro") _ } + offsetof { Spanned (IdentTok "offsetof") _ } + override { Spanned (IdentTok "override") _ } + priv { Spanned (IdentTok "priv") _ } + proc { Spanned (IdentTok "proc") _ } + pure { Spanned (IdentTok "pure") _ } + sizeof { Spanned (IdentTok "sizeof") _ } + typeof { Spanned (IdentTok "typeof") _ } + unsized { Spanned (IdentTok "unsized") _ } + virtual { Spanned (IdentTok "virtual") _ } + + -- Weak keywords, have special meaning only in specific contexts. + default { Spanned (IdentTok "default") _ } + union { Spanned (IdentTok "union") _ } + catch { Spanned (IdentTok "catch") _ } + auto { Spanned (IdentTok "auto") _ } + yield { Spanned (IdentTok "yield") _ } + dyn { Spanned (IdentTok "dyn") _ } + + -- Comments + outerDoc { Spanned (Doc _ Outer _) _ } + innerDoc { Spanned (Doc _ Inner _) _ } + + -- Identifiers. + '_' { Spanned (IdentTok "_") _ } + IDENT { Spanned IdentTok{} _ } + + -- Lifetimes. + LIFETIME { Spanned (LifetimeTok _) _ } + + -- Interpolated + ntItem { Spanned (Interpolated (NtItem $$)) _ } + ntBlock { Spanned (Interpolated (NtBlock $$)) _ } + ntStmt { Spanned (Interpolated (NtStmt $$)) _ } + ntPat { Spanned (Interpolated (NtPat $$)) _ } + ntExpr { Spanned (Interpolated (NtExpr $$)) _ } + ntTy { Spanned (Interpolated (NtTy $$)) _ } + ntIdent { Spanned (Interpolated (NtIdent _)) _ } + ntPath { Spanned (Interpolated (NtPath $$)) _ } + ntTT { Spanned (Interpolated (NtTT $$)) _ } + ntArm { Spanned (Interpolated (NtArm $$)) _ } + ntImplItem { Spanned (Interpolated (NtImplItem $$)) _ } + ntTraitItem { Spanned (Interpolated (NtTraitItem $$)) _ } + ntGenerics { Spanned (Interpolated (NtGenerics $$)) _ } + ntWhereClause { Spanned (Interpolated (NtWhereClause $$)) _ } + ntArg { Spanned (Interpolated (NtArg $$)) _ } + ntLit { Spanned (Interpolated (NtLit $$)) _ } + +-- 'SEG' needs to be lower than '::' for path segments +%nonassoc SEG + +-- 'mut' needs to be lower precedence than 'IDENT' so that in 'pat', something like "&mut x" +-- associates the "mut" to a refence pattern and not to the identifier pattern "x". +-- +-- 'DEF' is for the empty case of 'def', which needs to _not_ be taken when there is a 'default' +-- token available. +-- +-- 'EQ' is for differentiating the 'where ty' from 'where ty = ty' case in where clause +-- predicates, since the former needs to _not_ be taken when there is a '=' token available. +-- +-- '::' is so that the remainder of mod paths in attributes are not gobbled as just raw tokens +%nonassoc mut DEF EQ '::' + +-- These are all identifiers of sorts ('union' and 'default' are "weak" keywords) +%nonassoc IDENT ntIdent default union catch self Self super auto dyn crate + +-- These are all very low precedence unary operators +%nonassoc box return yield break continue for IMPLTRAIT LAMBDA + +-- 'static' needs to have higher precedenc than 'LAMBDA' so that statements starting in static get +-- considered as static items, and not a static lambda +%nonassoc static + +-- These are the usual arithmetic precedences. 'UNARY' is introduced here for '*', '!', '-', '&' +%right '=' '>>=' '<<=' '-=' '+=' '*=' '/=' '^=' '|=' '&=' '%=' +%right '<-' +%nonassoc SINGLERNG +%nonassoc INFIXRNG +%nonassoc POSTFIXRNG +%nonassoc PREFIXRNG +%nonassoc '..' '...' '..=' +%left '||' +%left '&&' +%left '==' '!=' '<' '>' '<=' '>=' +%left '|' +%left '^' +%left '&' +%left '<<' '>>' +%left '+' '-' +%left '*' '/' '%' +%nonassoc ':' as +%nonassoc UNARY + +-- These are all generated precedence tokens. +-- +-- * 'FIELD' for field access expressions (which bind less tightly than '.' for method calls) +-- * 'VIS' for adjusting the precedence of 'pub' compared to other visbility modifiers (see 'vis') +-- * 'PATH' boosts the precedences of paths in types and expressions +-- * 'WHERE' is for non-empty where clauses +-- +%nonassoc FIELD VIS PATH WHERE NOSEMI + +-- These are postfix operators. +%nonassoc '?' '.' + +-- Delimiters have the highest precedence. 'ntBlock' counts as a delimiter since it always starts +-- and ends with '{' and '}' +%nonassoc '{' ntBlock '[' '(' '!' ';' + +%% + +-- Unwraps the IdentTok into just an Ident +-- For questionable reasons of backwards compatibility, 'union', 'default', and 'catch' can be used +-- as identifiers, even if they are also keywords. They are "contextual" keywords. +-- +-- Union's RFC: https://github.com/rust-lang/rfcs/blob/master/text/1444-union.md +ident :: { Spanned Ident } + : ntIdent { fmap (\(Interpolated (NtIdent i)) -> i) $1 } + | union { toIdent $1 } + | default { toIdent $1 } + | catch { toIdent $1 } + | auto { toIdent $1 } + | dyn { toIdent $1 } + | IDENT { toIdent $1 } + | EMBEDDED_IDENT { let (Spanned (EmbeddedIdent i) s) = $1 in Spanned (mkIdent ("${i|" ++ i ++ "|}")) s } + +binding_mode1_ident :: { Spanned Ident } + : ntIdent { fmap (\(Interpolated (NtIdent i)) -> i) $1 } + | union { toIdent $1 } + | default { toIdent $1 } + | catch { toIdent $1 } + | auto { toIdent $1 } + | dyn { toIdent $1 } + | IDENT { toIdent $1 } + +-- This should precede any '>' token which could be absorbed in a '>>', '>=', or '>>=' token. Its +-- purpose is to check if the lookahead token starts with '>' but contains more that. If that is +-- the case, it pushes two tokens, the first of which is '>'. We exploit the %% feature of threaded +-- lexers to discard what would have been the troublesome '>>', '>=', or '>>=' token. +gt :: { () } + : {- empty -} {%% \(Spanned tok s) -> + let s' = nudge 1 0 s; s'' = nudge 0 (-1) s in + case tok of + GreaterGreater -> pushToken (Spanned Greater s') *> pushToken (Spanned Greater s'') + GreaterEqual -> pushToken (Spanned Equal s') *> pushToken (Spanned Greater s'') + GreaterGreaterEqual -> pushToken (Spanned GreaterEqual s') *> pushToken (Spanned Greater s'') + _ -> pushToken (Spanned tok s) + } + +-- This should precede any '|' token which could be absorbed in a '||' token. This works in the same +-- way as 'gt'. +pipe :: { () } + : {- empty -} {%% \(Spanned tok s) -> + let s' = nudge 1 0 s; s'' = nudge 0 (-1) s in + case tok of + PipePipe -> pushToken (Spanned Pipe s') *> pushToken (Spanned Pipe s'') + _ -> pushToken (Spanned tok s) + } + +------------- +-- Utility -- +------------- + +-- | One or more occurences of 'p' +some(p) :: { Reversed NonEmpty p } + : some(p) p { let Reversed xs = $1 in Reversed ($2 <| xs) } + | p { [$1] } + +-- | Zero or more occurences of 'p' +many(p) :: { [ p ] } + : some(p) { toList $1 } + | {- empty -} { [] } + +-- | One or more occurences of 'p', seperated by 'sep' +sep_by1(p,sep) :: { Reversed NonEmpty p } + : sep_by1(p,sep) sep p { let Reversed xs = $1 in Reversed ($3 <| xs) } + | p { [$1] } + +-- | Zero or more occurrences of 'p', separated by 'sep' +sep_by(p,sep) :: { [ p ] } + : sep_by1(p,sep) { toList $1 } + | {- empty -} { [] } + +-- | One or more occurrences of 'p', seperated by 'sep', optionally ending in 'sep' +sep_by1T(p,sep) :: { Reversed NonEmpty p } + : sep_by1(p,sep) sep { $1 } + | sep_by1(p,sep) { $1 } + +-- | Zero or more occurences of 'p', seperated by 'sep', optionally ending in 'sep' (only if there +-- is at least one 'p') +sep_byT(p,sep) :: { [ p ] } + : sep_by1T(p,sep) { toList $1 } + | {- empty -} { [] } + + +-------------------------- +-- Whole file +-------------------------- + +-- shebang is dealt with at the top level, outside Happy/Alex +source_file :: { ([Attribute Span],[Item Span]) } + : inner_attrs many(mod_item) { (toList $1, $2) } + | many(mod_item) { ([], $1) } + + +-------------------------- +-- Attributes +-------------------------- + +outer_attribute :: { Attribute Span } + : '#' '[' mod_path token_stream_no_embed ']' { Attribute Outer $3 $4 ($1 # $>) } + | outerDoc { let Spanned (Doc str _ l) x = $1 in SugaredDoc Outer l str x } + +inner_attribute :: { Attribute Span } + : '#' '!' '[' mod_path token_stream_no_embed ']' { Attribute Inner $4 $5 ($1 # $>) } + | '#!' '[' mod_path token_stream_no_embed ']' { Attribute Inner $3 $4 ($1 # $>) } + | innerDoc { let Spanned (Doc str _ l) x = $1 in SugaredDoc Inner l str x } + +-- TODO: for some precedence related reason, using 'some' here doesn't work +inner_attrs :: { Reversed NonEmpty (Attribute Span) } + : inner_attrs inner_attribute { let Reversed xs = $1 in Reversed ($2 <| xs) } + | inner_attribute { [$1] } + + +-------------- +-- Literals -- +-------------- + +lit :: { Lit Span } + : ntLit { $1 } + | byte { lit $1 } + | char { lit $1 } + | int { lit $1 } + | float { lit $1 } + | true { lit $1 } + | false { lit $1 } + | string { $1 } + +string :: { Lit Span } + : str { lit $1 } + | rawStr { lit $1 } + | byteStr { lit $1 } + | rawByteStr { lit $1 } + + +----------- +-- Paths -- +----------- + +-- parse_qualified_path(PathStyle::Type) +-- qual_path :: Spanned (NonEmpty (Ident, PathParameters Span)) -> P (Spanned (QSelf Span, Path Span)) +qual_path(segs) :: { Spanned (QSelf Span, Path Span) } + : '<' qual_path_suf(segs) { let Spanned x _ = $2 in Spanned x ($1 # $2) } + | lt_ty_qual_path as ty_path '>' '::' segs { + let Path g segsTy x = $3 in + Spanned (QSelf (unspan $1) (length segsTy), Path g (segsTy <> toList $6) x) ($1 # $>) + } + +-- Basically a qualified path, but ignoring the very first '<' token +qual_path_suf(segs) :: { Spanned (QSelf Span, Path Span) } + : ty '>' '::' segs { Spanned (QSelf $1 0, Path False (toList $4) (spanOf $4)) ($1 # $>) } + | ty as ty_path '>' '::' segs { + let Path g segsTy x = $3 in + Spanned (QSelf $1 (length segsTy), Path g (segsTy <> toList $6) x) ($1 # $>) + } + +-- Usually qual_path_suf is for... type paths! This consumes these but with a starting '<<' token. +-- The underlying type has the right 'Span' (it doesn't include the very first '<', while the +-- 'Spanned' wrapper does) +lt_ty_qual_path :: { Spanned (Ty Span) } + : '<<' qual_path_suf(path_segments_without_colons) + { let (qself,path) = unspan $2 in Spanned (PathTy (Just qself) path (nudge 1 0 ($1 # $2))) ($1 # $2) } + +-- parse_generic_args() but with the '<' '>' +generic_values :: { Spanned ([Lifetime Span], [Ty Span], [(Ident, Ty Span)]) } + : '<' sep_by1(lifetime,',') ',' sep_by1(ty,',') ',' sep_by1T(binding,',') gt '>' + { Spanned (toList $2, toList $4, toList $6) ($1 # $>) } + | '<' sep_by1(lifetime,',') ',' sep_by1T(ty,',') gt '>' + { Spanned (toList $2, toList $4, [] ) ($1 # $>) } + | '<' sep_by1(lifetime,',') ',' sep_by1T(binding,',') gt '>' + { Spanned (toList $2, [], toList $4) ($1 # $>) } + | '<' sep_by1T(lifetime,',') gt '>' + { Spanned (toList $2, [], [] ) ($1 # $>) } + | '<' sep_by1(ty,',') ',' sep_by1T(binding,',') gt '>' + { Spanned ([], toList $2, toList $4) ($1 # $>) } + | '<' sep_by1T(ty,',') gt '>' + { Spanned ([], toList $2, [] ) ($1 # $>) } + | '<' sep_by1T(binding,',') gt '>' + { Spanned ([], [], toList $2) ($1 # $>) } + | '<' gt '>' + { Spanned ([], [], [] ) ($1 # $>) } + | lt_ty_qual_path ',' sep_by1(ty,',') ',' sep_by1T(binding,',') gt '>' + { Spanned ([], unspan $1 : toList $3, toList $5) ($1 # $>) } + | lt_ty_qual_path ',' sep_by1T(ty,',') gt '>' + { Spanned ([], unspan $1 : toList $3, [] ) ($1 # $>) } + | lt_ty_qual_path ',' sep_by1T(binding,',') gt '>' + { Spanned ([], [unspan $1],toList $3) ($1 # $>) } + | lt_ty_qual_path gt '>' + { Spanned ([], [unspan $1],[] ) ($1 # $>) } + +binding :: { (Ident, Ty Span) } + : ident '=' ty { (unspan $1, $3) } + + +-- Type related: +-- parse_path(PathStyle::Type) +ty_path :: { Path Span } + : ntPath { $1 } + | path_segments_without_colons { Path False $1 (spanOf $1) } + | '::' path_segments_without_colons { Path True $2 ($1 # $2) } + +ty_qual_path :: { Spanned (QSelf Span, Path Span) } + : qual_path(path_segments_without_colons) { $1 } + +-- parse_path_segments_without_colons() +path_segments_without_colons :: { [PathSegment Span] } + : sep_by1(path_segment_without_colons, '::') %prec SEG { toList $1 } + +-- No corresponding function - see path_segments_without_colons +path_segment_without_colons :: { PathSegment Span } + : self_or_ident path_parameter { PathSegment (unspan $1) $2 ($1 # $>) } + +path_parameter :: { Maybe (PathParameters Span) } + : generic_values { let (lts, tys, bds) = unspan $1 + in Just (AngleBracketed lts tys bds (spanOf $1)) } + | '(' sep_byT(ty,',') ')' { Just (Parenthesized $2 Nothing ($1 # $>)) } + | '(' sep_byT(ty,',') ')' '->' ty_no_plus { Just (Parenthesized $2 (Just $>) ($1 # $>)) } + | {- empty -} %prec IDENT { Nothing } + + +-- Expression related: +-- parse_path(PathStyle::Expr) +expr_path :: { Path Span } + : ntPath { $1 } + | path_segments_with_colons { Path False (toList $1) (spanOf $1) } + | '::' path_segments_with_colons { Path True (toList $2) ($1 # $2) } + +expr_qual_path :: { Spanned (QSelf Span, Path Span) } + : qual_path(path_segments_with_colons) { $1 } + +-- parse_path_segments_with_colons() +path_segments_with_colons :: { Reversed NonEmpty (PathSegment Span) } + : self_or_ident + { [PathSegment (unspan $1) Nothing (spanOf $1)] } + | path_segments_with_colons '::' self_or_ident + { $1 <> [PathSegment (unspan $3) Nothing (spanOf $3)] } + | path_segments_with_colons '::' generic_values + {% + case (unsnoc $1, unspan $3) of + ((rst, PathSegment i Nothing x), (lts, tys, bds)) -> + let seg = PathSegment i (Just (AngleBracketed lts tys bds (spanOf $3))) (x # $3) + in pure $ snoc rst seg + _ -> fail "invalid path segment in expression path" + } + +-- Mod related: +-- parse_path(PathStyle::Mod) +-- +-- TODO: This is O(n^2) in the segment length! I haven't been able to make the grammar work out in +-- order to refactor this nicely +mod_path :: { Path Span } + : ntPath { $1 } + | self_or_ident { Path False [PathSegment (unspan $1) Nothing (spanOf $1)] (spanOf $1) } + | '::' self_or_ident { Path True [PathSegment (unspan $2) Nothing (spanOf $2)] ($1 # $>) } + | mod_path '::' self_or_ident { + let Path g segs _ = $1 in + Path g (segs <> [PathSegment (unspan $3) Nothing (spanOf $3) ]) ($1 # $3) + } + +self_or_ident :: { Spanned Ident } + : ident { $1 } + | crate { Spanned "crate" (spanOf $1) } + | self { Spanned "self" (spanOf $1) } + | Self { Spanned "Self" (spanOf $1) } + | super { Spanned "super" (spanOf $1) } + + +----------- +-- Types -- +----------- + +lifetime :: { Lifetime Span } + : LIFETIME { let Spanned (LifetimeTok (Ident (Name l) _ _)) s = $1 in Lifetime l s } + +-- parse_trait_ref() +trait_ref :: { TraitRef Span } + : ty_path { TraitRef $1 } + +-- parse_ty() +-- See https://github.com/rust-lang/rfcs/blob/master/text/0438-precedence-of-plus.md +-- All types, including trait types with plus +ty :: { Ty Span } + : ty_no_plus { $1 } + | poly_trait_ref_mod_bound '+' sep_by1T(ty_param_bound_mod,'+') { TraitObject ($1 <| toNonEmpty $3) ($1 # $3) } + +-- parse_ty_no_plus() +ty_no_plus :: { Ty Span } + : ntTy { $1 } + | no_for_ty { $1 } + | for_ty_no_plus { $1 } + +-- All types not starting with a '(' or '<' +ty_prim :: { Ty Span } + : no_for_ty_prim { $1 } + | for_ty_no_plus { $1 } + | poly_trait_ref_mod_bound '+' sep_by1T(ty_param_bound_mod,'+') { TraitObject ($1 <| toNonEmpty $3) ($1 # $3) } + +-- All (non-sum) types not starting with a 'for' +no_for_ty :: { Ty Span } + : no_for_ty_prim { $1 } + | '(' ')' { TupTy [] ($1 # $2) } + | '(' ty ')' { ParenTy $2 ($1 # $3) } + | '(' ty ',' ')' { TupTy [$2] ($1 # $4) } + | '(' ty ',' sep_by1T(ty,',') ')' { TupTy ($2 : toList $4) ($1 # $5) } + | ty_qual_path { PathTy (Just (fst (unspan $1))) (snd (unspan $1)) (spanOf $1) } + +-- All (non-sum) types not starting with a 'for', '(', or '<' +no_for_ty_prim :: { Ty Span } + : '_' { Infer (spanOf $1) } + | '!' { Never (spanOf $1) } + | '[' ty ']' { Slice $2 ($1 # $3) } + | '*' ty_no_plus { Ptr Immutable $2 ($1 # $2) } + | '*' const ty_no_plus { Ptr Immutable $3 ($1 # $3) } + | '*' mut ty_no_plus { Ptr Mutable $3 ($1 # $3) } + | '&' ty_no_plus { Rptr Nothing Immutable $2 ($1 # $>) } + | '&' lifetime ty_no_plus { Rptr (Just $2) Immutable $3 ($1 # $>) } + | '&' mut ty_no_plus { Rptr Nothing Mutable $3 ($1 # $>) } + | '&' lifetime mut ty_no_plus { Rptr (Just $2) Mutable $4 ($1 # $>) } + | '&&' ty_no_plus { Rptr Nothing Immutable (Rptr Nothing Immutable $2 (nudge 1 0 ($1 # $>))) ($1 # $>) } + | '&&' lifetime ty_no_plus { Rptr Nothing Immutable (Rptr (Just $2) Immutable $3 (nudge 1 0 ($1 # $>))) ($1 # $>) } + | '&&' mut ty_no_plus { Rptr Nothing Immutable (Rptr Nothing Mutable $3 (nudge 1 0 ($1 # $>))) ($1 # $>) } + | '&&' lifetime mut ty_no_plus { Rptr Nothing Immutable (Rptr (Just $2) Mutable $4 (nudge 1 0 ($1 # $>))) ($1 # $>) } + | ty_path %prec PATH { PathTy Nothing $1 ($1 # $>) } + | ty_mac { MacTy $1 ($1 # $>) } + | unsafe extern abi fn fn_decl(arg_general) { BareFn Unsafe $3 [] $> ($1 # $>) } + | unsafe fn fn_decl(arg_general) { BareFn Unsafe Rust [] $> ($1 # $>) } + | extern abi fn fn_decl(arg_general) { BareFn Normal $2 [] $> ($1 # $>) } + | fn fn_decl(arg_general) { BareFn Normal Rust [] $> ($1 # $>) } + | typeof '(' expr ')' { Typeof $3 ($1 # $>) } + | '[' ty ';' expr ']' { Array $2 $4 ($1 # $>) } + | '?' trait_ref { TraitObject [TraitTyParamBound (PolyTraitRef [] $2 (spanOf $2)) Maybe ($1 # $2)] ($1 # $2) } + | '?' for_lts trait_ref { TraitObject [TraitTyParamBound (PolyTraitRef (unspan $2) $3 ($2 # $3)) Maybe ($1 # $3)] ($1 # $3) } + | impl sep_by1(ty_param_bound_mod,'+') %prec IMPLTRAIT { ImplTrait (toNonEmpty $2) ($1 # $2) } + | dyn sep_by1(ty_param_bound_mod,'+') %prec IMPLTRAIT { TraitObject (toNonEmpty $2) ($1 # $2) } + +-- All (non-sum) types starting with a 'for' +for_ty_no_plus :: { Ty Span } + : for_lts unsafe extern abi fn fn_decl(arg_general) { BareFn Unsafe $4 (unspan $1) $> ($1 # $>) } + | for_lts unsafe fn fn_decl(arg_general) { BareFn Unsafe Rust (unspan $1) $> ($1 # $>) } + | for_lts extern abi fn fn_decl(arg_general) { BareFn Normal $3 (unspan $1) $> ($1 # $>) } + | for_lts fn fn_decl(arg_general) { BareFn Normal Rust (unspan $1) $> ($1 # $>) } + | for_lts trait_ref { + let poly = PolyTraitRef (unspan $1) $2 ($1 # $2) in + TraitObject [TraitTyParamBound poly None ($1 # $2)] ($1 # $2) + } + +-- An optional lifetime followed by an optional mutability +lifetime_mut :: { (Maybe (Lifetime Span), Mutability) } + : lifetime mut { (Just $1, Mutable) } + | lifetime { (Just $1, Immutable) } + | mut { (Nothing, Mutable) } + | {- empty -} { (Nothing, Immutable) } + +-- The argument list and return type in a function +fn_decl(arg) :: { FnDecl Span } + : '(' sep_by1(arg,',') ',' '...' ')' ret_ty { FnDecl (toList $2) $> True ($1 # $5 # $6) } + | '(' sep_byT(arg,',') ')' ret_ty { FnDecl $2 $> False ($1 # $3 # $4) } + +-- Like 'fn_decl', but also accepting a self argument +fn_decl_with_self_general :: { FnDecl Span } + : '(' arg_self_general ',' sep_byT(arg_general,',') ')' ret_ty { FnDecl ($2 : $4) $> False ($1 # $5 # $6) } + | '(' arg_self_general ')' ret_ty { FnDecl [$2] $> False ($1 # $3 # $4) } + | '(' ')' ret_ty { FnDecl [] $> False ($1 # $2 # $3) } + +-- Like 'fn_decl', but also accepting a self argument +fn_decl_with_self_named :: { FnDecl Span } + : '(' arg_self_named ',' sep_by1(arg_named,',') ',' ')' ret_ty { FnDecl ($2 : toList $4) $> False ($1 # $6 # $7) } + | '(' arg_self_named ',' sep_by1(arg_named,',') ')' ret_ty { FnDecl ($2 : toList $4) $> False ($1 # $5 # $6) } + | '(' arg_self_named ',' ')' ret_ty { FnDecl [$2] $> False ($1 # $3 # $4) } + | '(' arg_self_named ')' ret_ty { FnDecl [$2] $> False ($1 # $3 # $4) } + | fn_decl(arg_named) { $1 } + + +-- parse_ty_param_bounds(BoundParsingMode::Bare) == sep_by1(ty_param_bound,'+') +ty_param_bound :: { TyParamBound Span } + : lifetime { RegionTyParamBound $1 (spanOf $1) } + | poly_trait_ref { TraitTyParamBound $1 None (spanOf $1) } + | '(' poly_trait_ref ')' { TraitTyParamBound $2 None ($1 # $3) } + +poly_trait_ref_mod_bound :: { TyParamBound Span } + : poly_trait_ref { TraitTyParamBound $1 None (spanOf $1) } + | '?' poly_trait_ref { TraitTyParamBound $2 Maybe ($1 # $2) } + +-- parse_ty_param_bounds(BoundParsingMode::Modified) == sep_by1(ty_param_bound_mod,'+') +ty_param_bound_mod :: { TyParamBound Span } + : ty_param_bound { $1 } + | '?' poly_trait_ref { TraitTyParamBound $2 Maybe ($1 # $2) } + +-- Sort of like parse_opt_abi() -- currently doesn't handle raw string ABI +abi :: { Abi } + : str {% case unspan $1 of + LiteralTok (StrTok "cdecl") Nothing -> pure Cdecl + LiteralTok (StrTok "stdcall") Nothing -> pure Stdcall + LiteralTok (StrTok "fastcall") Nothing -> pure Fastcall + LiteralTok (StrTok "vectorcall") Nothing -> pure Vectorcall + LiteralTok (StrTok "aapcs") Nothing -> pure Aapcs + LiteralTok (StrTok "win64") Nothing -> pure Win64 + LiteralTok (StrTok "sysv64") Nothing -> pure SysV64 + LiteralTok (StrTok "ptx-kernel") Nothing -> pure PtxKernel + LiteralTok (StrTok "msp430-interrupt") Nothing -> pure Msp430Interrupt + LiteralTok (StrTok "x86-interrupt") Nothing -> pure X86Interrupt + LiteralTok (StrTok "Rust") Nothing -> pure Rust + LiteralTok (StrTok "C") Nothing -> pure C + LiteralTok (StrTok "system") Nothing -> pure System + LiteralTok (StrTok "rust-intrinsic") Nothing -> pure RustIntrinsic + LiteralTok (StrTok "rust-call") Nothing -> pure RustCall + LiteralTok (StrTok "platform-intrinsic") Nothing -> pure PlatformIntrinsic + LiteralTok (StrTok "unadjusted") Nothing -> pure Unadjusted + _ -> parseError $1 {- "invalid ABI" -} + } + | {- empty -} { C } + +-- parse_ret_ty +ret_ty :: { Maybe (Ty Span) } + : '->' ty_no_plus { Just $2 } + | {- empty -} { Nothing } + +-- parse_poly_trait_ref() +poly_trait_ref :: { PolyTraitRef Span } + : trait_ref { PolyTraitRef [] $1 (spanOf $1) } + | for_lts trait_ref { PolyTraitRef (unspan $1) $2 ($1 # $2) } + +-- parse_for_lts() +-- Unlike the Rust libsyntax version, this _requires_ the 'for' +for_lts :: { Spanned [LifetimeDef Span] } + : for '<' sep_byT(lifetime_def,',') '>' { Spanned $3 ($1 # $>) } + +-- Definition of a lifetime: attributes can come before the lifetime, and a list of bounding +-- lifetimes can come after the lifetime. +lifetime_def :: { LifetimeDef Span } + : many(outer_attribute) lifetime ':' sep_by1T(lifetime,'+') { LifetimeDef $1 $2 (toList $4) ($1 # $2 # $>) } + | many(outer_attribute) lifetime { LifetimeDef $1 $2 [] ($1 # $2 # $>) } + + +--------------- +-- Arguments -- +--------------- + +-- Argument (requires a name / pattern, ie. @parse_arg_general(true)@) +arg_named :: { Arg Span } + : ntArg { $1 } + | pat ':' ty { Arg (Just $1) $3 ($1 # $3) } + +-- Argument (does not require a name / pattern, ie. @parse_arg_general(false)@) +-- +-- Remark: not all patterns are accepted (as per ) +-- The details for which patterns _should_ be accepted fall into @is_named_argument()@. +arg_general :: { Arg Span } + : ntArg { $1 } + | ty { Arg Nothing $1 (spanOf $1) } + | '_' ':' ty { Arg (Just (WildP (spanOf $1))) $3 ($1 # $3) } + | ident ':' ty { Arg (Just (IdentP (ByValue Immutable) (unspan $1) Nothing (spanOf $1))) $3 ($1 # $3) } + | mut ident ':' ty { Arg (Just (IdentP (ByValue Mutable) (unspan $2) Nothing (spanOf $2))) $4 ($1 # $4) } + | '&' '_' ':' ty { Arg (Just (RefP (WildP (spanOf $2)) Immutable ($1 # $2))) $4 ($1 # $4) } + | '&' ident ':' ty { Arg (Just (RefP (IdentP (ByValue Immutable) (unspan $2) Nothing (spanOf $2)) Immutable ($1 # $2))) $4 ($1 # $4) } + | '&&' '_' ':' ty { Arg (Just (RefP (RefP (WildP (spanOf $2)) Immutable (nudge 1 0 ($1 # $2))) Immutable ($1 # $2))) $4 ($1 # $4) } + | '&&' ident ':' ty { Arg (Just (RefP (RefP (IdentP (ByValue Immutable) (unspan $2) Nothing (spanOf $2)) Immutable (nudge 1 0 ($1 # $2))) Immutable ($1 # $2))) $4 ($1 # $4) } + +-- Self argument (only allowed in trait function signatures) +arg_self_general :: { Arg Span } + : mut self { SelfValue Mutable ($1 # $>) } + | self ':' ty { SelfExplicit $3 Immutable ($1 # $>) } + | mut self ':' ty { SelfExplicit $4 Mutable ($1 # $>) } + | arg_general { + case $1 of + Arg Nothing (PathTy Nothing (Path False [PathSegment "self" Nothing _] _) _) x -> SelfValue Immutable x + Arg Nothing (Rptr l m (PathTy Nothing (Path False [PathSegment "self" Nothing _] _) _) _) x -> SelfRegion l m x + _ -> $1 + } + +-- Self argument (only allowed in impl function signatures) +arg_self_named :: { Arg Span } + : self { SelfValue Immutable ($1 # $>) } + | mut self { SelfValue Mutable ($1 # $>) } + | '&' self { SelfRegion Nothing Immutable ($1 # $>) } + | '&' lifetime self { SelfRegion (Just $2) Immutable ($1 # $>) } + | '&' mut self { SelfRegion Nothing Mutable ($1 # $>) } + | '&' lifetime mut self { SelfRegion (Just $2) Mutable ($1 # $>) } + | self ':' ty { SelfExplicit $3 Immutable ($1 # $>) } + | mut self ':' ty { SelfExplicit $4 Mutable ($1 # $>) } + +-- Lambda expression argument +lambda_arg :: { Arg Span } + : ntArg { $1 } + | pat ':' ty { Arg (Just $1) $3 ($1 # $3) } + | pat { Arg (Just $1) (Infer mempty) (spanOf $1) } + + +-------------- +-- Patterns -- +-------------- + +-- There is a funky trick going on here around 'IdentP'. When there is a binding mode (ie a 'mut' or +-- 'ref') or an '@' pattern, everything is fine, but otherwise there is no difference between an +-- expression variable path and a pattern. To deal with this, we intercept expression paths with +-- only one segment, no path parameters, and not global and turn them into identifier patterns. +pat :: { Pat Span } + : ntPat { $1 } + | '_' { WildP (spanOf $1) } + | '&' mut pat { RefP $3 Mutable ($1 # $3) } + | '&' pat { RefP $2 Immutable ($1 # $2) } + | '&&' mut pat { RefP (RefP $3 Mutable (nudge 1 0 ($1 # $3))) Immutable ($1 # $3) } + | '&&' pat { RefP (RefP $2 Immutable (nudge 1 0 ($1 # $2))) Immutable ($1 # $2) } + | lit_expr { LitP $1 (spanOf $1) } + | '-' lit_expr { LitP (Unary [] Neg $2 ($1 # $2)) ($1 # $2) } + | box pat { BoxP $2 ($1 # $2) } + | binding_mode1 binding_mode1_ident '@' pat { IdentP (unspan $1) (unspan $2) (Just $4) ($1 # $>) } + | binding_mode1 binding_mode1_ident { IdentP (unspan $1) (unspan $2) Nothing ($1 # $>) } + | ident '@' pat { IdentP (ByValue Immutable) (unspan $1) (Just $3) ($1 # $>) } + | expr_path { + case $1 of + Path False [PathSegment i Nothing _] _ -> IdentP (ByValue Immutable) i Nothing (spanOf $1) + _ -> PathP Nothing $1 (spanOf $1) + } + | expr_qual_path { PathP (Just (fst (unspan $1))) (snd (unspan $1)) ($1 # $>) } + | lit_or_path '...' lit_or_path { RangeP $1 $3 ($1 # $>) } + | lit_or_path '..=' lit_or_path { RangeP $1 $3 ($1 # $>) } + | expr_path '{' '..' '}' { StructP $1 [] True ($1 # $>) } + | expr_path '{' pat_fields '}' { let (fs,b) = $3 in StructP $1 fs b ($1 # $>) } + | expr_path '(' pat_tup ')' { let (ps,m,_) = $3 in TupleStructP $1 ps m ($1 # $>) } + | expr_mac { MacP $1 (spanOf $1) } + | '[' pat_slice ']' { let (b,s,a) = $2 in SliceP b s a ($1 # $3) } + | '(' pat_tup ')' {% + case $2 of + ([p], Nothing, False) -> parseError (CloseDelim Paren) + (ps,m,t) -> pure (TupleP ps m ($1 # $3)) + } + + +-- The first element is the spans, the second the position of '..', and the third if there is a +-- trailing comma +pat_tup :: { ([Pat Span], Maybe Int, Bool) } + : sep_by1(pat,',') ',' '..' ',' sep_by1(pat,',') { (toList ($1 <> $5), Just (length $1), False) } + | sep_by1(pat,',') ',' '..' ',' sep_by1(pat,',') ',' { (toList ($1 <> $5), Just (length $1), True) } + | sep_by1(pat,',') ',' '..' { (toList $1, Just (length $1), False) } + | sep_by1(pat,',') { (toList $1, Nothing, False) } + | sep_by1(pat,',') ',' { (toList $1, Nothing, True) } + | '..' ',' sep_by1(pat,',') { (toList $3, Just 0, False) } + | '..' ',' sep_by1(pat,',') ',' { (toList $3, Just 0, True) } + | '..' { ([], Just 0, False) } + | {- empty -} { ([], Nothing, False) } + +-- The first element is the patterns at the beginning of the slice, the second the optional binding +-- for the middle slice ('Nothing' if there is no '..' and 'Just (WildP mempty) is there is one, but +-- unlabelled), and the third is the patterns at the end of the slice. +pat_slice :: { ([Pat Span], Maybe (Pat Span), [Pat Span]) } + : sep_by1(pat,',') ',' '..' ',' sep_by1T(pat,',') { (toList $1, Just (WildP mempty), toList $5) } + | sep_by1(pat,',') ',' '..' { (toList $1, Just (WildP mempty), []) } + | sep_by1(pat,',') '..' ',' sep_by1T(pat,',') { let (xs, x) = unsnoc $1 in (toList xs, Just x, toList $4) } + | sep_by1(pat,',') '..' { let (xs, x) = unsnoc $1 in (toList xs, Just x, []) } + | sep_by1T(pat,',') { (toList $1, Nothing, []) } + | '..' ',' sep_by1T(pat,',') { ([], Just (WildP mempty), toList $3) } + | '..' { ([], Just (WildP mempty), []) } + | {- empty -} { ([], Nothing, []) } + + +-- Endpoints of range patterns +lit_or_path :: { Expr Span } + : expr_path { PathExpr [] Nothing $1 (spanOf $1) } + | expr_qual_path { PathExpr [] (Just (fst (unspan $1))) (snd (unspan $1)) (spanOf $1) } + | '-' lit_expr { Unary [] Neg $2 ($1 # $2) } + | lit_expr { $1 } + +-- Used in patterns for tuple and expression patterns +pat_fields :: { ([FieldPat Span], Bool) } + : sep_byT(pat_field,',') { ($1, False) } + | sep_by1(pat_field,',') ',' '..' { (toList $1, True) } + +pat_field :: { FieldPat Span } + : binding_mode ident + { FieldPat Nothing (IdentP (unspan $1) (unspan $2) Nothing (spanOf $2)) ($1 # $2) } + | box binding_mode ident + { FieldPat Nothing (BoxP (IdentP (unspan $2) (unspan $3) Nothing ($2 # $3)) ($1 # $3)) ($1 # $3) } + | binding_mode ident ':' pat + { FieldPat (Just (unspan $2)) $4 ($1 # $2 # $4) } + + +-- Used prefixing IdentP patterns (not empty - that is a seperate pattern case) +binding_mode1 :: { Spanned BindingMode } + : ref mut { Spanned (ByRef Mutable) ($1 # $2) } + | ref { Spanned (ByRef Immutable) (spanOf $1) } + | mut { Spanned (ByValue Mutable) (spanOf $1) } + +-- Used for patterns for fields (includes the empty case) +binding_mode :: { Spanned BindingMode } + : binding_mode1 { $1 } + | {- empty -} { Spanned (ByValue Immutable) mempty } + + +----------------- +-- Expressions -- +----------------- + +-- Expressions are a pain to parse. The Rust language places "restrictions" preventing certain +-- specific expressions from being valid in a certain context. Elsewhere in the parser, it will turn +-- on or off these restrictions. Unfortunately, that doesn't work well at all in a grammar, so we +-- have to define production rules for every combination of restrications used. Parametrized +-- productions make this a bit easier by letting us factor out the core expressions used everywhere. + +-- Generalized expressions, parametrized by +-- +-- * 'lhs' - expressions allowed on the left extremity of the term +-- * 'rhs' - expressions allowed on the right extremity of the term +-- * 'rhs2' - expressions allowed on the right extremity following '..'/'.../..=' +-- +-- Precedences are handled by Happy (right at the end of the token section) +gen_expression(lhs,rhs,rhs2) :: { Expr Span } + -- immediate expressions + : ntExpr { $1 } + | lit_expr { $1 } + | '[' sep_byT(expr,',') ']' { Vec [] $2 ($1 # $>) } + | '[' inner_attrs sep_byT(expr,',') ']' { Vec (toList $2) $3 ($1 # $>) } + | '[' expr ';' expr ']' { Repeat [] $2 $4 ($1 # $>) } + | expr_mac { MacExpr [] $1 (spanOf $1) } + | expr_path %prec PATH { PathExpr [] Nothing $1 (spanOf $1) } + | expr_qual_path { PathExpr [] (Just (fst (unspan $1))) (snd (unspan $1)) (spanOf $1) } + -- unary expressions + | '*' rhs %prec UNARY { Unary [] Deref $2 ($1 # $>) } + | '!' rhs %prec UNARY { Unary [] Not $2 ($1 # $>) } + | '-' rhs %prec UNARY { Unary [] Neg $2 ($1 # $>) } + | '&' rhs %prec UNARY { AddrOf [] Immutable $2 ($1 # $>) } + | '&' mut rhs %prec UNARY { AddrOf [] Mutable $3 ($1 # $>) } + | '&&' rhs %prec UNARY { AddrOf [] Immutable (AddrOf [] Immutable $2 (nudge 1 0 ($1 # $2))) ($1 # $2) } + | '&&' mut rhs %prec UNARY { AddrOf [] Immutable (AddrOf [] Mutable $3 (nudge 1 0 ($1 # $3))) ($1 # $3) } + | box rhs %prec UNARY { Box [] $2 ($1 # $>) } + -- left-recursive + | left_gen_expression(lhs,rhs,rhs2) { $1 } + -- range expressions + | '..' rhs2 %prec PREFIXRNG { Range [] Nothing (Just $2) HalfOpen ($1 # $2) } + | '...' rhs2 %prec PREFIXRNG { Range [] Nothing (Just $2) Closed ($1 # $2) } + | '..=' rhs2 %prec PREFIXRNG { Range [] Nothing (Just $2) Closed ($1 # $2) } + | '..' %prec SINGLERNG { Range [] Nothing Nothing HalfOpen (spanOf $1) } + | '..=' %prec SINGLERNG { Range [] Nothing Nothing Closed (spanOf $1) } + -- low precedence prefix expressions + | return { Ret [] Nothing (spanOf $1) } + | return rhs { Ret [] (Just $2) ($1 # $2) } + | yield { Yield [] Nothing (spanOf $1) } + | yield rhs { Yield [] (Just $2) ($1 # $2) } + | continue { Continue [] Nothing (spanOf $1) } + | continue label { Continue [] (Just $2) ($1 # $2) } + | break { Break [] Nothing Nothing (spanOf $1) } + | break rhs { Break [] Nothing (Just $2) ($1 # $2) } + | break label { Break [] (Just $2) Nothing ($1 # $2) } + | break label rhs %prec break { Break [] (Just $2) (Just $3) ($1 # $3) } + -- lambda expressions + | static move lambda_args rhs %prec LAMBDA + { Closure [] Immovable Value (FnDecl (unspan $3) Nothing False (spanOf $3)) $> ($1 # $>) } + | move lambda_args rhs %prec LAMBDA + { Closure [] Movable Value (FnDecl (unspan $2) Nothing False (spanOf $2)) $> ($1 # $>) } + | static lambda_args rhs %prec LAMBDA + { Closure [] Immovable Ref (FnDecl (unspan $2) Nothing False (spanOf $2)) $> ($1 # $>) } + | lambda_args rhs %prec LAMBDA + { Closure [] Movable Ref (FnDecl (unspan $1) Nothing False (spanOf $1)) $> ($1 # $>) } + +-- Variant of 'gen_expression' which only constructs expressions starting with another expression. +left_gen_expression(lhs,rhs,rhs2) :: { Expr Span } + : postfix_blockexpr(lhs) { $1 } + | lhs '[' expr ']' { Index [] $1 $3 ($1 # $>) } + | lhs '(' sep_byT(expr,',') ')' { Call [] $1 $3 ($1 # $>) } + -- unary expressions + | lhs ':' ty_no_plus { TypeAscription [] $1 $3 ($1 # $>) } + | lhs as ty_no_plus { Cast [] $1 $3 ($1 # $>) } + -- binary expressions + | lhs '*' rhs { Binary [] MulOp $1 $3 ($1 # $>) } + | lhs '/' rhs { Binary [] DivOp $1 $3 ($1 # $>) } + | lhs '%' rhs { Binary [] RemOp $1 $3 ($1 # $>) } + | lhs '+' rhs { Binary [] AddOp $1 $3 ($1 # $>) } + | lhs '-' rhs { Binary [] SubOp $1 $3 ($1 # $>) } + | lhs '<<' rhs { Binary [] ShlOp $1 $3 ($1 # $>) } + | lhs '>>' rhs { Binary [] ShrOp $1 $3 ($1 # $>) } + | lhs '&' rhs { Binary [] BitAndOp $1 $3 ($1 # $>) } + | lhs '^' rhs { Binary [] BitXorOp $1 $3 ($1 # $>) } + | lhs '|' rhs { Binary [] BitOrOp $1 $3 ($1 # $>) } + | lhs '==' rhs { Binary [] EqOp $1 $3 ($1 # $>) } + | lhs '!=' rhs { Binary [] NeOp $1 $3 ($1 # $>) } + | lhs '<' rhs { Binary [] LtOp $1 $3 ($1 # $>) } + | lhs '>' rhs { Binary [] GtOp $1 $3 ($1 # $>) } + | lhs '<=' rhs { Binary [] LeOp $1 $3 ($1 # $>) } + | lhs '>=' rhs { Binary [] GeOp $1 $3 ($1 # $>) } + | lhs '&&' rhs { Binary [] AndOp $1 $3 ($1 # $>) } + | lhs '||' rhs { Binary [] OrOp $1 $3 ($1 # $>) } + -- range expressions + | lhs '..' %prec POSTFIXRNG { Range [] (Just $1) Nothing HalfOpen ($1 # $>) } + | lhs '...' %prec POSTFIXRNG { Range [] (Just $1) Nothing Closed ($1 # $>) } + | lhs '..=' %prec POSTFIXRNG { Range [] (Just $1) Nothing Closed ($1 # $>) } + | lhs '..' rhs2 %prec INFIXRNG { Range [] (Just $1) (Just $3) HalfOpen ($1 # $>) } + | lhs '...' rhs2 %prec INFIXRNG { Range [] (Just $1) (Just $3) Closed ($1 # $>) } + | lhs '..=' rhs2 %prec INFIXRNG { Range [] (Just $1) (Just $3) Closed ($1 # $>) } + -- assignment expressions + | lhs '<-' rhs { InPlace [] $1 $3 ($1 # $>) } + | lhs '=' rhs { Assign [] $1 $3 ($1 # $>) } + | lhs '>>=' rhs { AssignOp [] ShrOp $1 $3 ($1 # $>) } + | lhs '<<=' rhs { AssignOp [] ShlOp $1 $3 ($1 # $>) } + | lhs '-=' rhs { AssignOp [] SubOp $1 $3 ($1 # $>) } + | lhs '+=' rhs { AssignOp [] AddOp $1 $3 ($1 # $>) } + | lhs '*=' rhs { AssignOp [] MulOp $1 $3 ($1 # $>) } + | lhs '/=' rhs { AssignOp [] DivOp $1 $3 ($1 # $>) } + | lhs '^=' rhs { AssignOp [] BitXorOp $1 $3 ($1 # $>) } + | lhs '|=' rhs { AssignOp [] BitOrOp $1 $3 ($1 # $>) } + | lhs '&=' rhs { AssignOp [] BitAndOp $1 $3 ($1 # $>) } + | lhs '%=' rhs { AssignOp [] RemOp $1 $3 ($1 # $>) } + +-- Postfix expressions that can come after an expression block, in a 'stmt' +-- +-- * `{ 1 }[0]` isn't here because it is treated as `{ 1 }; [0]` +-- * `{ 1 }(0)` isn't here because it is treated as `{ 1 }; (0)` +-- +postfix_blockexpr(lhs) :: { Expr Span } + : lhs '?' { Try [] $1 ($1 # $>) } + | lhs '.' ident %prec FIELD { FieldAccess [] $1 (unspan $3) ($1 # $>) } + | lhs '.' ident '(' sep_byT(expr,',') ')' + { MethodCall [] $1 (unspan $3) Nothing $5 ($1 # $>) } + | lhs '.' ident '::' '<' sep_byT(ty,',') '>' '(' sep_byT(expr,',') ')' + { MethodCall [] $1 (unspan $3) (Just $6) $9 ($1 # $>) } + | lhs '.' int {% + case lit $3 of + Int Dec i _ Unsuffixed _ -> pure (TupField [] $1 (fromIntegral i) ($1 # $3)) + _ -> parseError $3 + } + +-- Postfix expressions that can come after an expression block, in a 'stmt' +-- +-- * `{ 1 }[0]` isn't here because it is treated as `{ 1 }; [0]` +-- * `{ 1 }(0)` isn't here because it is treated as `{ 1 }; (0)` +-- +postfix_blockexpr(lhs) :: { Expr Span } + : lhs '?' { Try [] $1 ($1 # $>) } + | lhs '.' ident %prec FIELD { FieldAccess [] $1 (unspan $3) ($1 # $>) } + | lhs '.' ident '(' sep_byT(expr,',') ')' + { MethodCall [] $1 (unspan $3) Nothing $5 ($1 # $>) } + | lhs '.' ident '::' '<' sep_byT(ty,',') '>' '(' sep_byT(expr,',') ')' + { MethodCall [] $1 (unspan $3) (Just $6) $9 ($1 # $>) } + | lhs '.' int {% + case lit $3 of + Int Dec i _ Unsuffixed _ -> pure (TupField [] $1 (fromIntegral i) ($1 # $3)) + _ -> parseError $3 + } + +-- Postfix expressions that can come after an expression block, in a 'stmt' +-- +-- * `{ 1 }[0]` isn't here because it is treated as `{ 1 }; [0]` +-- * `{ 1 }(0)` isn't here because it is treated as `{ 1 }; (0)` +-- +postfix_blockexpr(lhs) :: { Expr Span } + : lhs '?' { Try [] $1 ($1 # $>) } + | lhs '.' ident %prec FIELD { FieldAccess [] $1 (unspan $3) ($1 # $>) } + | lhs '.' ident '(' sep_byT(expr,',') ')' + { MethodCall [] $1 (unspan $3) Nothing $5 ($1 # $>) } + | lhs '.' ident '::' '<' sep_byT(ty,',') '>' '(' sep_byT(expr,',') ')' + { MethodCall [] $1 (unspan $3) (Just $6) $9 ($1 # $>) } + | lhs '.' int {% + case lit $3 of + Int Dec i _ Unsuffixed _ -> pure (TupField [] $1 (fromIntegral i) ($1 # $3)) + _ -> parseError $3 + } + + + +-- Then, we instantiate this general production into the following families of rules: +-- +-- ['expr'] Most general class of expressions, no restrictions +-- +-- ['nostruct_expr'] Forbids struct literals (for use as scrutinee of loops, ifs, etc) +-- +-- ['nostructblock_expr'] Forbids struct literals and block expressions (but not block-like things +-- like 'if' expressions or 'loop' expressions) +-- +-- ['nonblock_expr'] Forbids expressions starting with blocks (things such as '{ 1 } + 2' are +-- not allowed, while struct expressions are - their "block" is at the end +-- of the expression) +-- +-- ['blockpostfix_expr'] Allows expressions starting with blocks (things such as '{ 1 }? + 1') +-- but only when the leading block is itself a postfix expression. +-- +-- There is also a later instantiation revolving around 'match' expressions, but it has some +-- different types. + +expr :: { Expr Span } + : gen_expression(expr,expr,expr) { $1 } + | paren_expr { $1 } + | struct_expr { $1 } + | block_expr { $1 } + | lambda_expr_block { $1 } + | embedded_expr { $1 } + +nostruct_expr :: { Expr Span } + : gen_expression(nostruct_expr,nostruct_expr,nonstructblock_expr) { $1 } + | paren_expr { $1 } + | block_expr { $1 } + +nonstructblock_expr :: { Expr Span } + : gen_expression(nonstructblock_expr,nostruct_expr,nonstructblock_expr) { $1 } + | paren_expr { $1 } + | block_like_expr { $1 } + | unsafe inner_attrs_block + { let (as, Block ss r x) = $> in BlockExpr as (Block ss Unsafe ($1 # x)) ($1 # x) } + +nonblock_expr :: { Expr Span } + : gen_expression(nonblock_expr,expr,expr) { $1 } + | paren_expr { $1 } + | struct_expr { $1 } + | lambda_expr_block { $1 } + +blockpostfix_expr :: { Expr Span } + : postfix_blockexpr(block_like_expr) { $1 } + | postfix_blockexpr(vis_safety_block) { $1 } + | left_gen_expression(blockpostfix_expr,expr,expr) { $1 } + +-- Can't put attributes on embedded code (seems like a reasonable restriction at the time of this writing): +embedded_expr :: { Expr Span } + : EMBEDDED_EXPR { toEmbedded [] $1 } + +-- Finally, what remains is the more mundane definitions of particular types of expressions. + +-- labels on loops +label :: { Label Span } + : LIFETIME { let Spanned (LifetimeTok (Ident (Name l) _ _)) s = $1 in Label l s } + +-- Literal expressions (composed of just literals) +lit_expr :: { Expr Span } + : lit { Lit [] $1 (spanOf $1) } + +-- An expression ending in a '{ ... }' block. Useful since "There is a convenience rule that allows +-- one to omit the separating ';' after 'if', 'match', 'loop', 'for', 'while'" +block_expr :: { Expr Span } + : block_like_expr { $1 } + | inner_attrs_block { let (as,b) = $1 in BlockExpr as b (spanOf b) } + | unsafe inner_attrs_block + { let (as, Block ss r x) = $> in BlockExpr as (Block ss Unsafe ($1 # x)) ($1 # x) } + +-- Any expression ending in a '{ ... }' block except a block itself. +block_like_expr :: { Expr Span } + : if_expr { $1 } + | loop inner_attrs_block { let (as,b) = $> in Loop as b Nothing ($1 # b) } + | label ':' loop inner_attrs_block { let (as,b) = $> in Loop as b (Just $1) ($1 # b) } + | for pat in nostruct_expr inner_attrs_block { let (as,b) = $> in ForLoop as $2 $4 b Nothing ($1 # b) } + | label ':' for pat in nostruct_expr inner_attrs_block { let (as,b) = $> in ForLoop as $4 $6 b (Just $1) ($1 # b) } + | while nostruct_expr inner_attrs_block { let (as,b) = $> in While as $2 b Nothing ($1 # b) } + | label ':' while nostruct_expr inner_attrs_block { let (as,b) = $> in While as $4 b (Just $1) ($1 # b) } + | while let pats '=' nostruct_expr inner_attrs_block { let (as,b) = $> in WhileLet as $3 $5 b Nothing ($1 # b) } + | label ':' while let pats '=' nostruct_expr inner_attrs_block { let (as,b) = $> in WhileLet as $5 $7 b (Just $1) ($1 # b) } + | match nostruct_expr '{' '}' { Match [] $2 [] ($1 # $>) } + | match nostruct_expr '{' inner_attrs '}' { Match (toList $4) $2 [] ($1 # $>) } + | match nostruct_expr '{' arms '}' { Match [] $2 $4 ($1 # $>) } + | match nostruct_expr '{' inner_attrs arms '}' { Match (toList $4) $2 $5 ($1 # $>) } + | expr_path '!' '{' token_stream '}' { MacExpr [] (Mac $1 $4 ($1 # $>)) ($1 # $>) } + | do catch inner_attrs_block { let (as,b) = $> in Catch as b ($1 # b) } + +-- 'if' expressions are a bit special since they can have an arbitrary number of 'else if' chains. +if_expr :: { Expr Span } + : if nostruct_expr block else_expr { If [] $2 $3 $4 ($1 # $3 # $>) } + | if let pats '=' nostruct_expr block else_expr { IfLet [] $3 $5 $6 $7 ($1 # $6 # $>) } + +else_expr :: { Maybe (Expr Span) } + : else block { Just (BlockExpr [] $2 (spanOf $2)) } + | else if_expr { Just $2 } + | {- empty -} { Nothing } + +-- Match arms usually have to be seperated by commas (with an optional comma at the end). This +-- condition is loosened (so that there is no seperator needed) if the arm ends in a safe block. +arms :: { [Arm Span] } + : ntArm { [$1] } + | ntArm arms { $1 : $2 } + | many(outer_attribute) pats arm_guard '=>' expr_arms { let (e,as) = $> in (Arm $1 $2 $3 e ($1 # $2 # e) : as) } + +pats :: { NonEmpty (Pat Span) } + : '|' sep_by1(pat,'|') { toNonEmpty $2 } + | sep_by1(pat,'|') { toNonEmpty $1 } + +arm_guard :: { Maybe (Expr Span) } + : {- empty -} { Nothing } + | if expr { Just $2 } + +-- Possibly more match arms, with a comma if present +comma_arms :: { [Arm Span] } + : {- empty -} { [] } + | ',' { [] } + | ',' arms { $2 } + +-- An expression followed by match arms. If there is a comma needed, it is added +expr_arms :: { (Expr Span, [Arm Span]) } + : nonblock_expr comma_arms { ($1, $2) } + | blockpostfix_expr comma_arms { ($1, $2) } + | vis_safety_block comma_arms { ($1, $2) } + | vis_safety_block arms { ($1, $2) } + | block_like_expr comma_arms { ($1, $2) } + | block_like_expr arms { ($1, $2) } + +-- As per https://github.com/rust-lang/rust/issues/15701 (as of March 10 2017), the only way to have +-- attributes on expressions should be with inner attributes on a paren expression. +paren_expr :: { Expr Span } + : '(' ')' { TupExpr [] [] ($1 # $>) } + | '(' inner_attrs ')' { TupExpr (toList $2) [] ($1 # $>) } + | '(' expr ')' { ParenExpr [] $2 ($1 # $>) } + | '(' inner_attrs expr ')' { ParenExpr (toList $2) $3 ($1 # $>) } + | '(' expr ',' ')' { TupExpr [] [$2] ($1 # $>) } + | '(' inner_attrs expr ',' ')' { TupExpr (toList $2) [$3] ($1 # $>) } + | '(' expr ',' sep_by1T(expr,',') ')' { TupExpr [] ($2 : toList $4) ($1 # $>) } + | '(' inner_attrs expr ',' sep_by1T(expr,',') ')' { TupExpr (toList $2) ($3 : toList $5) ($1 # $>) } + + +-- Closure ending in blocks +lambda_expr_block :: { Expr Span } + : static move lambda_args '->' ty_no_plus block + { Closure [] Immovable Value (FnDecl (unspan $3) (Just $5) False (spanOf $3)) (BlockExpr [] $> (spanOf $>)) ($1 # $>) } + | move lambda_args '->' ty_no_plus block + { Closure [] Movable Value (FnDecl (unspan $2) (Just $4) False (spanOf $2)) (BlockExpr [] $> (spanOf $>)) ($1 # $>) } + | static lambda_args '->' ty_no_plus block + { Closure [] Immovable Ref (FnDecl (unspan $2) (Just $4) False (spanOf $2)) (BlockExpr [] $> (spanOf $>)) ($1 # $>) } + | lambda_args '->' ty_no_plus block + { Closure [] Movable Ref (FnDecl (unspan $1) (Just $3) False (spanOf $1)) (BlockExpr [] $> (spanOf $>)) ($1 # $>) } + +-- Lambda expression arguments block +lambda_args :: { Spanned [Arg Span] } + : '||' { Spanned [] (spanOf $1) } + | '|' sep_byT(lambda_arg,',') pipe '|' { Spanned $2 ($1 # $4) } + + +-- Struct expression literal +struct_expr :: { Expr Span } + : expr_path '{' '..' expr '}' { Struct [] $1 [] (Just $4) ($1 # $>) } + | expr_path '{' inner_attrs '..' expr '}' { Struct (toList $3) $1 [] (Just $5) ($1 # $>) } + | expr_path '{' sep_by1(field,',') ',' '..' expr '}' { Struct [] $1 (toList $3) (Just $6) ($1 # $>) } + | expr_path '{' inner_attrs sep_by1(field,',') ',' '..' expr '}' { Struct (toList $3) $1 (toList $4) (Just $7) ($1 # $>) } + | expr_path '{' sep_byT(field,',') '}' { Struct [] $1 $3 Nothing ($1 # $>) } + | expr_path '{' inner_attrs sep_byT(field,',') '}' { Struct (toList $3) $1 $4 Nothing ($1 # $>) } + +field :: { Field Span } + : ident ':' expr { Field (unspan $1) (Just $3) ($1 # $3) } + | ident { Field (unspan $1) Nothing (spanOf $1) } + +-- an expression block that won't cause conflicts with stmts +vis_safety_block :: { Expr Span } + : pub_or_inherited safety inner_attrs_block {% + let (as, Block ss r x) = $3 + e = BlockExpr as (Block ss (unspan $2) ($2 # x)) ($2 # x) + in noVis $1 e + } + +-- an expression starting with 'union' or 'default' (as identifiers) that won't cause conflicts with stmts +vis_union_def_nonblock_expr :: { Expr Span } + : union_default_expr { $1 } + | left_gen_expression(vis_union_def_nonblock_expr, expr, expr) { $1 } + +union_default_expr :: { Expr Span } + : pub_or_inherited union {% + noVis $1 (PathExpr [] Nothing (Path False [PathSegment "union" Nothing (spanOf $2)] (spanOf $1)) (spanOf $1)) + } + | pub_or_inherited default {% + noVis $1 (PathExpr [] Nothing (Path False [PathSegment "default" Nothing (spanOf $2)] (spanOf $1)) (spanOf $1)) + } + + +---------------- +-- Statements -- +---------------- + +stmts :: { [Stmt Span] } + : many(stmt) { $1 } + +stmt :: { Stmt Span } + : ntStmt { $1 } + | many(outer_attribute) let pat ':' ty initializer ';' { Local $3 (Just $5) $6 $1 ($1 # $2 # $>) } + | many(outer_attribute) let pat initializer ';' { Local $3 Nothing $4 $1 ($1 # $2 # $>) } + | many(outer_attribute) nonblock_expr ';' { toStmt ($1 `addAttrs` $2) True False ($1 # $2 # $3) } + | many(outer_attribute) block_like_expr ';' { toStmt ($1 `addAttrs` $2) True True ($1 # $2 # $3) } + | many(outer_attribute) blockpostfix_expr ';' { toStmt ($1 `addAttrs` $2) True True ($1 # $2 # $3) } + | many(outer_attribute) vis_union_def_nonblock_expr ';' { toStmt ($1 `addAttrs` $2) True False ($1 # $2 # $3) } + | many(outer_attribute) block_like_expr %prec NOSEMI { toStmt ($1 `addAttrs` $2) False True ($1 # $2) } + | many(outer_attribute) vis_safety_block ';' { toStmt ($1 `addAttrs` $2) True True ($1 # $2 # $>) } + | many(outer_attribute) vis_safety_block %prec NOSEMI { toStmt ($1 `addAttrs` $2) False True ($1 # $2) } + | gen_item(pub_or_inherited) { ItemStmt $1 (spanOf $1) } + | many(outer_attribute) expr_path '!' ident '[' token_stream ']' ';' + { ItemStmt (macroItem $1 (Just (unspan $4)) (Mac $2 $6 ($2 # $>)) ($1 # $2 # $>)) ($1 # $2 # $>) } + | many(outer_attribute) expr_path '!' ident '(' token_stream ')' ';' + { ItemStmt (macroItem $1 (Just (unspan $4)) (Mac $2 $6 ($2 # $>)) ($1 # $2 # $>)) ($1 # $2 # $>) } + | many(outer_attribute) expr_path '!' ident '{' token_stream '}' + { ItemStmt (macroItem $1 (Just (unspan $4)) (Mac $2 $6 ($2 # $>)) ($1 # $2 # $>)) ($1 # $2 # $>) } + +pub_or_inherited :: { Spanned (Visibility Span) } + : pub %prec VIS { Spanned PublicV (spanOf $1) } + | {- empty -} %prec VIS { pure InheritedV } + +stmtOrSemi :: { Maybe (Stmt Span) } + : ';' { Nothing } + | stmt { Just $1 } + +-- List of statements where the last statement might be a no-semicolon statement. +stmts_possibly_no_semi :: { [Maybe (Stmt Span)] } + : stmtOrSemi stmts_possibly_no_semi { $1 : $2 } + | stmtOrSemi { [$1] } + | many(outer_attribute) nonblock_expr { [Just (toStmt ($1 `addAttrs` $2) False False ($1 # $2))] } + | many(outer_attribute) blockpostfix_expr { [Just (toStmt ($1 `addAttrs` $2) False True ($1 # $2))] } + +initializer :: { Maybe (Expr Span) } + : '=' expr { Just $2 } + | {- empty -} { Nothing } + +block :: { Block Span } + : ntBlock { $1 } + | '{' '}' { Block [] Normal ($1 # $>) } + | '{' stmts_possibly_no_semi '}' { Block [ s | Just s <- $2 ] Normal ($1 # $>) } + +inner_attrs_block :: { ([Attribute Span], Block Span) } + : block { ([], $1) } + | '{' inner_attrs '}' { (toList $2, Block [] Normal ($1 # $>)) } + | '{' inner_attrs stmts_possibly_no_semi '}' { (toList $2, Block [ s | Just s <- $3 ] Normal ($1 # $>)) } + + +----------- +-- Items -- +----------- + +-- Given the types of permitted visibilities, generate a rule for items. The reason this production +-- is useful over just having 'item :: { ItemSpan }' and then 'many(outer_attribute) vis item' is +-- that (1) not all items have visibility and (2) attributes and visibility are fields on the 'Item' +-- algebraic data type. +gen_item(vis) :: { Item Span } + : many(outer_attribute) vis static ident ':' ty '=' expr ';' + { Static $1 (unspan $2) (unspan $4) $6 Immutable $8 ($1 # $2 # $3 # $>) } + | many(outer_attribute) vis static mut ident ':' ty '=' expr ';' + { Static $1 (unspan $2) (unspan $5) $7 Mutable $9 ($1 # $2 # $3 # $>) } + | many(outer_attribute) vis const ident ':' ty '=' expr ';' + { ConstItem $1 (unspan $2) (unspan $4) $6 $8 ($1 # $2 # $3 # $>) } + | many(outer_attribute) vis type ident generics where_clause '=' ty ';' + { TyAlias $1 (unspan $2) (unspan $4) $8 ($5 `withWhere` $6) ($1 # $2 # $3 # $>) } + | many(outer_attribute) vis use use_tree ';' + { Use $1 (unspan $2) $4 ($1 # $2 # $3 # $>) } + | many(outer_attribute) vis safety extern crate ident ';' + {% noSafety $3 (ExternCrate $1 (unspan $2) (unspan $6) Nothing ($1 # $2 # $4 # $>)) } + | many(outer_attribute) vis safety extern crate ident as ident ';' + {% noSafety $3 (ExternCrate $1 (unspan $2) (unspan $8) (Just (unspan $6)) ($1 # $2 # $4 # $>)) } + | many(outer_attribute) vis const safety fn ident generics fn_decl(arg_named) where_clause inner_attrs_block + { Fn ($1 ++ fst $>) (unspan $2) (unspan $6) $8 (unspan $4) Const Rust ($7 `withWhere` $9) (snd $>) ($1 # $2 # $3 # snd $>) } + | many(outer_attribute) vis safety extern abi fn ident generics fn_decl(arg_named) where_clause inner_attrs_block + { Fn ($1 ++ fst $>) (unspan $2) (unspan $7) $9 (unspan $3) NotConst $5 ($8 `withWhere` $10) (snd $>) ($1 # $2 # $3 # $4 # snd $>) } + | many(outer_attribute) vis safety fn ident generics fn_decl(arg_named) where_clause inner_attrs_block + { Fn ($1 ++ fst $>) (unspan $2) (unspan $5) $7 (unspan $3) NotConst Rust ($6 `withWhere` $8) (snd $>) ($1 # $2 # $3 # $4 # snd $>) } + | many(outer_attribute) vis mod ident ';' + { Mod $1 (unspan $2) (unspan $4) Nothing ($1 # $2 # $3 # $>) } + | many(outer_attribute) vis mod ident '{' many(mod_item) '}' + { Mod $1 (unspan $2) (unspan $4) (Just $6) ($1 # $2 # $3 # $>) } + | many(outer_attribute) vis mod ident '{' inner_attrs many(mod_item) '}' + { Mod ($1 ++ toList $6) (unspan $2) (unspan $4) (Just $7) ($1 # $2 # $3 # $>) } + | many(outer_attribute) vis safety extern abi '{' many(foreign_item) '}' + {% noSafety $3 (ForeignMod $1 (unspan $2) $5 $7 ($1 # $2 # $4 # $>)) } + | many(outer_attribute) vis safety extern abi '{' inner_attrs many(foreign_item) '}' + {% noSafety $3 (ForeignMod ($1 ++ toList $7) (unspan $2) $5 $8 ($1 # $2 # $4 # $>)) } + | many(outer_attribute) vis struct ident generics struct_decl_args + { StructItem $1 (unspan $2) (unspan $4) (snd $6) ($5 `withWhere` fst $6) ($1 # $2 # $3 # snd $>) } + | many(outer_attribute) vis union ident generics struct_decl_args + { Union $1 (unspan $2) (unspan $4) (snd $6) ($5 `withWhere` fst $6) ($1 # $2 # $3 # snd $>) } + | many(outer_attribute) vis enum ident generics where_clause '{' sep_byT(enum_def,',') '}' + { Enum $1 (unspan $2) (unspan $4) $8 ($5 `withWhere` $6) ($1 # $2 # $3 # $>) } + | many(outer_attribute) vis safety trait ident generics ':' sep_by1T(ty_param_bound,'+') where_clause '{' many(trait_item) '}' + { Trait $1 (unspan $2) (unspan $5) False (unspan $3) ($6 `withWhere` $9) (toList $8) $11 ($1 # $2 # $3 # $4 # $>) } + | many(outer_attribute) vis safety trait ident generics where_clause '{' many(trait_item) '}' + { Trait $1 (unspan $2) (unspan $5) False (unspan $3) ($6 `withWhere` $7) [] $9 ($1 # $2 # $3 # $4 # $>) } + | many(outer_attribute) vis safety auto trait ident generics ':' sep_by1T(ty_param_bound,'+') where_clause '{' many(trait_item) '}' + { Trait $1 (unspan $2) (unspan $6) True (unspan $3) ($7 `withWhere` $10) (toList $9) $12 ($1 # $2 # $3 # $5 # $>) } + | many(outer_attribute) vis safety auto trait ident generics where_clause '{' many(trait_item) '}' + { Trait $1 (unspan $2) (unspan $6) True (unspan $3) ($7 `withWhere` $8) [] $10 ($1 # $2 # $3 # $5 # $>) } + | many(outer_attribute) vis safety trait ident generics '=' sep_by1T(ty_param_bound,'+') ';' + {% noSafety $3 (TraitAlias $1 (unspan $2) (unspan $5) $6 (toNonEmpty $8) ($1 # $2 # $3 # $>)) } + | many(outer_attribute) vis safety impl generics ty_prim where_clause '{' impl_items '}' + { Impl ($1 ++ fst $9) (unspan $2) Final (unspan $3) Positive ($5 `withWhere` $7) Nothing $6 (snd $9) ($1 # $2 # $3 # $4 # $5 # $>) } + | many(outer_attribute) vis default safety impl generics ty_prim where_clause '{' impl_items '}' + { Impl ($1 ++ fst $10) (unspan $2) Default (unspan $4) Positive ($6 `withWhere` $8) Nothing $7 (snd $10) ($1 # $2 # $3 # $4 # $5 # $>) } + | many(outer_attribute) vis safety impl generics '(' ty_no_plus ')' where_clause '{' impl_items '}' + { Impl ($1 ++ fst $11) (unspan $2) Final (unspan $3) Positive ($5 `withWhere` $9) Nothing (ParenTy $7 ($6 # $8)) (snd $11) ($1 # $2 # $3 # $4 # $5 # $>) } + | many(outer_attribute) vis default safety impl generics '(' ty_no_plus ')' where_clause '{' impl_items '}' + { Impl ($1 ++ fst $12) (unspan $2) Default (unspan $4) Positive ($6 `withWhere` $10) Nothing (ParenTy $8 ($7 # $9)) (snd $12) ($1 # $2 # $3 # $4 # $5 # $>) } + | many(outer_attribute) vis safety impl generics '!' trait_ref for ty where_clause '{' impl_items '}' + { Impl ($1 ++ fst $12) (unspan $2) Final (unspan $3) Negative ($5 `withWhere` $10) (Just $7) $9 (snd $12) ($1 # $2 # $3 # $4 # $5 # $>) } + | many(outer_attribute) vis default safety impl generics '!' trait_ref for ty where_clause '{' impl_items '}' + { Impl ($1 ++ fst $13) (unspan $2) Default (unspan $4) Negative ($6 `withWhere` $11) (Just $8) $10 (snd $13) ($1 # $2 # $3 # $4 # $5 # $>) } + | many(outer_attribute) vis safety impl generics trait_ref for ty where_clause '{' impl_items '}' + { Impl ($1 ++ fst $11) (unspan $2) Final (unspan $3) Positive ($5 `withWhere` $9) (Just $6) $8 (snd $11) ($1 # $2 # $3 # $4 # $5 # $>) } + | many(outer_attribute) vis default safety impl generics trait_ref for ty where_clause '{' impl_items '}' + { Impl ($1 ++ fst $12) (unspan $2) Default (unspan $4) Positive ($6 `withWhere` $10) (Just $7) $9 (snd $12) ($1 # $2 # $3 # $4 # $5 # $>) } + +mod_items :: { [Item Span] } + : many(mod_item) { $1 } + +-- Most general type of item +mod_item :: { Item Span } + : ntItem { $1 } + | gen_item(vis) { $1 } + | many(outer_attribute) expr_path '!' ident '[' token_stream ']' ';' + { macroItem $1 (Just (unspan $4)) (Mac $2 $6 ($2 # $>)) ($1 # $2 # $>) } + | many(outer_attribute) expr_path '!' '[' token_stream ']' ';' + { macroItem $1 Nothing (Mac $2 $5 ($2 # $>)) ($1 # $2 # $>) } + | many(outer_attribute) expr_path '!' ident '(' token_stream ')' ';' + { macroItem $1 (Just (unspan $4)) (Mac $2 $6 ($2 # $>)) ($1 # $2 # $>) } + | many(outer_attribute) expr_path '!' '(' token_stream ')' ';' + { macroItem $1 Nothing (Mac $2 $5 ($2 # $>)) ($1 # $2 # $>) } + | many(outer_attribute) expr_path '!' ident '{' token_stream '}' + { macroItem $1 (Just (unspan $4)) (Mac $2 $6 ($2 # $>)) ($1 # $2 # $>) } + | many(outer_attribute) expr_path '!' '{' token_stream '}' + { macroItem $1 Nothing (Mac $2 $5 ($2 # $>)) ($1 # $2 # $>) } + +foreign_item :: { ForeignItem Span } + : many(outer_attribute) vis static ident ':' ty ';' + { ForeignStatic $1 (unspan $2) (unspan $4) $6 Immutable ($1 # $2 # $>) } + | many(outer_attribute) vis static mut ident ':' ty ';' + { ForeignStatic $1 (unspan $2) (unspan $5) $7 Mutable ($1 # $2 # $>) } + | many(outer_attribute) vis fn ident generics fn_decl(arg_named) where_clause ';' + { ForeignFn $1 (unspan $2) (unspan $4) $6 ($5 `withWhere` $7) ($1 # $2 # $>) } + | many(outer_attribute) vis type ident ';' + { ForeignTy $1 (unspan $2) (unspan $4) ($1 # $2 # $>) } + +-- parse_generics +-- Leaves the WhereClause empty +generics :: { Generics Span } + : ntGenerics { $1 } + | '<' sep_by1(lifetime_def,',') ',' sep_by1T(ty_param,',') gt '>' { Generics (toList $2) (toList $4) (WhereClause [] mempty) ($1 # $>) } + | '<' sep_by1T(lifetime_def,',') gt '>' { Generics (toList $2) [] (WhereClause [] mempty) ($1 # $>) } + | '<' sep_by1T(ty_param,',') gt '>' { Generics [] (toList $2) (WhereClause [] mempty) ($1 # $>) } + | '<' gt '>' { Generics [] [] (WhereClause [] mempty) ($1 # $>) } + | {- empty -} { Generics [] [] (WhereClause [] mempty) mempty } + +ty_param :: { TyParam Span } + : many(outer_attribute) ident { TyParam $1 (unspan $2) [] Nothing ($1 # $>) } + | many(outer_attribute) ident ':' sep_by1T(ty_param_bound_mod,'+') { TyParam $1 (unspan $2) (toList $4) Nothing ($1 # $>) } + | many(outer_attribute) ident '=' ty { TyParam $1 (unspan $2) [] (Just $>) ($1 # $>) } + | many(outer_attribute) ident ':' sep_by1T(ty_param_bound_mod,'+') '=' ty { TyParam $1 (unspan $2) (toList $4) (Just $>) ($1 # $>) } + + +struct_decl_args :: { (WhereClause Span, VariantData Span) } + : where_clause ';' { ($1, UnitD ($1 # $>)) } + | where_clause '{' sep_byT(struct_decl_field,',') '}' { ($1, StructD $3 ($1 # $>)) } + | '(' sep_byT(tuple_decl_field,',') ')' where_clause ';' { ($4, TupleD $2 ($1 # $>)) } + +struct_decl_field :: { StructField Span } + : many(outer_attribute) vis ident ':' ty { StructField (Just (unspan $3)) (unspan $2) $5 $1 ($1 # $2 # $5) } + +tuple_decl_field :: { StructField Span } + : many(outer_attribute) vis ty { StructField Nothing (unspan $2) $3 $1 ($1 # $2 # $3) } + +enum_def :: { Variant Span } + : many(outer_attribute) ident '{' sep_byT(struct_decl_field,',') '}' { Variant (unspan $2) $1 (StructD $4 ($3 # $5)) Nothing ($1 # $2 # $>) } + | many(outer_attribute) ident '(' sep_byT(tuple_decl_field,',') ')' { Variant (unspan $2) $1 (TupleD $4 ($3 # $5)) Nothing ($1 # $2 # $>) } + | many(outer_attribute) ident initializer { Variant (unspan $2) $1 (UnitD mempty) $3 ($1 # $2 # $>) } + + +-- parse_where_clause +where_clause :: { WhereClause Span } + : {- empty -} { WhereClause [] mempty } + | ntWhereClause { $1 } + | where sep_by(where_predicate,',') %prec WHERE { WhereClause $2 ($1 # $2) } + | where sep_by1(where_predicate,',') ',' %prec WHERE { WhereClause (toList $2) ($1 # $3) } + +where_predicate :: { WherePredicate Span } + : lifetime { RegionPredicate $1 [] (spanOf $1) } + | lifetime ':' sep_by1T(lifetime,'+') { RegionPredicate $1 (toList $3) ($1 # $3) } + | no_for_ty %prec EQ { BoundPredicate [] $1 [] (spanOf $1) } + | no_for_ty '=' ty { EqPredicate $1 $3 ($1 # $3) } + | no_for_ty '==' ty { EqPredicate $1 $3 ($1 # $3) } + | no_for_ty ':' sep_by1T(ty_param_bound_mod,'+') { BoundPredicate [] $1 (toList $3) ($1 # $3) } + | for_lts no_for_ty { BoundPredicate (unspan $1) $2 [] ($1 # $2) } + | for_lts no_for_ty ':' sep_by1T(ty_param_bound_mod,'+') { BoundPredicate (unspan $1) $2 (toList $4) ($1 # $>) } + +impl_items :: { ([Attribute Span], [ImplItem Span]) } + : many(impl_item) { ([], $1) } + | inner_attrs many(impl_item) { (toList $1, $2) } + +impl_item :: { ImplItem Span } + : ntImplItem { $1 } + | many(outer_attribute) vis def type ident '=' ty ';' { TypeI $1 (unspan $2) (unspan $3) (unspan $5) $7 ($1 # $2 # $3 # $4 # $>) } + | many(outer_attribute) vis def const ident ':' ty '=' expr ';' { ConstI $1 (unspan $2) (unspan $3) (unspan $5) $7 $9 ($1 # $2 # $3 # $4 # $>) } + | many(outer_attribute) def mod_mac { MacroI $1 (unspan $2) $3 ($1 # $2 # $>) } + | many(outer_attribute) vis def const safety fn ident generics fn_decl_with_self_named where_clause inner_attrs_block + { let methodSig = MethodSig (unspan $5) Const Rust $9; generics = $8 `withWhere` $10 + in MethodI ($1 ++ fst $>) (unspan $2) (unspan $3) (unspan $7) generics methodSig (snd $>) ($1 # $2 # $3 # $4 # snd $>) } + | many(outer_attribute) vis def safety ext_abi fn ident generics fn_decl_with_self_named where_clause inner_attrs_block + { let methodSig = MethodSig (unspan $4) NotConst (unspan $5) $9; generics = $8 `withWhere` $10 + in MethodI ($1 ++ fst $>) (unspan $2) (unspan $3) (unspan $7) generics methodSig (snd $>) ($1 # $2 # $3 # $4 # $5 # $6 # snd $>) } + +trait_item :: { TraitItem Span } + : ntTraitItem { $1 } + | many(outer_attribute) const ident ':' ty initializer ';' { ConstT $1 (unspan $3) $5 $6 ($1 # $2 # $>) } + | many(outer_attribute) mod_mac { MacroT $1 $2 ($1 # $>) } + | many(outer_attribute) type ident ';' { TypeT $1 (unspan $3) [] Nothing ($1 # $2 # $>) } + | many(outer_attribute) type ident '=' ty ';' { TypeT $1 (unspan $3) [] (Just $5) ($1 # $2 # $>) } + | many(outer_attribute) type ident ':' sep_by1T(ty_param_bound_mod,'+') ';' + { TypeT $1 (unspan $3) (toList $5) Nothing ($1 # $2 # $>) } + | many(outer_attribute) type ident ':' sep_by1T(ty_param_bound_mod,'+') '=' ty ';' + { TypeT $1 (unspan $3) (toList $5) (Just $7) ($1 # $2 # $>) } + | many(outer_attribute) safety ext_abi fn ident generics fn_decl_with_self_general where_clause ';' + { let methodSig = MethodSig (unspan $2) NotConst (unspan $3) $7; generics = $6 `withWhere` $8 + in MethodT $1 (unspan $5) generics methodSig Nothing ($1 # $2 # $3 # $4 # $>) } + | many(outer_attribute) safety ext_abi fn ident generics fn_decl_with_self_general where_clause inner_attrs_block + { let methodSig = MethodSig (unspan $2) NotConst (unspan $3) $7; generics = $6 `withWhere` $8 + in MethodT ($1 ++ fst $>) (unspan $5) generics methodSig (Just (snd $>)) ($1 # $2 # $3 # $4 # snd $>) } + +safety :: { Spanned Unsafety } + : {- empty -} { pure Normal } + | unsafe { Spanned Unsafe (spanOf $1) } + +ext_abi :: { Spanned Abi } + : {- empty -} { pure Rust } + | extern abi { Spanned $2 (spanOf $1) } + +vis :: { Spanned (Visibility Span) } + : {- empty -} %prec VIS { Spanned InheritedV mempty } + | pub %prec VIS { Spanned PublicV (spanOf $1) } + | pub '(' crate ')' { Spanned CrateV ($1 # $4) } + | crate { Spanned CrateV (spanOf $1) } + | pub '(' in mod_path ')' { Spanned (RestrictedV $4) ($1 # $5) } + | pub '(' super ')' { Spanned (RestrictedV (Path False [PathSegment "super" Nothing (spanOf + $3)] (spanOf $3))) ($1 # $4) } + | pub '(' self ')' { Spanned (RestrictedV (Path False [PathSegment "self" Nothing (spanOf + $3)] (spanOf $3))) ($1 # $4) } + +def :: { Spanned Defaultness } + : {- empty -} %prec DEF { pure Final } + | default { Spanned Default (spanOf $1) } + +use_tree :: { UseTree Span } + : mod_path { UseTreeSimple $1 Nothing (spanOf $1) } + | mod_path as ident { UseTreeSimple $1 (Just (unspan $3)) ($1 # $3) } + | mod_path '::' '*' { UseTreeGlob $1 ($1 # $3) } + | '::' '*' { UseTreeGlob (Path True [] (spanOf $1)) ($1 # $2) } + | '*' { UseTreeGlob (Path False [] mempty) (spanOf $1) } + | mod_path '::' '{' sep_byT(use_tree,',') '}' { UseTreeNested $1 $4 ($1 # $>) } + | '::' '{' sep_byT(use_tree,',') '}' { UseTreeNested (Path True [] (spanOf $1)) $3 ($1 # $>) } + | '{' sep_byT(use_tree,',') '}' { UseTreeNested (Path False [] mempty) $2 ($1 # $>) } + +------------------- +-- Macro related -- +------------------- + +expr_mac :: { Mac Span } + : expr_path '!' '[' token_stream ']' { Mac $1 $4 ($1 # $>) } + | expr_path '!' '(' token_stream ')' { Mac $1 $4 ($1 # $>) } + +ty_mac :: { Mac Span } + : ty_path '!' '[' token_stream ']' { Mac $1 $4 ($1 # $>) } + | ty_path '!' '{' token_stream '}' { Mac $1 $4 ($1 # $>) } + | ty_path '!' '(' token_stream ')' { Mac $1 $4 ($1 # $>) } + +mod_mac :: { Mac Span } + : mod_path '!' '[' token_stream ']' ';' { Mac $1 $4 ($1 # $>) } + | mod_path '!' '{' token_stream '}' { Mac $1 $4 ($1 # $>) } + | mod_path '!' '(' token_stream ')' ';' { Mac $1 $4 ($1 # $>) } + +token_stream :: { TokenStream } + : {- empty -} { Stream [] } + | some(token_tree) { + case $1 of + [tt] -> Tree tt + tts -> Stream [ Tree tt | tt <- toList tts ] + } + +token_stream_no_embed :: { TokenStream } + : {- empty -} { Stream [] } + | some(token_tree_no_embed) { + case $1 of + [tt] -> Tree tt + tts -> Stream [ Tree tt | tt <- toList tts ] + } + +token_tree :: { TokenTree } + : ntTT { $1 } + -- # Delimited + | '(' token_stream ')' { Delimited ($1 # $3) Paren $2 } + | '{' token_stream '}' { Delimited ($1 # $3) Brace $2 } + | '[' token_stream ']' { Delimited ($1 # $3) Bracket $2 } + -- # Token + | token { let Spanned t s = $1 in Token s t } + +token :: { Spanned Token } + : '=' { $1 } + | '<' { $1 } + | '>' { $1 } + | '!' { $1 } + | '~' { $1 } + | '-' { $1 } + | '/' { $1 } + | '+' { $1 } + | '*' { $1 } + | '%' { $1 } + | '^' { $1 } + | '&' { $1 } + | '|' { $1 } + | '<<=' { $1 } + | '>>=' { $1 } + | '-=' { $1 } + | '&=' { $1 } + | '|=' { $1 } + | '+=' { $1 } + | '*=' { $1 } + | '/=' { $1 } + | '^=' { $1 } + | '%=' { $1 } + | '||' { $1 } + | '&&' { $1 } + | '==' { $1 } + | '!=' { $1 } + | '<=' { $1 } + | '>=' { $1 } + | '<<' { $1 } + | '>>' { $1 } + -- Structural symbols. + | '@' { $1 } + | '...' { $1 } + | '..=' { $1 } + | '..' { $1 } + | '.' { $1 } + | ',' { $1 } + | ';' { $1 } + | '::' { $1 } + | ':' { $1 } + | '->' { $1 } + | '<-' { $1 } + | '=>' { $1 } + | '#' { $1 } + | '$' { $1 } + | '?' { $1 } + | '#!' { $1 } + -- Literals. + | byte { $1 } + | char { $1 } + | int { $1 } + | float { $1 } + | str { $1 } + | byteStr { $1 } + | rawStr { $1 } + | rawByteStr { $1 } + -- Strict keywords used in the language + | as { $1 } + | box { $1 } + | break { $1 } + | const { $1 } + | continue { $1 } + | crate { $1 } + | else { $1 } + | enum { $1 } + | extern { $1 } + | false { $1 } + | fn { $1 } + | for { $1 } + | if { $1 } + | impl { $1 } + | in { $1 } + | let { $1 } + | loop { $1 } + | match { $1 } + | mod { $1 } + | move { $1 } + | mut { $1 } + | pub { $1 } + | ref { $1 } + | return { $1 } + | Self { $1 } + | self { $1 } + | static { $1 } + | struct { $1 } + | super { $1 } + | trait { $1 } + | true { $1 } + | type { $1 } + | unsafe { $1 } + | use { $1 } + | where { $1 } + | while { $1 } + -- Keywords reserved for future use + | abstract { $1 } + | alignof { $1 } + | become { $1 } + | do { $1 } + | final { $1 } + | macro { $1 } + | offsetof { $1 } + | override { $1 } + | priv { $1 } + | proc { $1 } + | pure { $1 } + | sizeof { $1 } + | typeof { $1 } + | unsized { $1 } + | virtual { $1 } + -- Weak keywords, have special meaning only in specific contexts. + | default { $1 } + | union { $1 } + | catch { $1 } + | auto { $1 } + | yield { $1 } + | dyn { $1 } + -- Comments + | outerDoc { $1 } + | innerDoc { $1 } + -- Identifiers. + | IDENT { $1 } + | EMBEDDED_IDENT { $1 } + | '_' { $1 } + -- Lifetimes. + | LIFETIME { $1 } + +token_tree_no_embed :: { TokenTree } + : ntTT { $1 } + -- # Delimited + | '(' token_stream_no_embed ')' { Delimited ($1 # $3) Paren $2 } + | '{' token_stream_no_embed '}' { Delimited ($1 # $3) Brace $2 } + | '[' token_stream_no_embed ']' { Delimited ($1 # $3) Bracket $2 } + -- # Token + | token_no_embed { let Spanned t s = $1 in Token s t } + +token_no_embed :: { Spanned Token } + : '=' { $1 } + | '<' { $1 } + | '>' { $1 } + | '!' { $1 } + | '~' { $1 } + | '-' { $1 } + | '/' { $1 } + | '+' { $1 } + | '*' { $1 } + | '%' { $1 } + | '^' { $1 } + | '&' { $1 } + | '|' { $1 } + | '<<=' { $1 } + | '>>=' { $1 } + | '-=' { $1 } + | '&=' { $1 } + | '|=' { $1 } + | '+=' { $1 } + | '*=' { $1 } + | '/=' { $1 } + | '^=' { $1 } + | '%=' { $1 } + | '||' { $1 } + | '&&' { $1 } + | '==' { $1 } + | '!=' { $1 } + | '<=' { $1 } + | '>=' { $1 } + | '<<' { $1 } + | '>>' { $1 } + -- Structural symbols. + | '@' { $1 } + | '...' { $1 } + | '..=' { $1 } + | '..' { $1 } + | '.' { $1 } + | ',' { $1 } + | ';' { $1 } + | '::' { $1 } + | ':' { $1 } + | '->' { $1 } + | '<-' { $1 } + | '=>' { $1 } + | '#' { $1 } + | '$' { $1 } + | '?' { $1 } + | '#!' { $1 } + -- Literals. + | byte { $1 } + | char { $1 } + | int { $1 } + | float { $1 } + | str { $1 } + | byteStr { $1 } + | rawStr { $1 } + | rawByteStr { $1 } + -- Strict keywords used in the language + | as { $1 } + | box { $1 } + | break { $1 } + | const { $1 } + | continue { $1 } + | crate { $1 } + | else { $1 } + | enum { $1 } + | extern { $1 } + | false { $1 } + | fn { $1 } + | for { $1 } + | if { $1 } + | impl { $1 } + | in { $1 } + | let { $1 } + | loop { $1 } + | match { $1 } + | mod { $1 } + | move { $1 } + | mut { $1 } + | pub { $1 } + | ref { $1 } + | return { $1 } + | Self { $1 } + | self { $1 } + | static { $1 } + | struct { $1 } + | super { $1 } + | trait { $1 } + | true { $1 } + | type { $1 } + | unsafe { $1 } + | use { $1 } + | where { $1 } + | while { $1 } + -- Keywords reserved for future use + | abstract { $1 } + | alignof { $1 } + | become { $1 } + | do { $1 } + | final { $1 } + | macro { $1 } + | offsetof { $1 } + | override { $1 } + | priv { $1 } + | proc { $1 } + | pure { $1 } + | sizeof { $1 } + | typeof { $1 } + | unsized { $1 } + | virtual { $1 } + -- Weak keywords, have special meaning only in specific contexts. + | default { $1 } + | union { $1 } + | catch { $1 } + | auto { $1 } + | yield { $1 } + | dyn { $1 } + -- Comments + | outerDoc { $1 } + | innerDoc { $1 } + -- Identifiers. + | IDENT { $1 } + | '_' { $1 } + -- Lifetimes. + | LIFETIME { $1 } + +--------------------- +-- Just for export -- +--------------------- + +-- These rules aren't used anywhere in the grammar above, they just provide a more general parsers. + +-- Any attribute +export_attribute :: { Attribute Span } + : inner_attribute { $1 } + | outer_attribute { $1 } + +-- Complete blocks +export_block :: { Block Span } + : ntBlock { $1 } + | safety '{' '}' { Block [] (unspan $1) ($1 # $2 # $>) } + | safety '{' stmts_possibly_no_semi '}' { Block [ s | Just s <- $3 ] (unspan $1) ($1 # $2 # $>) } + +{ +-- | Parser for literals. +parseLit :: P (Lit Span) + +-- | Parser for attributes. +parseAttr :: P (Attribute Span) + +-- | Parser for types. +parseTy :: P (Ty Span) + +-- | Parser for patterns. +parsePat :: P (Pat Span) + +-- | Parser for statements. +parseStmt :: P (Stmt Span) + +-- | Parser for expressions. +parseExpr :: P (Expr Span) + +-- | Parser for items. +parseItem :: P (Item Span) + +-- | Parser for blocks. +parseBlock :: P (Block Span) + +-- | Parser for @impl@ items. +parseImplItem :: P (ImplItem Span) + +-- | Parser for @trait@ items. +parseTraitItem :: P (TraitItem Span) + +-- | Parser for token trees. +parseTt :: P TokenTree + +-- | Parser for token streams. +parseTokenStream :: P TokenStream + +-- | Parser for lifetime definitions. +parseLifetimeDef :: P (LifetimeDef Span) + +-- | Parser for a type parameter. +parseTyParam :: P (TyParam Span) + +-- | Parser for a where clause. +parseWhereClause :: P (WhereClause Span) + +-- | Parser for generics (although 'WhereClause' is always empty here). +parseGenerics :: P (Generics Span) + +-- | Generate a nice looking error message based on expected tokens +expParseError :: (Spanned Token, [String]) -> P a +expParseError (Spanned t _, exps) = fail $ "Syntax error: unexpected `" ++ show t ++ "'" ++ + case go (sort exps) [] replacements of + [] -> "" + [s] -> " (expected " ++ s ++ ")" + [s2,s1] -> " (expected " ++ s1 ++ " or " ++ s2 ++ ")" + (s : ss) -> " (expected " ++ (reverse ss >>= (++ ", ")) ++ "or " ++ s ++ ")" + where + + go [] msgs _ = msgs + go (e:es) msgs rs | e `elem` ignore = go es msgs rs + go (e:es) msgs [] = go es (e : msgs) [] + go es msgs ((rep,msg):rs) + | rep `isSubsequenceOf` es = go (es \\ rep) (msg : msgs) rs + | otherwise = go es msgs rs + + ignore = words "ntItem ntBlock ntStmt ntPat ntExpr ntTy ntIdent ntPath ntTT" ++ + words "ntArm ntImplItem ntTraitItem ntGenerics ntWhereClause ntArg ntLit" + + replacements = map (\(ks,v) -> (sort ks,v)) $ + [ (expr, "an expression" ) + + , (lit, "a literal" ) + , (boolLit, "a boolean" ) + , (byteLit, "a byte" ) + , (charLit, "a character" ) + , (intLit, "an int" ) + , (floatLit, "a float" ) + , (strLit, "a string" ) + , (byteStrLit, "a byte string" ) + , (rawStrLit, "a raw string" ) + , (rawByteStrLit, "a raw bytestring") + + , (doc, "a doc" ) + , (outerDoc, "an outer doc" ) + , (innerDoc, "an inner doc" ) + + , (identifier, "an identifier" ) + , (lifetime, "a lifetime" ) + ] + + expr :: [String] + expr = lit ++ identifier ++ lifetime ++ + words "'<' '!' '-' '*' '&' '|' '...' '..=' '..' '::'" ++ + words "'||' '&&' '<<' '(' '[' '{' box break continue" ++ + words "for if loop match move return Self self " ++ + words "static super unsafe while do default union " ++ + words "catch auto yield dyn" + + lit = boolLit ++ byteLit ++ charLit ++ intLit ++ floatLit ++ strLit ++ + byteStrLit ++ rawStrLit ++ rawByteStrLit + boolLit = words "true false" + byteLit = words "byte" + charLit = words "char" + intLit = words "int" + floatLit = words "float" + strLit = words "str" + byteStrLit = words "byteStr" + rawStrLit = words "rawStr" + rawByteStrLit = words "rawByteStr" + + doc = outerDoc ++ innerDoc + outerDoc = words "outerDoc" + innerDoc = words "innerDoc" + + identifier = words "IDENT" + lifetime = words "LIFETIME" + +-- | Convert an 'IdentTok' into an 'Ident' +toIdent :: Spanned Token -> Spanned Ident +toIdent (Spanned (IdentTok i) s) = Spanned i s + +toEmbedded :: [Attribute Span] -> Spanned Token -> Expr Span +toEmbedded as (Spanned (EmbeddedCode c) s) = EmbeddedExpr as c s + +-- | Try to convert an expression to a statement given information about whether there is a trailing +-- semicolon +toStmt :: Expr Span -> Bool -> Bool -> Span -> Stmt Span +toStmt (MacExpr a m s) hasSemi isBlock | hasSemi = MacStmt m SemicolonMac a + | isBlock = MacStmt m BracesMac a +toStmt e hasSemi _ = (if hasSemi then Semi else NoSemi) e + +-- | Return the second argument, as long as the visibility is 'InheritedV' +noVis :: Spanned (Visibility Span) -> a -> P a +noVis (Spanned InheritedV _) x = pure x +noVis _ _ = fail "visibility is not allowed here" + +-- | Fill in the where clause in a generic +withWhere :: Generics a -> WhereClause a -> Generics a +withWhere (Generics l t _ x) w = Generics l t w x + +-- | Return the second argument, as long as the safety is 'Normal' +noSafety :: Spanned Unsafety -> a -> P a +noSafety (Spanned Normal _) x = pure x +noSafety _ _ = fail "safety is not allowed here" + +-- | Make a macro item, which may be a 'MacroDef' +macroItem :: [Attribute Span] -> (Maybe Ident) -> Mac Span -> Span -> Item Span +macroItem as (Just i) (Mac (Path False [PathSegment "macro_rules" Nothing _] _) tts _) x = MacroDef as i tts x +macroItem as i mac x = MacItem as i mac x + +-- | Add attributes to an expression +addAttrs :: [Attribute Span] -> Expr Span -> Expr Span +addAttrs as (Box as' e s) = Box (as ++ as') e s +addAttrs as (InPlace as' e1 e2 s) = InPlace (as ++ as') e1 e2 s +addAttrs as (Vec as' e s) = Vec (as ++ as') e s +addAttrs as (Call as' f es s) = Call (as ++ as') f es s +addAttrs as (MethodCall as' i s tys es s') = MethodCall (as ++ as') i s tys es s' +addAttrs as (TupExpr as' e s) = TupExpr (as ++ as') e s +addAttrs as (Binary as' b e1 e2 s) = Binary (as ++ as') b e1 e2 s +addAttrs as (Unary as' u e s) = Unary (as ++ as') u e s +addAttrs as (Lit as' l s) = Lit (as ++ as') l s +addAttrs as (Cast as' e t s) = Cast (as ++ as') e t s +addAttrs as (TypeAscription as' e t s) = TypeAscription (as ++ as') e t s +addAttrs as (If as' e1 b b2 s) = If (as ++ as') e1 b b2 s +addAttrs as (IfLet as' p e b em s) = IfLet (as ++ as') p e b em s +addAttrs as (While as' e b l s) = While (as ++ as') e b l s +addAttrs as (WhileLet as' p e b l s) = WhileLet (as ++ as') p e b l s +addAttrs as (ForLoop as' p e b l s) = ForLoop (as ++ as') p e b l s +addAttrs as (Loop as' b l s) = Loop (as ++ as') b l s +addAttrs as (Match as' e a s) = Match (as ++ as') e a s +addAttrs as (Closure as' m c f e s) = Closure (as ++ as') m c f e s +addAttrs as (BlockExpr as' b s) = BlockExpr (as ++ as') b s +addAttrs as (Catch as' b s) = Catch (as ++ as') b s +addAttrs as (Assign as' e1 e2 s) = Assign (as ++ as') e1 e2 s +addAttrs as (AssignOp as' b e1 e2 s) = AssignOp (as ++ as') b e1 e2 s +addAttrs as (FieldAccess as' e i s) = FieldAccess (as ++ as') e i s +addAttrs as (TupField as' e i s) = TupField (as ++ as') e i s +addAttrs as (Index as' e1 e2 s) = Index (as ++ as') e1 e2 s +addAttrs as (Range as' e1 e2 r s) = Range (as ++ as') e1 e2 r s +addAttrs as (PathExpr as' q p s) = PathExpr (as ++ as') q p s +addAttrs as (AddrOf as' m e s) = AddrOf (as ++ as') m e s +addAttrs as (Break as' l e s) = Break (as ++ as') l e s +addAttrs as (Continue as' l s) = Continue (as ++ as') l s +addAttrs as (Ret as' e s) = Ret (as ++ as') e s +addAttrs as (MacExpr as' m s) = MacExpr (as ++ as') m s +addAttrs as (Struct as' p f e a) = Struct (as ++ as') p f e a +addAttrs as (Repeat as' e1 e2 s) = Repeat (as ++ as') e1 e2 s +addAttrs as (ParenExpr as' e s) = ParenExpr (as ++ as') e s +addAttrs as (Try as' e s) = Try (as ++ as') e s +addAttrs as (Yield as' e s) = Yield (as ++ as') e s + + +-- | Given a 'LitTok' token that is expected to result in a valid literal, construct the associated +-- literal. Note that this should _never_ fail on a token produced by the lexer. +lit :: Spanned Token -> Lit Span +lit (Spanned (IdentTok (Ident (Name "true") False _)) s) = Bool True Unsuffixed s +lit (Spanned (IdentTok (Ident (Name "false") False _)) s) = Bool False Unsuffixed s +lit (Spanned (LiteralTok litTok suffix_m) s) = translateLit litTok suffix s + where + suffix = case suffix_m of + Nothing -> Unsuffixed + (Just "isize") -> Is + (Just "usize") -> Us + (Just "i8") -> I8 + (Just "u8") -> U8 + (Just "i16") -> I16 + (Just "u16") -> U16 + (Just "i32") -> I32 + (Just "u32") -> U32 + (Just "i64") -> I64 + (Just "u64") -> U64 + (Just "i128") -> I128 + (Just "u128") -> U128 + (Just "f32") -> F32 + (Just "f64") -> F64 + _ -> error "invalid literal" + +isTraitTyParamBound TraitTyParamBound{} = True +isTraitTyParamBound _ = False + +-- | Parse a source file +parseSourceFile :: P (SourceFile Span) +parseSourceFile = do + sh <- lexShebangLine + (as,items) <- parseSourceFileContents + pure (SourceFile sh as items) + +-- | Nudge the span endpoints of a 'Span' value +nudge :: Int -> Int -> Span -> Span +nudge leftSide rightSide (Span l r) = Span l' r' + where l' = incPos l leftSide + r' = incPos r rightSide + +} diff --git a/src/Language/Rust/Parser/Lexer.x b/src/Language/Rust/Parser/Lexer.x new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Parser/Lexer.x @@ -0,0 +1,1321 @@ +{ +{-| +Module : Language.Rust.Parser.Lexer +Description : Rust lexer +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : portable + +As much as possible, this follows Rust's choices for tokenization, including punting some things to +the parser. For instance, the last two @>@ in @Vec\\>@ are lexed as a single +'GreaterGreater' token while the last two tokens of @Vec\\>\>@ are +'GreaterGreater' and 'Greater'. + +Yet weirder (but very useful in parsing for dealing with conflicts and precedences of logical and, +bitwise and, and unary reference), @&&&x&&&y@ lexes into 'AmpersandAmpersand', 'Ampersand', +@'IdentTok' "x"@, 'AmpersandAmpersand', 'Ampersand', @'IdentTok' "y"@. Although the parser sometimes +needs to "break apart" tokens, it never has to think about putting them together. That means it can +easily figure out that @&&&x&&&y@ parses as @&(&(&x)) && (&y)@ and not @&(&(&x)) & (&(&y))@ even if +bitwise conjunctions bind more tightly that logical conjunctions. + +This sort of amguity where one token need to be broken up by the parser occurs for + + * @&&@ in patterns like @&&mut x@ + * @||@ in closures with no arguments like @|| x@ + * @<<@ in qualified type paths like @FromIterator\<\::Item\>@ + * @>>@ in qualified paths like @\\>::Bar@ + * @>=@ in equality predicates like @F\=i32@ + * @>>=@ in equality predicates like @F\\>=i32@ +-} + +module Language.Rust.Parser.Lexer ( + -- * Lexing + lexToken, + lexNonSpace, + lexTokens, + lexShebangLine, + + -- * Tokens + Token(..), + + -- * Error reporting + lexicalError, +) where + +import Language.Rust.Data.Ident ( mkIdent, Ident(..), IdentName(..) ) +import Language.Rust.Data.InputStream +import Language.Rust.Data.Position +import Language.Rust.Parser.ParseMonad +import Language.Rust.Syntax.Token + +import Data.Char ( chr ) +import Data.Word ( Word8 ) + +-- Things to review: +-- * improved error messages + +-- Based heavily on: +-- * +-- * +-- * + +} + +-- XID_START unicode character class +@xid_start + = [\x0041-\x005a] + | "_" + | [\x0061-\x007a] + | \x00aa + | \x00b5 + | \x00ba + | [\x00c0-\x00d6] + | [\x00d8-\x00f6] + | [\x00f8-\x0236] + | [\x0250-\x02c1] + | [\x02c6-\x02d1] + | [\x02e0-\x02e4] + | \x02ee + | \x0386 + | [\x0388-\x038a] + | \x038c + | [\x038e-\x03a1] + | [\x03a3-\x03ce] + | [\x03d0-\x03f5] + | [\x03f7-\x03fb] + | [\x0400-\x0481] + | [\x048a-\x04ce] + | [\x04d0-\x04f5] + | [\x04f8-\x04f9] + | [\x0500-\x050f] + | [\x0531-\x0556] + | \x0559 + | [\x0561-\x0587] + | [\x05d0-\x05ea] + | [\x05f0-\x05f2] + | [\x0621-\x063a] + | [\x0640-\x064a] + | [\x066e-\x066f] + | [\x0671-\x06d3] + | \x06d5 + | [\x06e5-\x06e6] + | [\x06ee-\x06ef] + | [\x06fa-\x06fc] + | \x06ff + | \x0710 + | [\x0712-\x072f] + | [\x074d-\x074f] + | [\x0780-\x07a5] + | \x07b1 + | [\x0904-\x0939] + | \x093d + | \x0950 + | [\x0958-\x0961] + | [\x0985-\x098c] + | [\x098f-\x0990] + | [\x0993-\x09a8] + | [\x09aa-\x09b0] + | \x09b2 + | [\x09b6-\x09b9] + | \x09bd + | [\x09dc-\x09dd] + | [\x09df-\x09e1] + | [\x09f0-\x09f1] + | [\x0a05-\x0a0a] + | [\x0a0f-\x0a10] + | [\x0a13-\x0a28] + | [\x0a2a-\x0a30] + | [\x0a32-\x0a33] + | [\x0a35-\x0a36] + | [\x0a38-\x0a39] + | [\x0a59-\x0a5c] + | \x0a5e + | [\x0a72-\x0a74] + | [\x0a85-\x0a8d] + | [\x0a8f-\x0a91] + | [\x0a93-\x0aa8] + | [\x0aaa-\x0ab0] + | [\x0ab2-\x0ab3] + | [\x0ab5-\x0ab9] + | \x0abd + | \x0ad0 + | [\x0ae0-\x0ae1] + | [\x0b05-\x0b0c] + | [\x0b0f-\x0b10] + | [\x0b13-\x0b28] + | [\x0b2a-\x0b30] + | [\x0b32-\x0b33] + | [\x0b35-\x0b39] + | \x0b3d + | [\x0b5c-\x0b5d] + | [\x0b5f-\x0b61] + | \x0b71 + | \x0b83 + | [\x0b85-\x0b8a] + | [\x0b8e-\x0b90] + | [\x0b92-\x0b95] + | [\x0b99-\x0b9a] + | \x0b9c + | [\x0b9e-\x0b9f] + | [\x0ba3-\x0ba4] + | [\x0ba8-\x0baa] + | [\x0bae-\x0bb5] + | [\x0bb7-\x0bb9] + | [\x0c05-\x0c0c] + | [\x0c0e-\x0c10] + | [\x0c12-\x0c28] + | [\x0c2a-\x0c33] + | [\x0c35-\x0c39] + | [\x0c60-\x0c61] + | [\x0c85-\x0c8c] + | [\x0c8e-\x0c90] + | [\x0c92-\x0ca8] + | [\x0caa-\x0cb3] + | [\x0cb5-\x0cb9] + | \x0cbd + | \x0cde + | [\x0ce0-\x0ce1] + | [\x0d05-\x0d0c] + | [\x0d0e-\x0d10] + | [\x0d12-\x0d28] + | [\x0d2a-\x0d39] + | [\x0d60-\x0d61] + | [\x0d85-\x0d96] + | [\x0d9a-\x0db1] + | [\x0db3-\x0dbb] + | \x0dbd + | [\x0dc0-\x0dc6] + | [\x0e01-\x0e30] + | \x0e32 + | [\x0e40-\x0e46] + | [\x0e81-\x0e82] + | \x0e84 + | [\x0e87-\x0e88] + | \x0e8a + | \x0e8d + | [\x0e94-\x0e97] + | [\x0e99-\x0e9f] + | [\x0ea1-\x0ea3] + | \x0ea5 + | \x0ea7 + | [\x0eaa-\x0eab] + | [\x0ead-\x0eb0] + | \x0eb2 + | \x0ebd + | [\x0ec0-\x0ec4] + | \x0ec6 + | [\x0edc-\x0edd] + | \x0f00 + | [\x0f40-\x0f47] + | [\x0f49-\x0f6a] + | [\x0f88-\x0f8b] + | [\x1000-\x1021] + | [\x1023-\x1027] + | [\x1029-\x102a] + | [\x1050-\x1055] + | [\x10a0-\x10c5] + | [\x10d0-\x10f8] + | [\x1100-\x1159] + | [\x115f-\x11a2] + | [\x11a8-\x11f9] + | [\x1200-\x1206] + | [\x1208-\x1246] + | \x1248 + | [\x124a-\x124d] + | [\x1250-\x1256] + | \x1258 + | [\x125a-\x125d] + | [\x1260-\x1286] + | \x1288 + | [\x128a-\x128d] + | [\x1290-\x12ae] + | \x12b0 + | [\x12b2-\x12b5] + | [\x12b8-\x12be] + | \x12c0 + | [\x12c2-\x12c5] + | [\x12c8-\x12ce] + | [\x12d0-\x12d6] + | [\x12d8-\x12ee] + | [\x12f0-\x130e] + | \x1310 + | [\x1312-\x1315] + | [\x1318-\x131e] + | [\x1320-\x1346] + | [\x1348-\x135a] + | [\x13a0-\x13f4] + | [\x1401-\x166c] + | [\x166f-\x1676] + | [\x1681-\x169a] + | [\x16a0-\x16ea] + | [\x16ee-\x16f0] + | [\x1700-\x170c] + | [\x170e-\x1711] + | [\x1720-\x1731] + | [\x1740-\x1751] + | [\x1760-\x176c] + | [\x176e-\x1770] + | [\x1780-\x17b3] + | \x17d7 + | \x17dc + | [\x1820-\x1877] + | [\x1880-\x18a8] + | [\x1900-\x191c] + | [\x1950-\x196d] + | [\x1970-\x1974] + | [\x1d00-\x1d6b] + | [\x1e00-\x1e9b] + | [\x1ea0-\x1ef9] + | [\x1f00-\x1f15] + | [\x1f18-\x1f1d] + | [\x1f20-\x1f45] + | [\x1f48-\x1f4d] + | [\x1f50-\x1f57] + | \x1f59 + | \x1f5b + | \x1f5d + | [\x1f5f-\x1f7d] + | [\x1f80-\x1fb4] + | [\x1fb6-\x1fbc] + | \x1fbe + | [\x1fc2-\x1fc4] + | [\x1fc6-\x1fcc] + | [\x1fd0-\x1fd3] + | [\x1fd6-\x1fdb] + | [\x1fe0-\x1fec] + | [\x1ff2-\x1ff4] + | [\x1ff6-\x1ffc] + | \x2071 + | \x207f + | \x2102 + | \x2107 + | [\x210a-\x2113] + | \x2115 + | [\x2118-\x211d] + | \x2124 + | \x2126 + | \x2128 + | [\x212a-\x2131] + | [\x2133-\x2139] + | [\x213d-\x213f] + | [\x2145-\x2149] + | [\x2160-\x2183] + | [\x3005-\x3007] + | [\x3021-\x3029] + | [\x3031-\x3035] + | [\x3038-\x303c] + | [\x3041-\x3096] + | [\x309d-\x309f] + | [\x30a1-\x30fa] + | [\x30fc-\x30ff] + | [\x3105-\x312c] + | [\x3131-\x318e] + | [\x31a0-\x31b7] + | [\x31f0-\x31ff] + | [\x3400-\x4db5] + | [\x4e00-\x9fa5] + | [\xa000-\xa48c] + | [\xac00-\xd7a3] + | [\xf900-\xfa2d] + | [\xfa30-\xfa6a] + | [\xfb00-\xfb06] + | [\xfb13-\xfb17] + | \xfb1d + | [\xfb1f-\xfb28] + | [\xfb2a-\xfb36] + | [\xfb38-\xfb3c] + | \xfb3e + | [\xfb40-\xfb41] + | [\xfb43-\xfb44] + | [\xfb46-\xfbb1] + | [\xfbd3-\xfc5d] + | [\xfc64-\xfd3d] + | [\xfd50-\xfd8f] + | [\xfd92-\xfdc7] + | [\xfdf0-\xfdf9] + | \xfe71 + | \xfe73 + | \xfe77 + | \xfe79 + | \xfe7b + | \xfe7d + | [\xfe7f-\xfefc] + | [\xff21-\xff3a] + | [\xff41-\xff5a] + | [\xff66-\xff9d] + | [\xffa0-\xffbe] + | [\xffc2-\xffc7] + | [\xffca-\xffcf] + | [\xffd2-\xffd7] + | [\xffda-\xffdc] + | \xd800 [\xdc00-\xdc0a] + | \xd800 [\xdc0d-\xdc25] + | \xd800 [\xdc28-\xdc39] + | \xd800 [\xdc3c-\xdc3c] + | \xd800 [\xdc3f-\xdc4c] + | \xd800 [\xdc50-\xdc5c] + | \xd800 [\xdc80-\xdcf9] + | \xd800 [\xdf00-\xdf1d] + | \xd800 [\xdf30-\xdf49] + | \xd800 [\xdf80-\xdf9c] + | \xd801 [\xe000-\xe09c] + | \xd802 [\xe400-\xe404] + | \xd802 \x0808 + | \xd802 [\xe40a-\xe434] + | \xd802 [\xe437-\xe437] + | \xd802 \x083c + | \xd802 \x083f + | \xd835 [\xb000-\xb053] + | \xd835 [\xb056-\xb09b] + | \xd835 [\xb09e-\xb09e] + | \xd835 \xd4a2 + | \xd835 [\xb0a5-\xb0a5] + | \xd835 [\xb0a9-\xb0ab] + | \xd835 [\xb0ae-\xb0b8] + | \xd835 \xd4bb + | \xd835 [\xb0bd-\xb0c2] + | \xd835 [\xb0c5-\xb104] + | \xd835 [\xb107-\xb109] + | \xd835 [\xb10d-\xb113] + | \xd835 [\xb116-\xb11b] + | \xd835 [\xb11e-\xb138] + | \xd835 [\xb13b-\xb13d] + | \xd835 [\xb140-\xb143] + | \xd835 \xd546 + | \xd835 [\xb14a-\xb14f] + | \xd835 [\xb152-\xb2a2] + | \xd835 [\xb2a8-\xb2bf] + | \xd835 [\xb2c2-\xb2d9] + | \xd835 [\xb2dc-\xb2f9] + | \xd835 [\xb2fc-\xb313] + | \xd835 [\xb316-\xb333] + | \xd835 [\xb336-\xb34d] + | \xd835 [\xb350-\xb36d] + | \xd835 [\xb370-\xb387] + | \xd835 [\xb38a-\xb3a7] + | \xd835 [\xb3aa-\xb3c1] + | \xd835 [\xb3c4-\xb3c8] + | \xd840 [\xdc00-\xdffe] + | \xd841 [\xe000-\xe3fe] + | \xd842 [\xe400-\xe7fe] + | \xd843 [\xe800-\xebfe] + | \xd844 [\xec00-\xeffe] + | \xd845 [\xf000-\xf3fe] + | \xd846 [\xf400-\xf7fe] + | \xd847 [\xf800-\xfbfe] + | \xd848 [\xfc00-\xfffe] + | \xd849 [\x0000-\x03fe] + | \xd84a [\x0400-\x07fe] + | \xd84b [\x0800-\x0bfe] + | \xd84c [\x0c00-\x0ffe] + | \xd84d [\x1000-\x13fe] + | \xd84e [\x1400-\x17fe] + | \xd84f [\x1800-\x1bfe] + | \xd850 [\x1c00-\x1ffe] + | \xd851 [\x2000-\x23fe] + | \xd852 [\x2400-\x27fe] + | \xd853 [\x2800-\x2bfe] + | \xd854 [\x2c00-\x2ffe] + | \xd855 [\x3000-\x33fe] + | \xd856 [\x3400-\x37fe] + | \xd857 [\x3800-\x3bfe] + | \xd858 [\x3c00-\x3ffe] + | \xd859 [\x4000-\x43fe] + | \xd85a [\x4400-\x47fe] + | \xd85b [\x4800-\x4bfe] + | \xd85c [\x4c00-\x4ffe] + | \xd85d [\x5000-\x53fe] + | \xd85e [\x5400-\x57fe] + | \xd85f [\x5800-\x5bfe] + | \xd860 [\x5c00-\x5ffe] + | \xd861 [\x6000-\x63fe] + | \xd862 [\x6400-\x67fe] + | \xd863 [\x6800-\x6bfe] + | \xd864 [\x6c00-\x6ffe] + | \xd865 [\x7000-\x73fe] + | \xd866 [\x7400-\x77fe] + | \xd867 [\x7800-\x7bfe] + | \xd868 [\x7c00-\x7ffe] + | \xd869 [\x8000-\x82d5] + | \xd87e [\xd400-\xd61c] + +-- XID_CONTINUE unicode character class +@xid_continue + = [\x0030-\x0039] + | [\x0041-\x005a] + | \x005f + | [\x0061-\x007a] + | \x00aa + | \x00b5 + | \x00b7 + | \x00ba + | [\x00c0-\x00d6] + | [\x00d8-\x00f6] + | [\x00f8-\x0236] + | [\x0250-\x02c1] + | [\x02c6-\x02d1] + | [\x02e0-\x02e4] + | \x02ee + | [\x0300-\x0357] + | [\x035d-\x036f] + | \x0386 + | [\x0388-\x038a] + | \x038c + | [\x038e-\x03a1] + | [\x03a3-\x03ce] + | [\x03d0-\x03f5] + | [\x03f7-\x03fb] + | [\x0400-\x0481] + | [\x0483-\x0486] + | [\x048a-\x04ce] + | [\x04d0-\x04f5] + | [\x04f8-\x04f9] + | [\x0500-\x050f] + | [\x0531-\x0556] + | \x0559 + | [\x0561-\x0587] + | [\x0591-\x05a1] + | [\x05a3-\x05b9] + | [\x05bb-\x05bd] + | \x05bf + | [\x05c1-\x05c2] + | \x05c4 + | [\x05d0-\x05ea] + | [\x05f0-\x05f2] + | [\x0610-\x0615] + | [\x0621-\x063a] + | [\x0640-\x0658] + | [\x0660-\x0669] + | [\x066e-\x06d3] + | [\x06d5-\x06dc] + | [\x06df-\x06e8] + | [\x06ea-\x06fc] + | \x06ff + | [\x0710-\x074a] + | [\x074d-\x074f] + | [\x0780-\x07b1] + | [\x0901-\x0939] + | [\x093c-\x094d] + | [\x0950-\x0954] + | [\x0958-\x0963] + | [\x0966-\x096f] + | [\x0981-\x0983] + | [\x0985-\x098c] + | [\x098f-\x0990] + | [\x0993-\x09a8] + | [\x09aa-\x09b0] + | \x09b2 + | [\x09b6-\x09b9] + | [\x09bc-\x09c4] + | [\x09c7-\x09c8] + | [\x09cb-\x09cd] + | \x09d7 + | [\x09dc-\x09dd] + | [\x09df-\x09e3] + | [\x09e6-\x09f1] + | [\x0a01-\x0a03] + | [\x0a05-\x0a0a] + | [\x0a0f-\x0a10] + | [\x0a13-\x0a28] + | [\x0a2a-\x0a30] + | [\x0a32-\x0a33] + | [\x0a35-\x0a36] + | [\x0a38-\x0a39] + | \x0a3c + | [\x0a3e-\x0a42] + | [\x0a47-\x0a48] + | [\x0a4b-\x0a4d] + | [\x0a59-\x0a5c] + | \x0a5e + | [\x0a66-\x0a74] + | [\x0a81-\x0a83] + | [\x0a85-\x0a8d] + | [\x0a8f-\x0a91] + | [\x0a93-\x0aa8] + | [\x0aaa-\x0ab0] + | [\x0ab2-\x0ab3] + | [\x0ab5-\x0ab9] + | [\x0abc-\x0ac5] + | [\x0ac7-\x0ac9] + | [\x0acb-\x0acd] + | \x0ad0 + | [\x0ae0-\x0ae3] + | [\x0ae6-\x0aef] + | [\x0b01-\x0b03] + | [\x0b05-\x0b0c] + | [\x0b0f-\x0b10] + | [\x0b13-\x0b28] + | [\x0b2a-\x0b30] + | [\x0b32-\x0b33] + | [\x0b35-\x0b39] + | [\x0b3c-\x0b43] + | [\x0b47-\x0b48] + | [\x0b4b-\x0b4d] + | [\x0b56-\x0b57] + | [\x0b5c-\x0b5d] + | [\x0b5f-\x0b61] + | [\x0b66-\x0b6f] + | \x0b71 + | [\x0b82-\x0b83] + | [\x0b85-\x0b8a] + | [\x0b8e-\x0b90] + | [\x0b92-\x0b95] + | [\x0b99-\x0b9a] + | \x0b9c + | [\x0b9e-\x0b9f] + | [\x0ba3-\x0ba4] + | [\x0ba8-\x0baa] + | [\x0bae-\x0bb5] + | [\x0bb7-\x0bb9] + | [\x0bbe-\x0bc2] + | [\x0bc6-\x0bc8] + | [\x0bca-\x0bcd] + | \x0bd7 + | [\x0be7-\x0bef] + | [\x0c01-\x0c03] + | [\x0c05-\x0c0c] + | [\x0c0e-\x0c10] + | [\x0c12-\x0c28] + | [\x0c2a-\x0c33] + | [\x0c35-\x0c39] + | [\x0c3e-\x0c44] + | [\x0c46-\x0c48] + | [\x0c4a-\x0c4d] + | [\x0c55-\x0c56] + | [\x0c60-\x0c61] + | [\x0c66-\x0c6f] + | [\x0c82-\x0c83] + | [\x0c85-\x0c8c] + | [\x0c8e-\x0c90] + | [\x0c92-\x0ca8] + | [\x0caa-\x0cb3] + | [\x0cb5-\x0cb9] + | [\x0cbc-\x0cc4] + | [\x0cc6-\x0cc8] + | [\x0cca-\x0ccd] + | [\x0cd5-\x0cd6] + | \x0cde + | [\x0ce0-\x0ce1] + | [\x0ce6-\x0cef] + | [\x0d02-\x0d03] + | [\x0d05-\x0d0c] + | [\x0d0e-\x0d10] + | [\x0d12-\x0d28] + | [\x0d2a-\x0d39] + | [\x0d3e-\x0d43] + | [\x0d46-\x0d48] + | [\x0d4a-\x0d4d] + | \x0d57 + | [\x0d60-\x0d61] + | [\x0d66-\x0d6f] + | [\x0d82-\x0d83] + | [\x0d85-\x0d96] + | [\x0d9a-\x0db1] + | [\x0db3-\x0dbb] + | \x0dbd + | [\x0dc0-\x0dc6] + | \x0dca + | [\x0dcf-\x0dd4] + | \x0dd6 + | [\x0dd8-\x0ddf] + | [\x0df2-\x0df3] + | [\x0e01-\x0e3a] + | [\x0e40-\x0e4e] + | [\x0e50-\x0e59] + | [\x0e81-\x0e82] + | \x0e84 + | [\x0e87-\x0e88] + | \x0e8a + | \x0e8d + | [\x0e94-\x0e97] + | [\x0e99-\x0e9f] + | [\x0ea1-\x0ea3] + | \x0ea5 + | \x0ea7 + | [\x0eaa-\x0eab] + | [\x0ead-\x0eb9] + | [\x0ebb-\x0ebd] + | [\x0ec0-\x0ec4] + | \x0ec6 + | [\x0ec8-\x0ecd] + | [\x0ed0-\x0ed9] + | [\x0edc-\x0edd] + | \x0f00 + | [\x0f18-\x0f19] + | [\x0f20-\x0f29] + | \x0f35 + | \x0f37 + | \x0f39 + | [\x0f3e-\x0f47] + | [\x0f49-\x0f6a] + | [\x0f71-\x0f84] + | [\x0f86-\x0f8b] + | [\x0f90-\x0f97] + | [\x0f99-\x0fbc] + | \x0fc6 + | [\x1000-\x1021] + | [\x1023-\x1027] + | [\x1029-\x102a] + | [\x102c-\x1032] + | [\x1036-\x1039] + | [\x1040-\x1049] + | [\x1050-\x1059] + | [\x10a0-\x10c5] + | [\x10d0-\x10f8] + | [\x1100-\x1159] + | [\x115f-\x11a2] + | [\x11a8-\x11f9] + | [\x1200-\x1206] + | [\x1208-\x1246] + | \x1248 + | [\x124a-\x124d] + | [\x1250-\x1256] + | \x1258 + | [\x125a-\x125d] + | [\x1260-\x1286] + | \x1288 + | [\x128a-\x128d] + | [\x1290-\x12ae] + | \x12b0 + | [\x12b2-\x12b5] + | [\x12b8-\x12be] + | \x12c0 + | [\x12c2-\x12c5] + | [\x12c8-\x12ce] + | [\x12d0-\x12d6] + | [\x12d8-\x12ee] + | [\x12f0-\x130e] + | \x1310 + | [\x1312-\x1315] + | [\x1318-\x131e] + | [\x1320-\x1346] + | [\x1348-\x135a] + | [\x1369-\x1371] + | [\x13a0-\x13f4] + | [\x1401-\x166c] + | [\x166f-\x1676] + | [\x1681-\x169a] + | [\x16a0-\x16ea] + | [\x16ee-\x16f0] + | [\x1700-\x170c] + | [\x170e-\x1714] + | [\x1720-\x1734] + | [\x1740-\x1753] + | [\x1760-\x176c] + | [\x176e-\x1770] + | [\x1772-\x1773] + | [\x1780-\x17b3] + | [\x17b6-\x17d3] + | \x17d7 + | [\x17dc-\x17dd] + | [\x17e0-\x17e9] + | [\x180b-\x180d] + | [\x1810-\x1819] + | [\x1820-\x1877] + | [\x1880-\x18a9] + | [\x1900-\x191c] + | [\x1920-\x192b] + | [\x1930-\x193b] + | [\x1946-\x196d] + | [\x1970-\x1974] + | [\x1d00-\x1d6b] + | [\x1e00-\x1e9b] + | [\x1ea0-\x1ef9] + | [\x1f00-\x1f15] + | [\x1f18-\x1f1d] + | [\x1f20-\x1f45] + | [\x1f48-\x1f4d] + | [\x1f50-\x1f57] + | \x1f59 + | \x1f5b + | \x1f5d + | [\x1f5f-\x1f7d] + | [\x1f80-\x1fb4] + | [\x1fb6-\x1fbc] + | \x1fbe + | [\x1fc2-\x1fc4] + | [\x1fc6-\x1fcc] + | [\x1fd0-\x1fd3] + | [\x1fd6-\x1fdb] + | [\x1fe0-\x1fec] + | [\x1ff2-\x1ff4] + | [\x1ff6-\x1ffc] + | [\x203f-\x2040] + | \x2054 + | \x2071 + | \x207f + | [\x20d0-\x20dc] + | \x20e1 + | [\x20e5-\x20ea] + | \x2102 + | \x2107 + | [\x210a-\x2113] + | \x2115 + | [\x2118-\x211d] + | \x2124 + | \x2126 + | \x2128 + | [\x212a-\x2131] + | [\x2133-\x2139] + | [\x213d-\x213f] + | [\x2145-\x2149] + | [\x2160-\x2183] + | [\x3005-\x3007] + | [\x3021-\x302f] + | [\x3031-\x3035] + | [\x3038-\x303c] + | [\x3041-\x3096] + | [\x3099-\x309a] + | [\x309d-\x309f] + | [\x30a1-\x30ff] + | [\x3105-\x312c] + | [\x3131-\x318e] + | [\x31a0-\x31b7] + | [\x31f0-\x31ff] + | [\x3400-\x4db5] + | [\x4e00-\x9fa5] + | [\xa000-\xa48c] + | [\xac00-\xd7a3] + | [\xf900-\xfa2d] + | [\xfa30-\xfa6a] + | [\xfb00-\xfb06] + | [\xfb13-\xfb17] + | [\xfb1d-\xfb28] + | [\xfb2a-\xfb36] + | [\xfb38-\xfb3c] + | \xfb3e + | [\xfb40-\xfb41] + | [\xfb43-\xfb44] + | [\xfb46-\xfbb1] + | [\xfbd3-\xfc5d] + | [\xfc64-\xfd3d] + | [\xfd50-\xfd8f] + | [\xfd92-\xfdc7] + | [\xfdf0-\xfdf9] + | [\xfe00-\xfe0f] + | [\xfe20-\xfe23] + | [\xfe33-\xfe34] + | [\xfe4d-\xfe4f] + | \xfe71 + | \xfe73 + | \xfe77 + | \xfe79 + | \xfe7b + | \xfe7d + | [\xfe7f-\xfefc] + | [\xff10-\xff19] + | [\xff21-\xff3a] + | \xff3f + | [\xff41-\xff5a] + | [\xff65-\xffbe] + | [\xffc2-\xffc7] + | [\xffca-\xffcf] + | [\xffd2-\xffd7] + | [\xffda-\xffdc] + | \xd800 [\xdc00-\xdc0a] + | \xd800 [\xdc0d-\xdc25] + | \xd800 [\xdc28-\xdc39] + | \xd800 [\xdc3c-\xdc3c] + | \xd800 [\xdc3f-\xdc4c] + | \xd800 [\xdc50-\xdc5c] + | \xd800 [\xdc80-\xdcf9] + | \xd800 [\xdf00-\xdf1d] + | \xd800 [\xdf30-\xdf49] + | \xd800 [\xdf80-\xdf9c] + | \xd801 [\xe000-\xe09c] + | \xd801 [\xe0a0-\xe0a8] + | \xd802 [\xe400-\xe404] + | \xd802 \x0808 + | \xd802 [\xe40a-\xe434] + | \xd802 [\xe437-\xe437] + | \xd802 \x083c + | \xd802 \x083f + | \xd834 [\xad65-\xad68] + | \xd834 [\xad6d-\xad71] + | \xd834 [\xad7b-\xad81] + | \xd834 [\xad85-\xad8a] + | \xd834 [\xadaa-\xadac] + | \xd835 [\xb000-\xb053] + | \xd835 [\xb056-\xb09b] + | \xd835 [\xb09e-\xb09e] + | \xd835 \xd4a2 + | \xd835 [\xb0a5-\xb0a5] + | \xd835 [\xb0a9-\xb0ab] + | \xd835 [\xb0ae-\xb0b8] + | \xd835 \xd4bb + | \xd835 [\xb0bd-\xb0c2] + | \xd835 [\xb0c5-\xb104] + | \xd835 [\xb107-\xb109] + | \xd835 [\xb10d-\xb113] + | \xd835 [\xb116-\xb11b] + | \xd835 [\xb11e-\xb138] + | \xd835 [\xb13b-\xb13d] + | \xd835 [\xb140-\xb143] + | \xd835 \xd546 + | \xd835 [\xb14a-\xb14f] + | \xd835 [\xb152-\xb2a2] + | \xd835 [\xb2a8-\xb2bf] + | \xd835 [\xb2c2-\xb2d9] + | \xd835 [\xb2dc-\xb2f9] + | \xd835 [\xb2fc-\xb313] + | \xd835 [\xb316-\xb333] + | \xd835 [\xb336-\xb34d] + | \xd835 [\xb350-\xb36d] + | \xd835 [\xb370-\xb387] + | \xd835 [\xb38a-\xb3a7] + | \xd835 [\xb3aa-\xb3c1] + | \xd835 [\xb3c4-\xb3c8] + | \xd835 [\xb3ce-\xb3fe] + | \xd840 [\xdc00-\xdffe] + | \xd841 [\xe000-\xe3fe] + | \xd842 [\xe400-\xe7fe] + | \xd843 [\xe800-\xebfe] + | \xd844 [\xec00-\xeffe] + | \xd845 [\xf000-\xf3fe] + | \xd846 [\xf400-\xf7fe] + | \xd847 [\xf800-\xfbfe] + | \xd848 [\xfc00-\xfffe] + | \xd849 [\x0000-\x03fe] + | \xd84a [\x0400-\x07fe] + | \xd84b [\x0800-\x0bfe] + | \xd84c [\x0c00-\x0ffe] + | \xd84d [\x1000-\x13fe] + | \xd84e [\x1400-\x17fe] + | \xd84f [\x1800-\x1bfe] + | \xd850 [\x1c00-\x1ffe] + | \xd851 [\x2000-\x23fe] + | \xd852 [\x2400-\x27fe] + | \xd853 [\x2800-\x2bfe] + | \xd854 [\x2c00-\x2ffe] + | \xd855 [\x3000-\x33fe] + | \xd856 [\x3400-\x37fe] + | \xd857 [\x3800-\x3bfe] + | \xd858 [\x3c00-\x3ffe] + | \xd859 [\x4000-\x43fe] + | \xd85a [\x4400-\x47fe] + | \xd85b [\x4800-\x4bfe] + | \xd85c [\x4c00-\x4ffe] + | \xd85d [\x5000-\x53fe] + | \xd85e [\x5400-\x57fe] + | \xd85f [\x5800-\x5bfe] + | \xd860 [\x5c00-\x5ffe] + | \xd861 [\x6000-\x63fe] + | \xd862 [\x6400-\x67fe] + | \xd863 [\x6800-\x6bfe] + | \xd864 [\x6c00-\x6ffe] + | \xd865 [\x7000-\x73fe] + | \xd866 [\x7400-\x77fe] + | \xd867 [\x7800-\x7bfe] + | \xd868 [\x7c00-\x7ffe] + | \xd869 [\x8000-\x82d5] + | \xd87e [\xd400-\xd61c] + | \xdb40 [\xdd00-\xddee] + +@embedded_exp_open = "${e|" +@embedded_ident_open = "${i|" + +@ident = @xid_start @xid_continue* +@raw_ident = r \# @ident + +@lifetime = \' @ident + +$hexit = [0-9a-fA-F] + +@char_escape + = [nrt\\'"0] + | [xX] [0-7] $hexit + | u\{ $hexit \} + | u\{ $hexit $hexit \} + | u\{ $hexit $hexit $hexit \} + | u\{ $hexit $hexit $hexit $hexit \} + | u\{ $hexit $hexit $hexit $hexit $hexit \} + | u\{ $hexit $hexit $hexit $hexit $hexit $hexit \} + +@byte_escape + = [xX] $hexit $hexit + | [nrt\\'"0] + +-- literals + +@lit_char + = \' ( \\ @char_escape + | [^\\'\n\t\r] + | [ \ud800-\udbff \udc00-\udfff ] + ) + \' + +@lit_byte + = b\' ( \\ @byte_escape + | [^\\'\n\t\r] [ \udc00-\udfff ]? + ) + \' + +@lit_integer + = [0-9][0-9_]* + | 0b [01_]+ + | 0o [0-8_]+ + | 0x [0-9a-fA-F_]+ + +@decimal_suffix = \. [0-9][0-9_]* +@exponent_suffix = [eE] [\-\+]? [0-9][0-9_]* + +@lit_float = [0-9][0-9_]* @decimal_suffix? @exponent_suffix? +@lit_float2 = [0-9][0-9_]* \. + +@lit_str = \" (\\\n | \\\r\n | \\ @char_escape | [^\\\"] | \n | \r)* \" +@lit_byte_str = b \" (\\\n | \\\r\n | \\ @byte_escape | [^\\\"] | \n | \r)* \" + +@lit_raw_str = r \#* \" +@lit_raw_bstr = br \#* \" + + +-- Comments + +@outer_doc_line = "///" ( [^\r\n\/] [^\r\n]* )? +@outer_doc_inline = "/**" + +@inner_doc_line = "//!" [^\r\n]* +@inner_doc_inline = "/*!" + +@line_comment = "//" ( [^\n\/]* [^\n]* )? +@inline_comment = "/*" + +-- Macro related + +@subst_nt = "$" @ident + +tokens :- + +$white+ { \s -> pure (Space Whitespace s) } + +"=" { token Equal } +"<" { token Less } +">" { token Greater } +"&" { token Ampersand } +"|" { token Pipe } +"!" { token Exclamation } +"~" { token Tilde } +"+" { token Plus } +"-" { token Minus } +"*" { token Star } +"/" { token Slash } +"%" { token Percent } +"^" { token Caret } + +"||" { token PipePipe } +"&&" { token AmpersandAmpersand } +">=" { token GreaterEqual } +">>=" { token GreaterGreaterEqual } +"<<" { token LessLess } +">>" { token GreaterGreater } + +"==" { token EqualEqual } +"!=" { token NotEqual } +"<=" { token LessEqual } +"<<=" { token LessLessEqual } +"-=" { token MinusEqual } +"&=" { token AmpersandEqual } +"|=" { token PipeEqual } +"+=" { token PlusEqual } +"*=" { token StarEqual } +"/=" { token SlashEqual } +"^=" { token CaretEqual } +"%=" { token PercentEqual } + +@embedded_exp_open { \_ -> mkEmbedExp } -- (EmbeddedCode $ (drop 4 . init . init) s) } +@embedded_ident_open { \_ -> mkEmbedIdent } -- (EmbeddedIdent $ (drop 4 . init . init) s) } +@subst_nt { \s -> pure $ EmbeddedIdent $ tail s } + +"@" { token At } +"." { token Dot } +".." { token DotDot } +"..." { token DotDotDot } +"..=" { token DotDotEqual } +"," { token Comma } +";" { token Semicolon } +":" { token Colon } +"::" { token ModSep } +"->" { token RArrow } +"<-" { token LArrow } +"=>" { token FatArrow } +"(" { token (OpenDelim Paren) } +")" { token (CloseDelim Paren) } +"[" { token (OpenDelim Bracket) } +"]" { token (CloseDelim Bracket) } +"{" { token (OpenDelim Brace) } +"}" { token (CloseDelim Brace) } +"#" { token Pound } +"$" { token Dollar } + +@lit_integer { \i -> literal (IntegerTok i) } +@lit_float { \f -> literal (FloatTok f) } +@lit_float2 / ( [^\._a-zA-Z] | \r | \n ) + { \f -> literal (FloatTok f) } +@lit_float2 / { \_ _ _ (_,is) -> inputStreamEmpty is } + { \f -> literal (FloatTok f) } + +@lit_byte { \c -> literal (ByteTok (drop 2 (init c))) } +@lit_char { \c -> literal (CharTok (drop 1 (init c))) } +@lit_str { \s -> literal (StrTok (cleanWindowsNewlines (drop 1 (init s)))) } +@lit_byte_str { \s -> literal (ByteStrTok (cleanWindowsNewlines (drop 2 (init s)))) } + +@lit_raw_str { \s -> let n = length s - 2 + in do + str <- cleanWindowsNewlines `fmap` rawString n + literal (StrRawTok str (fromIntegral n)) + } +@lit_raw_bstr { \s -> let n = length s - 3 + in do + str <- cleanWindowsNewlines `fmap` rawString n + literal (ByteStrRawTok str (fromIntegral n)) + } + + "" ; + @ident { \s -> pure (IdentTok (mkIdent s)) } + +\? { token Question } +@raw_ident { \s -> pure (IdentTok ((mkIdent (drop 2 s)){ raw = True })) } +@ident { \s -> pure (IdentTok (mkIdent s)) } +@lifetime { \s -> (pure (LifetimeTok (mkIdent (tail s))) :: P Token) } + + +@outer_doc_line { \c -> pure (Doc (drop 3 c) Outer False) } +@outer_doc_line \r { \c -> pure (Doc (drop 3 (init c)) Outer False) } +@outer_doc_inline / ( [^\*] | \r | \n ) + { \_ -> Doc <$> nestedComment <*> pure Outer <*> pure True } + +@inner_doc_line { \c -> pure (Doc (drop 3 c) Inner False) } +@inner_doc_inline { \_ -> Doc <$> nestedComment <*> pure Inner <*> pure True } + +@line_comment { \c -> pure (Space Comment (drop 2 c)) } +@inline_comment { \_ -> Space Comment <$> nestedComment } + +{ + +nextEmbedChar :: P Char +nextEmbedChar = do + c <- nextChar + case c of + Nothing -> fail "Unclosed embedded expression." + Just c' -> pure c' + +mkEmbedIt :: P String +mkEmbedIt = do + c0 <- nextEmbedChar + (case c0 of + '|' -> do + c1 <- nextEmbedChar + (case c1 of + '}' -> pure "" + _ -> ([c0,c1] ++) <$> mkEmbedIt) + _ -> (c0 :) <$> mkEmbedIt) + +mkEmbedExp :: P Token +mkEmbedExp = EmbeddedCode <$> mkEmbedIt -- EmbeddedCode $ (drop 4 . init . init) s) + +mkEmbedIdent :: P Token +mkEmbedIdent = EmbeddedIdent <$> mkEmbedIt -- (EmbeddedIdent $ (drop 4 . init . init) s) + +-- | Make a token. +token :: Token -> String -> P Token +token t _ = pure t + +-- | Given the first part of a literal, try to parse also a suffix. Even if +-- the allowed suffixes are very well defined and only valid on integer and +-- float literals, we need to put in the same token whatever suffix follows. +-- This is for backwards compatibility if Rust decides to ever add suffixes. +literal :: LitTok -> P Token +literal lit = do + pos <- getPosition + inp <- getInput + case alexScan (pos,inp) lits of + AlexToken (pos',inp') len action -> do + tok <- action (peekChars len inp) + case tok of + IdentTok (Ident (Name suf) False _) -> do + setPosition pos' + setInput inp' + pure (LiteralTok lit (Just suf)) + _ -> pure (LiteralTok lit Nothing) + _ -> pure (LiteralTok lit Nothing) + +-- | Parses a raw string, the closing quotation, and the appropriate number of +-- '#' characters. +rawString :: Int -> P String +rawString n = do + c_m <- nextChar + case c_m of + -- The string was never closed + Nothing -> fail "Invalid raw (byte)string" + + -- The string has a chance of being closed + Just '"' -> do + n' <- greedyChar '#' n + if n' == n + then pure "" + else (('"' : replicate n' '#') ++) <$> rawString n + + -- Just another character... + Just c -> ([c] ++) <$> rawString n + +-- | Consume a full inline comment (which may be nested). +nestedComment :: P String +nestedComment = go 1 "" + where + go :: Int -> String -> P String + go 0 s = pure (reverse (drop 2 s)) + go n s = do + c <- nextChar + case c of + Nothing -> fail "Unclosed comment" + Just '*' -> do + c' <- peekChar + case c' of + Nothing -> fail "Unclosed comment" + Just '/' -> nextChar *> go (n-1) ('/':'*':s) + Just _ -> go n ('*':s) + Just '/' -> do + c' <- peekChar + case c' of + Nothing -> fail "Unclosed comment" + Just '*' -> nextChar *> go (n+1) ('*':'/':s) + Just _ -> go n ('/':s) + Just c' -> go n (c':s) + + +-- Monadic functions + +-- | Retrieve the next character (if there is one), updating the parser state accordingly. +nextChar :: P (Maybe Char) +nextChar = do + pos <- getPosition + inp <- getInput + if inputStreamEmpty inp + then pure Nothing + else let (c,inp') = takeChar inp + pos' = alexMove pos c + in pos' `seq` (setPosition pos' *> setInput inp' *> pure (Just c)) + +-- | Retrieve the next character (if there is one), without updating the +-- parser state. +peekChar :: P (Maybe Char) +peekChar = do + inp <- getInput + if inputStreamEmpty inp + then pure Nothing + else let (c,_) = takeChar inp + in pure (Just c) + +-- | Greedily try to eat as many of a given character as possible (and return +-- how many characters were eaten). The second argument is an upper limit. +greedyChar :: Char -> Int -> P Int +greedyChar _ 0 = pure 0 +greedyChar c limit = do + c_m <- peekChar + case c_m of + Just c' | c == c' -> do { _ <- nextChar; n <- greedyChar c (limit - 1); pure (n+1) } + _ -> pure 0 + +-- | Signal a lexical error. +lexicalError :: P a +lexicalError = do + c <- peekChar + fail ("Lexical error: the character " ++ show c ++ " does not fit here") + + +-- Functions required by Alex + +-- | type passed around by Alex functions (required by Alex) +type AlexInput = (Position, -- current position, + InputStream) -- current input string + +-- | get previous character (required by Alex). Since this is never used, the +-- implementation just raises an error. +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar _ = error "alexInputPrevChar not used" + +-- | get the next byte and new input from the current input (required by Alex +-- 3.0) +alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) +alexGetByte (pos,inp) + | inputStreamEmpty inp = Nothing + | otherwise = let (b,inp') = takeByte inp + -- this is safe for latin-1, but ugly + pos' = alexMove pos (chr (fromIntegral b)) + in pos' `seq` Just (b, (pos', inp')) + +-- | find the new position given the next character +alexMove :: Position -> Char -> Position +alexMove pos ' ' = incPos pos 1 +alexMove pos '\n' = retPos pos +alexMove pos '\r' = incOffset pos 1 +alexMove pos _ = incPos pos 1 + +-- | Lexer for one 'Token'. The only token this cannot produce is 'Interpolated'. +lexToken :: P (Spanned Token) +lexToken = do + tok_maybe <- popToken + case tok_maybe of + Just tok -> pure tok + Nothing -> do + pos <- getPosition + inp <- getInput + case alexScan (pos, inp) 0 of + AlexEOF -> pure (Spanned Eof (Span pos pos)) + AlexError _ -> fail "lexical error" + AlexSkip (pos',inp') _ -> setPosition pos' *> setInput inp' *> lexToken + AlexToken (pos',inp') len action -> do + setPosition pos' + setInput inp' + tok <- action (peekChars len inp) + tok' <- swapToken tok + pos'' <- getPosition + return (Spanned tok' (Span pos pos'')) + +-- | Lexer for one non-whitespace 'Token'. The only tokens this cannot produce are 'Interpolated' +-- and 'Space' (which includes comments that aren't doc comments). +lexNonSpace :: P (Spanned Token) +lexNonSpace = do + tok <- lexToken + case tok of + Spanned Space{} _ -> lexNonSpace + _ -> pure tok + +-- | Apply the given lexer repeatedly until (but not including) the 'Eof' token. Meant for debugging +-- purposes - in general this defeats the point of a threaded lexer. +lexTokens :: P (Spanned Token) -> P [Spanned Token] +lexTokens lexer = do + tok <- lexer + case tok of + Spanned Eof _ -> pure [] + _ -> (tok :) <$> lexTokens lexer + +-- | Lex the first line, if it immediately starts with @#!@ (but not @#![@ - that should be an +-- inner attribute). If this fails to find a shebang line, it consumes no input. +lexShebangLine :: P (Maybe String) +lexShebangLine = do + inp <- getInput + case peekChars 3 inp of + '#':'!':r | r /= "[" -> Just <$> toNewline + _ -> pure Nothing + where + -- Lexes a string until a newline + toNewline :: P String + toNewline = do + c <- peekChar + case c of + Nothing -> pure "" + Just '\n' -> pure "" + Just c' -> do + _ <- nextChar + (c' :) <$> toNewline + +-- | If we're running on Windows, we need to normalize to "\n" instead of "\r\n", to match Rust's +-- handling of newlines in strings. +cleanWindowsNewlines :: String -> String +cleanWindowsNewlines "" = "" +cleanWindowsNewlines ('\r':'\n':rest) = '\n' : cleanWindowsNewlines rest +cleanWindowsNewlines (x:rest) = x : cleanWindowsNewlines rest +} diff --git a/src/Language/Rust/Parser/Literals.hs b/src/Language/Rust/Parser/Literals.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Parser/Literals.hs @@ -0,0 +1,130 @@ +{-| +Module : Language.Rust.Parser.Literals +Description : Parsing literals +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : portable + +Functions for parsing literals from valid literal tokens. Note the functions in this module fail +badly is fed invalid 'LitTok's; it is expected their input is coming from Alex and is correct. +-} + +module Language.Rust.Parser.Literals ( + translateLit +) where + +import Language.Rust.Syntax.Token ( LitTok(..) ) +import Language.Rust.Syntax.AST ( IntRep(..), Lit(..), StrStyle(..), Suffix(..) ) + +import Data.Char ( chr, digitToInt, ord, isHexDigit, isSpace ) +import Data.List ( unfoldr ) +import Data.Maybe ( fromMaybe ) +import Data.Word ( Word8 ) + +import Text.Read ( readMaybe ) + +-- | Parse a valid 'LitTok' into a 'Lit'. +translateLit :: LitTok -> Suffix -> a -> Lit a +translateLit (ByteTok s) = Byte (unescapeByte' s) +translateLit (CharTok s) = Char (unescapeChar' s) +translateLit (FloatTok s) = Float (unescapeFloat s) +translateLit (StrTok s) = Str (unfoldr (unescapeChar True) s) Cooked +translateLit (StrRawTok s n) = Str s (Raw n) +translateLit (ByteStrTok s) = ByteStr (unfoldr (unescapeByte True) s) Cooked +translateLit (ByteStrRawTok s n) = ByteStr (map (fromIntegral . ord) s) (Raw n) +translateLit (IntegerTok s) = \suf -> case (suf, unescapeInteger s) of + (F32, (Dec, n)) -> Float (fromInteger n) F32 + (F64, (Dec, n)) -> Float (fromInteger n) F64 + (_, (rep, n)) -> Int rep n s suf + +-- | Given a string of characters read from a Rust source, extract the next underlying char taking +-- into account escapes and unicode. +unescapeChar :: Bool -- ^ multi-line strings allowed + -> String -- ^ input string + -> Maybe (Char, String) +unescapeChar multiline ('\\':c:cs) = case c of + 'n' -> pure ('\n', cs) + 'r' -> pure ('\r', cs) + 't' -> pure ('\t', cs) + '\\' -> pure ('\\', cs) + '\'' -> pure ('\'', cs) + '"' -> pure ('"', cs) + '0' -> pure ('\0', cs) + 'x' -> do (h,cs') <- readHex 2 cs; pure (chr h, cs') + 'X' -> do (h,cs') <- readHex 2 cs; pure (chr h, cs') + 'U' -> do (h,cs') <- readHex 8 cs; pure (chr h, cs') + 'u' -> case cs of + '{':x1:'}':cs' -> do (h,_) <- readHex 1 [x1]; pure (chr h, cs') + '{':x1:x2:'}':cs' -> do (h,_) <- readHex 2 [x1,x2]; pure (chr h, cs') + '{':x1:x2:x3:'}':cs' -> do (h,_) <- readHex 3 [x1,x2,x3]; pure (chr h, cs') + '{':x1:x2:x3:x4:'}':cs' -> do (h,_) <- readHex 4 [x1,x2,x3,x4]; pure (chr h, cs') + '{':x1:x2:x3:x4:x5:'}':cs' -> do (h,_) <- readHex 5 [x1,x2,x3,x4,x5]; pure (chr h, cs') + '{':x1:x2:x3:x4:x5:x6:'}':cs' -> do (h,_) <- readHex 6 [x1,x2,x3,x4,x5,x6]; pure (chr h, cs') + _ -> do (h,cs') <- readHex 4 cs; pure (chr h, cs') + '\n' | multiline -> unescapeChar multiline $ dropWhile isSpace cs + _ -> error "unescape char: bad escape sequence" +unescapeChar _ (c:cs) = Just (c, cs) +unescapeChar _ [] = fail "unescape char: empty string" + +-- | Given a string of characters read from a Rust source, extract the next underlying byte taking +-- into account escapes. +unescapeByte :: Bool -- ^ multi-line strings allowed + -> String -- ^ input string + -> Maybe (Word8, String) +unescapeByte multiline ('\\':c:cs) = case c of + 'n' -> pure (toEnum $ fromEnum '\n', cs) + 'r' -> pure (toEnum $ fromEnum '\r', cs) + 't' -> pure (toEnum $ fromEnum '\t', cs) + '\\' -> pure (toEnum $ fromEnum '\\', cs) + '\'' -> pure (toEnum $ fromEnum '\'', cs) + '"' -> pure (toEnum $ fromEnum '"', cs) + '0' -> pure (toEnum $ fromEnum '\0', cs) + 'x' -> do (h,cs') <- readHex 2 cs; pure (h, cs') + 'X' -> do (h,cs') <- readHex 2 cs; pure (h, cs') + '\n' | multiline -> unescapeByte multiline $ dropWhile isSpace cs + _ -> error "unescape byte: bad escape sequence" +unescapeByte _ (c:cs) = Just (toEnum $ fromEnum c, cs) +unescapeByte _ [] = fail "unescape byte: empty string" + +-- | Given a string Rust representation of a character, parse it into a character +unescapeChar' :: String -> Char +unescapeChar' s = case unescapeChar False s of + Just (c, "") -> c + _ -> error "unescape char: bad character literal" + +-- | Given a string Rust representation of a byte, parse it into a byte +unescapeByte' :: String -> Word8 +unescapeByte' s = case unescapeByte False s of + Just (w8, "") -> w8 + _ -> error "unescape byte: bad byte literal" + +-- | Given a string Rust representation of an integer, parse it into a number +unescapeInteger :: Num a => String -> (IntRep,a) +unescapeInteger ('0':'b':cs@(_:_)) | all (`elem` "_01") cs = (Bin, numBase 2 (filter (/= '_') cs)) +unescapeInteger ('0':'o':cs@(_:_)) | all (`elem` "_01234567") cs = (Oct, numBase 8 (filter (/= '_') cs)) +unescapeInteger ('0':'x':cs@(_:_)) | all (`elem` "_0123456789abcdefABCDEF") cs = (Hex, numBase 16 (filter (/= '_') cs)) +unescapeInteger cs@(_:_) | all (`elem` "_0123456789") cs = (Dec, numBase 10 (filter (/= '_') cs)) +unescapeInteger _ = error "unescape integer: bad decimal literal" + +-- | Given a string Rust representation of a float, parse it into a float. +-- NOTE: this is a bit hacky. Eventually, we might not do this and change the internal +-- representation of a float to a string (what language-c has opted to do). +unescapeFloat :: String -> Double +unescapeFloat cs = fromMaybe (error $ "unescape float: cannot parse float " ++ cs') (readMaybe cs') + where cs' = filter (/= '_') (if last cs == '.' then cs ++ "0" else cs) + +-- | Try to read a hexadecimal number of the specified length off of the front of the string +-- provided. If there are not enough characters to do this, or the characters don't fall in the +-- right range, this fails with 'Nothing'. +readHex :: Num a => Int -> String -> Maybe (a, String) +readHex n cs = let digits = take n cs + in if length digits == n && all isHexDigit digits + then Just (numBase 16 digits, drop n cs) + else Nothing + +-- | Convert a list of characters to the number they represent. +numBase :: Num a => a -> String -> a +numBase b = foldl (\n x -> fromIntegral (digitToInt x) + b * n) 0 + diff --git a/src/Language/Rust/Parser/NonEmpty.hs b/src/Language/Rust/Parser/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Parser/NonEmpty.hs @@ -0,0 +1,80 @@ +{-| +Module : Language.Rust.Parser.NonEmpty +Description : Non-empty lists +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : GHC + +Datatype wrapping non-empty lists. +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +#if __GLASGOW_HASKELL__ < 800 +{-# LANGUAGE FlexibleContexts #-} +#endif +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell, DeriveFoldable, DeriveFunctor, GeneralizedNewtypeDeriving, DeriveTraversable #-} + +module Language.Rust.Parser.NonEmpty ( + NonEmpty(..), + listCons, + head, tail, + reverse, last, init, (<|), (|:), (|>) +) where +import Prelude hiding (head, tail, reverse, init, last) + +import qualified Data.List.NonEmpty as N +import Data.Data ( Data(..) ) +import Control.DeepSeq ( NFData ) +import Data.Semigroup (Semigroup(..)) + +-- Support for OverloadedLists of NonEmpty lists: +import GHC.Exts (IsList(..)) + +newtype NonEmpty a = NonEmpty (N.NonEmpty a) + deriving (Foldable, Eq, Ord, Show, Functor, Data, NFData, Traversable) + +instance IsList (NonEmpty a) where + type Item (NonEmpty a) = a + + fromList (a:as) = NonEmpty $ a N.:| as + fromList [] = errorWithoutStackTrace "NonEmpty.fromList: empty list" + + toList ~(NonEmpty (a N.:| as)) = a : as + +instance Semigroup (NonEmpty a) where + (NonEmpty (a N.:| as)) <> ~(NonEmpty (b N.:| bs)) = NonEmpty $ a N.:| (as ++ b : bs) + +listCons :: a -> [a] -> NonEmpty a +listCons a as = NonEmpty $ a N.:| as + +head :: NonEmpty a -> a +head (NonEmpty as) = N.head as + +tail :: NonEmpty a -> [a] +tail (NonEmpty as) = N.tail as + +reverse :: NonEmpty a -> NonEmpty a +reverse (NonEmpty as) = NonEmpty $ N.reverse as + +init :: NonEmpty a -> [a] +init (NonEmpty as) = N.init as + +last :: NonEmpty a -> a +last (NonEmpty as) = N.last as + +(<|) :: a -> NonEmpty a -> NonEmpty a +(<|) a (NonEmpty as) = NonEmpty $ a N.<| as + +(|:) :: [a] -> a -> NonEmpty a +[] |: y = NonEmpty $ y N.:| [] +(x:xs) |: y = NonEmpty $ x N.:| (xs ++ [y]) + +(|>) :: NonEmpty a -> a -> NonEmpty a +(|>) (NonEmpty (x N.:| xs)) y = NonEmpty $ x N.:| (xs ++ [y]) + diff --git a/src/Language/Rust/Parser/ParseMonad.hs b/src/Language/Rust/Parser/ParseMonad.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Parser/ParseMonad.hs @@ -0,0 +1,170 @@ +{-| +Module : Language.Rust.Parser.ParseMonad +Description : Parsing monad for lexer/parser +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : GHC + +Both the lexer and the parser run inside of the 'P' monad. As detailed in the section on +on [threaded-lexers](https://www.haskell.org/happy/doc/html/sec-monads.html#sec-lexers) in Happy's +instruction manual, the benefits of this are that: + + * Lexical errors can be treated in the same way as parse errors + * Information such as the current position in the file shared between the lexer and parser + * General information can be passed back from the parser to the lexer too + +In our case, this shared information is held in 'PState'. +-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Language.Rust.Parser.ParseMonad ( + -- * Parsing monad + P, + execParser, + execParser', + initPos, + PState(..), + + -- * Monadic operations + getPState, + setPState, + getPosition, + setPosition, + getInput, + setInput, + popToken, + pushToken, + swapToken, + + -- * Error reporting + ParseFail(..), + parseError, +) where + +import Language.Rust.Data.InputStream ( InputStream ) +import Language.Rust.Data.Position ( Spanned, Position, initPos, prettyPosition ) +import Language.Rust.Syntax.Token ( Token ) + +import Control.Monad.Fail as Fail +import Control.Exception ( Exception ) +import Data.Maybe ( listToMaybe ) +import Data.Typeable ( Typeable ) + +-- | Parsing and lexing monad. A value of type @'P' a@ represents a parser that can be run (using +-- 'execParser') to possibly produce a value of type @a@. +newtype P a = P { unParser :: forall r. PState -- State being passed along + -> (a -> PState -> r) -- Successful parse continuation + -> (String -> Position -> r) -- Failed parse continuation + -> r -- Final output + } + +-- | State that the lexer and parser share +data PState = PState + { curPos :: !Position -- ^ position at current input location + , curInput :: !InputStream -- ^ the current input + , prevPos :: Position -- ^ position at previous input location + , pushedTokens :: [Spanned Token] -- ^ tokens manually pushed by the user + , swapFunction :: Token -> Token -- ^ function to swap token + } + +instance Functor P where + fmap f m = P $ \ !s pOk pFailed -> unParser m s (pOk . f) pFailed + +instance Applicative P where + pure x = P $ \ !s pOk _ -> pOk x s + + m <*> k = P $ \ !s pOk pFailed -> + let pOk' x s' = unParser k s' (pOk . x) pFailed + in unParser m s pOk' pFailed + +instance Monad P where + return = pure + + m >>= k = P $ \ !s pOk pFailed -> + let pOk' x s' = unParser (k x) s' pOk pFailed + in unParser m s pOk' pFailed + +instance Fail.MonadFail P where + fail msg = P $ \ !s _ pFailed -> pFailed msg (curPos s) + +-- | Exceptions that occur during parsing +data ParseFail = ParseFail Position String deriving (Eq, Typeable) + +instance Show ParseFail where + showsPrec p (ParseFail pos msg) = showParen (p >= 11) (showString err) + where err = unwords [ "parse failure at", prettyPosition pos, "(" ++ msg ++ ")" ] + +instance Exception ParseFail + +-- | Execute the given parser on the supplied input stream at the given start position, returning +-- either the position of an error and the error message, or the value parsed. +execParser :: P a -> InputStream -> Position -> Either ParseFail a +execParser p input pos = execParser' p input pos id + +-- | Generalized version of 'execParser' that expects an extra argument that lets you hot-swap a +-- token that was just lexed before it gets passed to the parser. +execParser' :: P a -> InputStream -> Position -> (Token -> Token) -> Either ParseFail a +execParser' parser input pos swap = unParser parser + initialState + (\result _ -> Right result) + (\message errPos -> Left (ParseFail errPos message)) + where initialState = PState + { curPos = pos + , curInput = input + , prevPos = error "ParseMonad.execParser: Touched undefined position!" + , pushedTokens = [] + , swapFunction = swap + } + +-- | Swap a token using the swap function. +swapToken :: Token -> P Token +swapToken t = P $ \ !s@PState{ swapFunction = f } pOk _ -> pOk (f $! t) s + +-- | Extract the state stored in the parser. +getPState :: P PState +getPState = P $ \ !s pOk _ -> pOk s s + +-- | Update the state stored in the parser. +setPState :: PState -> P () +setPState s = P $ \ _ pOk _ -> pOk () s + +-- | Modify the state stored in the parser. +modifyPState :: (PState -> PState) -> P () +modifyPState f = P $ \ !s pOk _ -> pOk () (f $! s) + +-- | Retrieve the current position of the parser. +getPosition :: P Position +getPosition = curPos <$> getPState + +-- | Update the current position of the parser. +setPosition :: Position -> P () +setPosition pos = modifyPState $ \ s -> s{ curPos = pos } + +-- | Retrieve the current 'InputStream' of the parser. +getInput :: P InputStream +getInput = curInput <$> getPState + +-- | Update the current 'InputStream' of the parser. +setInput :: InputStream -> P () +setInput i = modifyPState $ \s -> s{ curInput = i } + +-- | Manually push a @'Spanned' 'Token'@. This turns out to be useful when parsing tokens that need +-- to be broken up. For example, when seeing a 'Language.Rust.Syntax.GreaterEqual' token but only +-- expecting a 'Language.Rust.Syntax.Greater' token, one can consume the +-- 'Language.Rust.Syntax.GreaterEqual' token and push back an 'Language.Rust.Syntax.Equal' token. +pushToken :: Spanned Token -> P () +pushToken tok = modifyPState $ \s@PState{ pushedTokens = toks } -> s{ pushedTokens = tok : toks } + +-- | Manually pop a @'Spanned' 'Token'@ (if there are no tokens to pop, returns 'Nothing'). See +-- 'pushToken' for more details. +popToken :: P (Maybe (Spanned Token)) +popToken = P $ \ !s@PState{ pushedTokens = toks } pOk _ -> pOk (listToMaybe toks) s{ pushedTokens = drop 1 toks } + +-- | Signal a syntax error. +parseError :: Show b => b -> P a +parseError b = Fail.fail ("Syntax error: the symbol `" ++ show b ++ "' does not fit here") + diff --git a/src/Language/Rust/Parser/Reversed.hs b/src/Language/Rust/Parser/Reversed.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Parser/Reversed.hs @@ -0,0 +1,86 @@ +{-| +Module : Language.Rust.Parser.Reversed +Description : Parsing literals +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : GHC + +Datatypes wrapping lists and non-empty lists designed for fast append (as opposed to prepend) +along with the usual class instances. +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +#if __GLASGOW_HASKELL__ < 800 +{-# LANGUAGE FlexibleContexts #-} +#endif +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Language.Rust.Parser.Reversed ( + Reversed(..), + toNonEmpty, + unsnoc, + snoc, + NonEmpty(..), +) where + +import Language.Rust.Data.Position + +import Data.Foldable ( Foldable(toList) ) +import Data.Semigroup as Sem ( Semigroup(..) ) + +import qualified Language.Rust.Parser.NonEmpty as N +import Language.Rust.Parser.NonEmpty (NonEmpty(..), listCons) +import qualified GHC.Exts as G + +import Data.Data (Data(..), Typeable) + +-- | Wrap a data type where all the operations are reversed +newtype Reversed f a = Reversed (f a) + +instance Functor f => Functor (Reversed f) where + fmap f (Reversed xs) = Reversed (fmap f xs) + +instance Foldable (Reversed []) where + foldMap f (Reversed xs) = foldMap f (reverse xs) + toList (Reversed xs) = reverse xs + +instance Foldable (Reversed NonEmpty) where + foldMap f (Reversed xs) = foldMap f (N.reverse xs) + toList (Reversed xs) = reverse (toList xs) + +instance Sem.Semigroup (f a) => Sem.Semigroup (Reversed f a) where + Reversed xs <> Reversed ys = Reversed (ys Sem.<> xs) + +instance Monoid (f a) => Monoid (Reversed f a) where + mempty = Reversed mempty + mappend (Reversed xs) (Reversed ys) = Reversed (mappend ys xs) + +instance G.IsList (f a) => G.IsList (Reversed f a) where + type Item (Reversed f a) = G.Item (f a) + fromList xs = Reversed (G.fromList (reverse xs)) + toList (Reversed xs) = reverse (G.toList xs) + +instance Located (f a) => Located (Reversed f a) where + spanOf (Reversed xs) = spanOf xs + +deriving instance (Typeable f, Typeable a, Data (f a)) => Data (Reversed f a) + +-- | Convert a reversed 'NonEmpty' back into a normal one. +{-# INLINE toNonEmpty #-} +toNonEmpty :: Reversed NonEmpty a -> NonEmpty a +toNonEmpty (Reversed xs) = N.reverse xs + +-- | Remove an element from the end of a non-empty reversed sequence +{-# INLINE unsnoc #-} +unsnoc :: Reversed NonEmpty a -> (Reversed [] a, a) +unsnoc (Reversed xs) = (Reversed $ N.tail xs, N.head xs) + +-- | Add an element to the end of a reversed sequence to produce a non-empty +-- reversed sequence +{-# INLINE snoc #-} +snoc :: Reversed [] a -> a -> Reversed NonEmpty a +snoc (Reversed xs) x = Reversed (x `listCons` xs) diff --git a/src/Language/Rust/Pretty.hs b/src/Language/Rust/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Pretty.hs @@ -0,0 +1,238 @@ +{-| +Module : Language.Rust.Pretty +Description : Pretty printing +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : portable + +This module provides functions for turning ASTs into values of type 'Doc'. These values can then be +rendered into concrete string types using functions from the @prettyprinter@ package. This has some +advantages over printing plain old strings: + + * /Backend independent/: you can use a variety of existing backends to efficiently render to all + sorts of formats like 'Data.Text.Text', 'String', HTML, and terminal. + + * /Dynamic layouts/: the AST will render differently depending on the desired page width + + >>> :set -XTypeApplications -XOverloadedStrings + >>> import Language.Rust.Parser + >>> import Data.Text.Prettyprint.Doc.Util ( putDocW ) + >>> let src = parse' @(SourceFile Span) "fn foo(x: i32, y: i32, z: i32) -> i32 { x - y + z }" + >>> let doc = pretty' src <> "\n" + >>> putDocW 80 doc + fn foo(x: i32, y: i32, z: i32) -> i32 { + x - y + z + } + >>> putDocW 10 doc + fn foo( + x: i32, + y: i32, + z: i32, + ) -> i32 { + x - y + z + } + + * /Annotations/: Depending on the backend you are using to render the 'Doc', annotations can + determine colours, styling, links, etc. + +The examples below assume the following GHCi flag and import: + +>>> :set -XOverloadedStrings +>>> import Language.Rust.Syntax.AST + +-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} + +module Language.Rust.Pretty ( + -- * Printing + pretty, + pretty', + prettyAnnotated, + prettyAnnotated', + writeSourceFile, + writeTokens, + Pretty(..), + PrettyAnnotated(..), + Doc, + + -- * Resolving + Resolve(..), + + -- * Error reporting + ResolveFail(..), + Issue(..), + Severity(..), +) where + +import Language.Rust.Data.Ident +import Language.Rust.Data.Position + +import Language.Rust.Syntax.AST +import Language.Rust.Syntax.Token + +import Language.Rust.Pretty.Internal +import Language.Rust.Pretty.Resolve + +import System.IO ( Handle ) +import Data.Typeable ( Typeable ) +import Data.Text.Prettyprint.Doc.Render.Text ( renderIO ) +import Data.Text.Prettyprint.Doc ( Doc ) +import qualified Data.Text.Prettyprint.Doc as PP + +import Control.Exception ( throw ) + +-- | Resolve (see the 'Resolve' typeclass) and pretty print something. +-- +-- >>> let one = Lit [] (Int Dec 1 Unsuffixed ()) () +-- >>> let two = Lit [] (Int Dec 2 Unsuffixed ()) () +-- >>> let three = Lit [] (Int Dec 3 Unsuffixed ()) () +-- >>> let bogusVar = PathExpr [] Nothing (Path False [PathSegment "let" Nothing ()] ()) () +-- >>> pretty (Binary [] MulOp (Binary [] AddOp one two ()) three ()) +-- Right (1 + 2) * 3 +-- >>> pretty (Binary [] AddOp one bogusVar ()) +-- Left (invalid AST (identifier `let' is a keyword)) +-- +pretty :: (Resolve a, Pretty a) => a -> Either ResolveFail (Doc b) +pretty = fmap prettyUnresolved . resolve + +-- | Same as 'pretty', but throws a 'ResolveFail' exception on invalid ASTs. This function is +-- intended for situations in which you are already stuck catching exceptions - otherwise you should +-- prefer 'pretty'. +-- +-- >>> let one = Lit [] (Int Dec 1 Unsuffixed ()) () +-- >>> let two = Lit [] (Int Dec 2 Unsuffixed ()) () +-- >>> let three = Lit [] (Int Dec 3 Unsuffixed ()) () +-- >>> let bogusVar = PathExpr [] Nothing (Path False [PathSegment "let" Nothing ()] ()) () +-- >>> pretty' (Binary [] MulOp (Binary [] AddOp one two ()) three ()) +-- (1 + 2) * 3 +-- >>> pretty' (Binary [] AddOp one bogusVar ()) +-- *** Exception: invalid AST (identifier `let' is a keyword)) +-- +pretty' :: (Resolve a, Pretty a) => a -> Doc b +pretty' = either throw id . pretty + +-- | Resolve (see the 'Resolve' typeclass) and pretty print something with annotations. Read more +-- about annotations in "Data.Text.Prettyprint.Doc". +-- +-- prop> fmap Data.Text.Prettyprint.Doc.noAnnotate . prettyAnnotated = pretty +-- +prettyAnnotated :: (Resolve (f a), PrettyAnnotated f) => f a -> Either ResolveFail (Doc a) +prettyAnnotated = fmap prettyAnnUnresolved . resolve + +-- | Same as 'prettyAnnotated', but throws a 'ResolveFail' exception on invalid ASTs. This function +-- is intended for situations in which you are already stuck catching exceptions - otherwise you +-- should prefer 'prettyAnnotated'. +-- +-- prop> Data.Text.Prettyprint.Doc.noAnnotate . prettyAnnotated' = pretty' +-- +prettyAnnotated' :: (Resolve (f a), PrettyAnnotated f) => f a -> Doc a +prettyAnnotated' = either throw id . prettyAnnotated + +-- | Given a handle to a file, write a 'SourceFile' in with a desired width of 100 characters. +writeSourceFile :: (Monoid a, Typeable a) => Handle -> SourceFile a -> IO () +writeSourceFile hdl = renderIO hdl . PP.layoutPretty layout . prettyAnnotated' + where layout = PP.LayoutOptions (PP.AvailablePerLine 100 1.0) + +-- | Given a handle to a file, write a 'SourceFile' in with a desired width of 100 characters. +-- +-- The 'Span' associated with the tokens (if present) will be used as a hint for laying out and +-- spacing the tokens. +writeTokens :: Handle -> [Spanned Token] -> IO () +writeTokens hdl = renderIO hdl . PP.layoutPretty layout . pretty' . Stream . map mkTT + where layout = PP.LayoutOptions (PP.AvailablePerLine 100 1.0) + mkTT (Spanned s t) = Tree (Token t s) + +-- | Describes things that can be pretty printed. +class Pretty a where + -- | Pretty print the given value without resolving it. + prettyUnresolved :: a -> Doc b + +instance Pretty Abi where prettyUnresolved = printAbi +instance Pretty BindingMode where prettyUnresolved = printBindingMode +instance Pretty BinOp where prettyUnresolved = printBinOp +instance Pretty Ident where prettyUnresolved = printIdent +instance Pretty ImplPolarity where prettyUnresolved = printPolarity +instance Pretty Suffix where prettyUnresolved = printLitSuffix +instance Pretty LitTok where prettyUnresolved = printLitTok +instance Pretty Mutability where prettyUnresolved = printMutability +instance Pretty RangeLimits where prettyUnresolved = printRangeLimits +instance Pretty Token where prettyUnresolved = printToken +instance Pretty TokenTree where prettyUnresolved = printTt +instance Pretty TokenStream where prettyUnresolved = printTokenStream +instance Pretty UnOp where prettyUnresolved = printUnOp +instance Pretty Unsafety where prettyUnresolved = printUnsafety +instance Pretty (Attribute a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Block a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (SourceFile a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Expr a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Field a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (FieldPat a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (FnDecl a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (ForeignItem a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Generics a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (ImplItem a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Item a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Lifetime a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (LifetimeDef a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Lit a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Mac a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Nonterminal a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Pat a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Path a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (PolyTraitRef a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Stmt a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (StructField a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (TraitItem a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (TraitRef a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Ty a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (TyParam a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (TyParamBound a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Variant a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (UseTree a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (Visibility a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (WhereClause a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty (WherePredicate a) where prettyUnresolved = PP.unAnnotate . prettyAnnUnresolved +instance Pretty Position where prettyUnresolved = PP.pretty . prettyPosition +instance Pretty Span where prettyUnresolved = PP.pretty . prettySpan + +-- | Similar to 'Pretty', but for types which are parametrized over an annotation type. +class PrettyAnnotated p where + -- | Pretty print the given value without resolving it, adding annotations in the 'Doc' whenever + -- possible. + prettyAnnUnresolved :: p a -> Doc a + +-- | This instance prints attributes inline +instance PrettyAnnotated Attribute where prettyAnnUnresolved = flip printAttr True +instance PrettyAnnotated Block where prettyAnnUnresolved = printBlock +instance PrettyAnnotated SourceFile where prettyAnnUnresolved = printSourceFile +instance PrettyAnnotated Expr where prettyAnnUnresolved = printExpr +instance PrettyAnnotated Field where prettyAnnUnresolved = printField +instance PrettyAnnotated FieldPat where prettyAnnUnresolved = printFieldPat +instance PrettyAnnotated FnDecl where prettyAnnUnresolved = printFnArgsAndRet +instance PrettyAnnotated ForeignItem where prettyAnnUnresolved = printForeignItem +instance PrettyAnnotated Generics where prettyAnnUnresolved = printGenerics +instance PrettyAnnotated ImplItem where prettyAnnUnresolved = printImplItem +instance PrettyAnnotated Item where prettyAnnUnresolved = printItem +instance PrettyAnnotated Lifetime where prettyAnnUnresolved = printLifetime +instance PrettyAnnotated LifetimeDef where prettyAnnUnresolved = printLifetimeDef +instance PrettyAnnotated Lit where prettyAnnUnresolved = printLit +instance PrettyAnnotated Mac where prettyAnnUnresolved = printMac Paren +instance PrettyAnnotated Nonterminal where prettyAnnUnresolved = printNonterminal +instance PrettyAnnotated Pat where prettyAnnUnresolved = printPat +instance PrettyAnnotated Path where prettyAnnUnresolved = flip printPath False +instance PrettyAnnotated PolyTraitRef where prettyAnnUnresolved = printPolyTraitRef +instance PrettyAnnotated Stmt where prettyAnnUnresolved = printStmt +instance PrettyAnnotated StructField where prettyAnnUnresolved = printStructField +instance PrettyAnnotated TraitItem where prettyAnnUnresolved = printTraitItem +instance PrettyAnnotated TraitRef where prettyAnnUnresolved = printTraitRef +instance PrettyAnnotated Ty where prettyAnnUnresolved = printType +instance PrettyAnnotated TyParam where prettyAnnUnresolved = printTyParam +instance PrettyAnnotated TyParamBound where prettyAnnUnresolved = printBound +instance PrettyAnnotated Variant where prettyAnnUnresolved = printVariant +instance PrettyAnnotated UseTree where prettyAnnUnresolved = printUseTree +instance PrettyAnnotated Visibility where prettyAnnUnresolved = printVis +instance PrettyAnnotated WhereClause where prettyAnnUnresolved = printWhereClause True +instance PrettyAnnotated WherePredicate where prettyAnnUnresolved = printWherePredicate + diff --git a/src/Language/Rust/Pretty/Internal.hs b/src/Language/Rust/Pretty/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Pretty/Internal.hs @@ -0,0 +1,1030 @@ +{-| +Module : Language.Rust.Pretty.Internal +Description : Rust pretty printer +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : portable + +The pretty printing facilities in this file are re-exported to 'Language.Rust.Pretty' via the +'Pretty' and 'PrettyAnnotated' classes. There may be invariants in this module that are not properly +documented. +-} +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} +{-# OPTIONS_HADDOCK hide, not-home #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Rust.Pretty.Internal ( + + -- * Pretty printers + -- As much as possible, these functions should say which function in the @rustc@ printer they are + -- emulating. + + -- ** Top level + printSourceFile, + + -- ** General + printMutability, + printUnsafety, + printFnArgsAndRet, + printIdent, + printName, + + -- ** Paths + printPath, + + -- ** Attributes + printAttr, + + -- ** Literals + printLit, + printLitSuffix, + printLitTok, + + -- ** Expressions + printExpr, + printAbi, + printUnOp, + printBinOp, + printField, + printRangeLimits, + + -- ** Types and lifetimes + printType, + printGenerics, + printLifetime, + printLifetimeDef, + printTyParam, + printBound, + printWhereClause, + printWherePredicate, + printPolyTraitRef, + printTraitRef, + + -- ** Patterns + printPat, + printBindingMode, + printFieldPat, + + -- ** Statements + printStmt, + + -- ** Items + printItem, + printForeignItem, + printImplItem, + printTraitItem, + printPolarity, + printStructField, + printVariant, + printUseTree, + printVis, + + -- ** Blocks + printBlock, + + -- ** Token trees + printToken, + printTt, + printTokenStream, + printNonterminal, + printMac, + + -- * Utilities + module Language.Rust.Pretty.Util, +) where + +import Language.Rust.Pretty.Literals +import Language.Rust.Pretty.Util + +import Language.Rust.Data.Ident +import Language.Rust.Data.Position + +import Language.Rust.Syntax.AST +import Language.Rust.Syntax.Token + +import Data.Text.Prettyprint.Doc hiding ( (<+>), hsep, indent, vsep ) + +import Data.Maybe ( maybeToList, fromMaybe ) +import Data.Foldable ( toList ) +import Data.List ( unfoldr ) +import qualified Language.Rust.Parser.NonEmpty as N + +-- | Print a source file +printSourceFile :: SourceFile a -> Doc a +printSourceFile (SourceFile shebang as items) = foldr1 (\x y -> x <#> "" <#> y) ls + where ls = concat [ maybeToList ((\s -> "#!" <> pretty s) <$> shebang) + , [ vcat [ printAttr a False | a <- as ] ] + , punctuate line' (printItem `map` items) + ] + +-- | Print a name +printName :: Name -> Doc a +printName = pretty + +printEmbeddedExpr :: String -> Doc a +printEmbeddedExpr s = "${e|" <> printName s <> "|}" + +printEmbeddedIdent :: String -> Doc a +printEmbeddedIdent s = "${i|" <> pretty s <> "|}" + +printIdentName :: IdentName -> Doc a +printIdentName (Name n) = printName n +printIdentName (HaskellName n) = printEmbeddedIdent n + +-- | Print an identifier +printIdent :: Ident -> Doc a +printIdent (Ident s False _) = printIdentName s +printIdent (Ident s True _) = "r#" <> printIdentName s + +-- | Print a type (@print_type@ with @print_ty_fn@ inlined) +-- Types are expected to always be only one line +printType :: Ty a -> Doc a +printType (Slice ty x) = annotate x ("[" <> printType ty <> "]") +printType (Array ty v x) = annotate x ("[" <> printType ty <> ";" <+> printExpr v <> "]") +printType (Ptr mut ty x) = annotate x ("*" <> printFullMutability mut <+> printType ty) +printType (Rptr lt mut ty x) = annotate x ("&" <> perhaps printLifetime lt <+> printMutability mut <+> printType ty) +printType (Never x) = annotate x "!" +printType (TupTy [elt] x) = annotate x (block Paren True "" mempty [ printType elt <> "," ]) +printType (TupTy elts x) = annotate x (block Paren True "," mempty (printType `map` elts)) +printType (PathTy Nothing p x) = annotate x (printPath p False) +printType (PathTy (Just q) p x) = annotate x (printQPath p q False) +printType (TraitObject bs x) = let prefix = if null (N.tail bs) then "dyn" else mempty + in annotate x (printBounds prefix (toList bs)) +printType (ImplTrait bs x) = annotate x (printBounds "impl" (toList bs)) +printType (ParenTy ty x) = annotate x ("(" <> printType ty <> ")") +printType (Typeof e x) = annotate x ("typeof" <> block Paren True mempty mempty [ printExpr e ]) +printType (Infer x) = annotate x "_" +printType (MacTy m x) = annotate x (printMac Bracket m) +printType (BareFn u a l d x) = annotate x (printFormalLifetimeList l + <+> printFnHeaderInfo u NotConst a InheritedV + <> printFnArgsAndRet d) + +-- | Print a macro (@print_mac@) +printMac :: Delim -> Mac a -> Doc a +printMac d (Mac path ts x) = annotate x (printPath path False <> "!" <> body) + where body = block d True mempty mempty [ printTokenStream ts ] + +-- | Given two positions, find out how to print appropriate amounts of space between them +printSpaceBetween :: Bool -> Span -> Span -> Maybe (Doc a) +printSpaceBetween spaceNeeded (Span _ (Position _ y1 x1)) (Span (Position _ y2 x2) _) + | y2 == y1 && x2 > x1 = Just $ hcat (replicate (x2 - x1) space) + | y2 > y1 = Just $ hcat (replicate (y2 - y1) line) <> column (\x1' -> hcat (replicate (x2 - x1') space)) + | spaceNeeded = Just space + | otherwise = Just mempty +printSpaceBetween _ _ _ = Nothing + +-- | Print a token tree (@print_tt@) +printTt :: TokenTree -> Doc a +printTt (Token _ t) = printToken t +printTt (Delimited _ d ts) = block d True mempty mempty [ printTokenStream ts ] + +-- | Print a list of token trees, with the right amount of space between successive elements +printTokenTrees :: [TokenTree] -> Doc a +printTokenTrees [] = mempty +printTokenTrees [tt] = printTt tt +printTokenTrees (tt1:tt2:tts) = printTt tt1 <> sp <> printTokenTrees (tt2:tts) + where + extremities :: TokenTree -> (Token, Token) + extremities (Token _ t ) = (t,t) + extremities (Delimited _ d _) = (OpenDelim d, CloseDelim d) + + -- extremities in this particular situation + (lastTt1, firstTt2) = (snd $ extremities tt1, fst $ extremities tt2) + spNeeded = lastTt1 `spaceNeeded` firstTt2 + + -- Spacing of tokens, as informed by positional information on tokens + spPos = printSpaceBetween spNeeded (spanOf tt1) (spanOf tt2) + + -- Spacing of tokens, as informed by 'spaceNeeded' and special cases + spTok = case (snd $ extremities tt1, fst $ extremities tt2) of + (Comma, _) -> space + (Colon, _) -> space + (Semicolon, _) -> space + (_, OpenDelim Brace) -> space + (CloseDelim Brace, _) -> space + (t1, t2) | t1 `elem` toksRequiringSp || t2 `elem` toksRequiringSp -> space + | otherwise -> if spNeeded then space else mempty + + -- List of tokens that want to have space on either side of them + toksRequiringSp = [ Equal, GreaterEqual, GreaterGreaterEqual, EqualEqual, NotEqual, LessEqual, + LessLessEqual, MinusEqual, AmpersandEqual, PipeEqual, PlusEqual, StarEqual, + SlashEqual, CaretEqual, PercentEqual, RArrow, LArrow, FatArrow ] + + -- Use 'spPos' with 'spTok' as a fallback + sp = fromMaybe spTok spPos + +-- | Print the space between a token stream and the mod-path before it +printTokenStreamSp :: TokenStream -> Doc a +printTokenStreamSp (Tree Token{}) = space +printTokenStreamSp (Tree Delimited{}) = mempty +printTokenStreamSp (Stream []) = mempty +printTokenStreamSp (Stream (t:_)) = printTokenStreamSp t + +-- | Print a token stream +printTokenStream :: TokenStream -> Doc a +printTokenStream = printTokenTrees . unfoldr unconsTokenStream + +-- | Print a token (@token_to_string@) +-- Single character expression-operator symbols. +printToken :: Token -> Doc a +printToken Equal = "=" +printToken Less = "<" +printToken Greater = ">" +printToken Ampersand = "&" +printToken Pipe = "|" +printToken Exclamation = "!" +printToken Tilde = "~" +printToken Plus = "+" +printToken Minus = "-" +printToken Star = "*" +printToken Slash = "/" +printToken Percent = "%" +-- Multi character eexpression-operator symbols +printToken GreaterEqual = ">=" +printToken GreaterGreaterEqual = ">>=" +printToken AmpersandAmpersand = "&&" +printToken PipePipe = "||" +printToken LessLess = "<<" +printToken GreaterGreater = ">>" +printToken EqualEqual = "==" +printToken NotEqual = "!=" +printToken LessEqual = "<=" +printToken LessLessEqual = "<<=" +printToken MinusEqual = "-=" +printToken AmpersandEqual = "&=" +printToken PipeEqual = "|=" +printToken PlusEqual = "+=" +printToken StarEqual = "*=" +printToken SlashEqual = "/=" +printToken CaretEqual = "^=" +printToken PercentEqual = "%=" +printToken Caret = "^" +-- Structural symbols +printToken At = "@" +printToken Dot = "." +printToken DotDot = ".." +printToken DotDotDot = "..." +printToken DotDotEqual = "..=" +printToken Comma = "," +printToken Semicolon = ";" +printToken Colon = ":" +printToken ModSep = "::" +printToken RArrow = "->" +printToken LArrow = "<-" +printToken FatArrow = "=>" +printToken Pound = "#" +printToken Dollar = "$" +printToken Question = "?" +-- Delimiters, eg. @{@, @]@, @(@ +printToken (OpenDelim Paren) = "(" +printToken (OpenDelim Bracket) = "[" +printToken (OpenDelim Brace) = "{" +printToken (OpenDelim NoDelim) = "" +printToken (CloseDelim Paren) = ")" +printToken (CloseDelim Bracket) = "]" +printToken (CloseDelim Brace) = "}" +printToken (CloseDelim NoDelim) = "" +-- Literals +printToken (LiteralTok l s) = noIndent $ printLitTok l <> perhaps printName s +-- Name components +printToken (IdentTok i) = printIdent i +printToken (LifetimeTok i) = "'" <> printIdent i +printToken (Space Whitespace _) = " " +printToken (Space Comment n) = "/*" <> printName n <> " */" +printToken (Doc d Inner True) = "/*!" <> printName d <> "*/" +printToken (Doc d Outer True) = "/**" <> printName d <> "*/" +printToken (Doc d Inner False) = "//!" <> printName d +printToken (Doc d Outer False) = "///" <> printName d +printToken Shebang = "#!" +-- Macro related +printToken (Interpolated n) = unAnnotate (printNonterminal n) +-- Other +printToken t = error $ "printToken: " ++ show t + + +-- | Print a literal token +printLitTok :: LitTok -> Doc a +printLitTok (ByteTok n) = "b'" <> printName n <> "'" +printLitTok (CharTok n) = "'" <> printName n <> "'" +printLitTok (IntegerTok n) = printName n +printLitTok (FloatTok n) = printName n +printLitTok (StrTok n) = "\"" <> string hardline n <> "\"" +printLitTok (StrRawTok n m) = let pad = pretty (replicate m '#') + in "r" <> pad <> "\"" <> string hardline n <> "\"" <> pad +printLitTok (ByteStrTok n) = "b\"" <> string hardline n <> "\"" +printLitTok (ByteStrRawTok n m) = let pad = pretty (replicate m '#') in "br" <> pad <> "\"" <> string hardline n <> "\"" <> pad + +-- | Print a nonterminal +printNonterminal :: Nonterminal a -> Doc a +printNonterminal (NtItem item) = printItem item +printNonterminal (NtBlock blk) = printBlock blk +printNonterminal (NtStmt stmt) = printStmt stmt +printNonterminal (NtPat pat) = printPat pat +printNonterminal (NtExpr expr) = printExpr expr +printNonterminal (NtTy ty) = printType ty +printNonterminal (NtIdent ident) = printIdent ident +printNonterminal (NtPath path) = printPath path False +printNonterminal (NtTT tt) = printTt tt +printNonterminal (NtArm arm) = printArm arm +printNonterminal (NtImplItem item) = printImplItem item +printNonterminal (NtTraitItem item) = printTraitItem item +printNonterminal (NtGenerics generics) = printGenerics generics +printNonterminal (NtWhereClause clause) = printWhereClause True clause +printNonterminal (NtArg arg) = printArg arg True +printNonterminal (NtLit lit) = printLit lit + +-- | Print a statement (@print_stmt@) +printStmt :: Stmt a -> Doc a +printStmt (ItemStmt item x) = annotate x (printItem item) +printStmt (NoSemi expr x) = annotate x (printExprOuterAttrStyle expr False <> when (requiresSemi expr) ";") + where + -- @parse::classify::expr_requires_semi_to_be_stmt@ + requiresSemi :: Expr a -> Bool + requiresSemi If{} = False + requiresSemi IfLet{} = False + requiresSemi While{} = False + requiresSemi WhileLet{} = False + requiresSemi ForLoop{} = False + requiresSemi Loop{} = False + requiresSemi Match{} = False + requiresSemi BlockExpr{} = False + requiresSemi _ = True +printStmt (Semi expr x) = annotate x (printExprOuterAttrStyle expr False <> ";") +printStmt (MacStmt m ms as x) = annotate x (printOuterAttrs as printMac delim m <> end) + where delim = case ms of { BracesMac -> Brace; _ -> Paren } + end = case ms of { SemicolonMac -> ";"; _ -> mempty } +printStmt (Local p ty i as x) = annotate x (printOuterAttrs as <#> group ("let" <+> binding <+> initializer <> ";")) + where binding = group (printPat p <> perhaps (\t -> ":" <#> indent n (printType t)) ty) + initializer = perhaps (\e -> "=" <#> indent n (printExpr e)) i + +-- | Print an expression +printExpr :: Expr a -> Doc a +printExpr expr = printExprOuterAttrStyle expr True + +-- | Print an expression (@print_expr_outer_attr_style@) +-- Inlined @print_expr_in_place@, @print_expr_call@, @print_expr_method_call@, @print_expr_tup@, +-- @print_expr_binary@, @print_expr_unary@, @print_expr_addr_of@, @print_if@, @print_if_let@, +-- @print_expr_repeat@ +-- +-- TODO: attributes on chained method calls +printExprOuterAttrStyle :: Expr a -> Bool -> Doc a +printExprOuterAttrStyle expr isInline = glue (printEitherAttrs (expressionAttrs expr) Outer isInline) $ + case expr of + Box _ e x -> annotate x ("box" <+> printExpr e) + InPlace _ place e x -> annotate x (hsep [ printExpr place, "<-", printExpr e ]) + Vec as exprs x -> annotate x (block Bracket True "," (printInnerAttrs as) (printExpr <$> exprs)) + Call _ func [arg] x -> annotate x (printExpr func <> parens (printExpr arg)) + Call _ func args x -> annotate x (printExpr func <> block Paren True "," mempty (printExpr <$> args)) + MethodCall{} -> chainedMethodCalls expr False id + TupExpr as [e] x -> annotate x (block Paren True "" (printInnerAttrs as) [ printExpr e <> "," ]) + TupExpr as es x -> annotate x (block Paren True "," (printInnerAttrs as) (printExpr <$> es)) + Binary _ op lhs rhs x -> annotate x (hsep [ printExpr lhs, printBinOp op, printExpr rhs ]) + Unary _ op e x -> annotate x (printUnOp op <> printExpr e) + Lit _ lit x -> annotate x (printLit lit) + Cast _ e ty x -> let f = case e of { Cast{} -> printExpr; _ -> printExpr } + in annotate x (hsep [ f e, "as", printType ty ]) + TypeAscription _ e ty x -> annotate x (printExpr e <> ":" <+> printType ty) + If _ test blk els x -> annotate x (hsep [ "if", printExpr test, printBlock blk, printElse els ]) + IfLet _ pats e blk els x -> annotate x (hsep [ "if let", printPats pats, "=", printExpr e, printBlock blk, printElse els ]) + While as test blk lbl x -> annotate x (hsep [ printLbl lbl, "while", printExpr test, printBlockWithAttrs True blk as ]) + WhileLet as ps e blk lbl x -> annotate x (hsep [ printLbl lbl, "while let", printPats ps, "=", printExpr e, printBlockWithAttrs True blk as ]) + ForLoop as pat e blk lbl x -> annotate x (hsep [ printLbl lbl, "for", printPat pat, "in", printExpr e, printBlockWithAttrs True blk as ]) + Loop as blk lbl x -> annotate x (hsep [ printLbl lbl, "loop", printBlockWithAttrs True blk as ]) + Match as e arms x -> annotate x (hsep [ "match", printExpr e, block Brace False "," (printInnerAttrs as) (printArm `map` arms) ]) + Closure _ s cap decl body x -> annotate x (hsep [ when (s == Immovable) "static" + , when (cap == Value) "move" + , printFnBlockArgs decl <+> printExpr body]) + BlockExpr attrs blk x -> annotate x (printBlockWithAttrs True blk attrs) + Catch attrs blk x -> annotate x ("do catch" <+> printBlockWithAttrs True blk attrs) + Assign _ lhs rhs x -> annotate x (hsep [ printExpr lhs, "=", printExpr rhs ]) + AssignOp _ op lhs rhs x -> annotate x (hsep [ printExpr lhs, printBinOp op <> "=", printExpr rhs ]) + FieldAccess{} -> chainedMethodCalls expr False id + TupField{} -> chainedMethodCalls expr False id + Index{} -> chainedMethodCalls expr False id + Range _ start end limits x -> annotate x (perhaps printExpr start <+> printRangeLimits limits <+> perhaps printExpr end) + PathExpr _ Nothing path x -> annotate x (printPath path True) + PathExpr _ (Just qs) path x -> annotate x (printQPath path qs True) + AddrOf _ mut e x -> annotate x ("&" <> printMutability mut <+> printExpr e) + Break _ brk e x -> annotate x ("break" <+> printLbl' brk <+> perhaps printExpr e) + Continue _ cont x -> annotate x ("continue" <+> printLbl' cont) + Ret _ result x -> annotate x ("return" <+> perhaps printExpr result) + Yield _ result x -> annotate x ("yield" <+> perhaps printExpr result) + MacExpr _ m x -> annotate x (printMac Paren m) + Struct as p fs Nothing x -> annotate x (printPath p True <+> block Brace True "," (printInnerAttrs as) (printField `map` fs)) + Struct as p fs (Just d) x -> let body = [ printField f <> "," | f <- fs ] ++ [ ".." <> printExpr d ] + in annotate x (printPath p True <+> block Brace True mempty (printInnerAttrs as) body) + Repeat attrs e cnt x -> annotate x (brackets (printInnerAttrs attrs <+> printExpr e <> ";" <+> printExpr cnt)) + ParenExpr attrs e x -> annotate x (parens (printInnerAttrs attrs <+> printExpr e)) + Try{} -> chainedMethodCalls expr False id + EmbeddedExpr _ e x -> annotate x (printEmbeddedExpr e) + where + printLbl = perhaps (\(Label n x) -> annotate x ("'" <> printName n) <> ":") + printLbl' = perhaps (\(Label n x) -> annotate x ("'" <> printName n)) + glue = if isInline then (<+>) else () + + -- | From an expression, separate the first non-method-call from the list of method call suffixes + -- + -- Collects in the list + -- * methods + -- * field accesses + -- + -- Allows interweaving + -- * tuple field accesses + -- * array indexes + -- * try + -- + chainedMethodCalls :: Expr a -- ^ expression + -> Bool -- ^ last expression was a 'TupField' (if we have two + -- successive 'TupField's, we need a space between them + -- to prevent them from looking like a float literal) + -> (Doc a -> Doc a) -- ^ suffix to the expression + -> Doc a + chainedMethodCalls (MethodCall _ s i ts' as x) _ fdoc + = let tys = perhaps (\ts -> "::<" <> commas ts printType <> ">") ts' + as' = case as of + [a] -> parens (printExpr a) + _ -> block Paren True "," mempty (printExpr <$> as) + in chainedMethodCalls s False (annotate x . (<##> fdoc (indent n (hcat [ ".", printIdent i, tys, as' ])))) + chainedMethodCalls (FieldAccess _ s i x) _ fdoc + = chainedMethodCalls s False (annotate x . (<##> fdoc (indent n (hcat [ ".", printIdent i ])))) + chainedMethodCalls (Try _ s x) _ fdoc + = chainedMethodCalls s False (annotate x . (<> fdoc "?")) + chainedMethodCalls (Index _ s i x) _ fdoc + = chainedMethodCalls s False (annotate x . (<> fdoc ("[" <> block NoDelim True mempty mempty [printExpr i] <> "]"))) + chainedMethodCalls (TupField _ s i x) t fdoc + = chainedMethodCalls s True (annotate x . (<> fdoc ("." <> pretty i <> when t " "))) + chainedMethodCalls e _ fdoc = group (fdoc (printExpr e)) + +-- | Print a string literal +printStr :: StrStyle -> String -> Doc a +printStr sty str = unAnnotate (printLit (Str str sty Unsuffixed ())) + +-- | Extract from an expression its attributes +expressionAttrs :: Expr a -> [Attribute a] +expressionAttrs (Box as _ _) = as +expressionAttrs (InPlace as _ _ _) = as +expressionAttrs (Vec as _ _) = as +expressionAttrs (Call as _ _ _) = as +expressionAttrs (MethodCall as _ _ _ _ _) = as +expressionAttrs (TupExpr as _ _) = as +expressionAttrs (Binary as _ _ _ _) = as +expressionAttrs (Unary as _ _ _) = as +expressionAttrs (Lit as _ _) = as +expressionAttrs (Cast as _ _ _) = as +expressionAttrs (TypeAscription as _ _ _) = as +expressionAttrs (If as _ _ _ _) = as +expressionAttrs (IfLet as _ _ _ _ _) = as +expressionAttrs (While as _ _ _ _) = as +expressionAttrs (WhileLet as _ _ _ _ _) = as +expressionAttrs (ForLoop as _ _ _ _ _) = as +expressionAttrs (Loop as _ _ _) = as +expressionAttrs (Match as _ _ _) = as +expressionAttrs (Closure as _ _ _ _ _) = as +expressionAttrs (BlockExpr as _ _) = as +expressionAttrs (Catch as _ _) = as +expressionAttrs (Assign as _ _ _) = as +expressionAttrs (AssignOp as _ _ _ _) = as +expressionAttrs (FieldAccess as _ _ _) = as +expressionAttrs (TupField as _ _ _) = as +expressionAttrs (Index as _ _ _) = as +expressionAttrs (Range as _ _ _ _) = as +expressionAttrs (PathExpr as _ _ _) = as +expressionAttrs (AddrOf as _ _ _) = as +expressionAttrs (Break as _ _ _) = as +expressionAttrs (Continue as _ _) = as +expressionAttrs (Ret as _ _) = as +expressionAttrs (MacExpr as _ _) = as +expressionAttrs (Struct as _ _ _ _) = as +expressionAttrs (Repeat as _ _ _) = as +expressionAttrs (ParenExpr as _ _) = as +expressionAttrs (Try as _ _) = as +expressionAttrs (Yield as _ _) = as +expressionAttrs (EmbeddedExpr as _ _) = as + +-- | Print a field +printField :: Field a -> Doc a +printField (Field ident Nothing x) = annotate x (printIdent ident) +printField (Field ident (Just expr) x) = annotate x (printIdent ident <>":" <+> printExpr expr) + +-- | Print range limits +printRangeLimits :: RangeLimits -> Doc a +printRangeLimits HalfOpen = ".." +printRangeLimits Closed = "..=" + +-- | Print a closure function declaration (@print_fn_block_args@) +printFnBlockArgs :: FnDecl a -> Doc a +printFnBlockArgs (FnDecl args ret _ x) = annotate x ("|" <> args' <> "|" <+> ret') + where ret' = perhaps (\ty -> "->" <+> printType ty) ret + args' = commas args (`printArg` True) + +-- | Print the arm of a match expression (@print_arm@) +printArm :: Arm a -> Doc a +printArm (Arm as pats guard body x) = annotate x $ printOuterAttrs as + printPats pats + <+> perhaps (\e -> "if" <+> printExpr e) guard + <+> "=>" + <+> printExpr body + +printPats :: Foldable f => f (Pat a) -> Doc a +printPats pats = group (foldr1 (\a b -> a <+> "|" <#> b) (printPat `map` toList pats)) + +-- | Print a block +printBlock :: Block a -> Doc a +printBlock blk = printBlockWithAttrs True blk [] + +-- | Print a block with attributes (@print_block_with_attrs@ or @print_block_maybe_unclosed@) +printBlockWithAttrs :: Bool -> Block a -> [Attribute a] -> Doc a +printBlockWithAttrs b (Block stmts rules x) as = annotate x (printUnsafety rules <+> block Brace b mempty (printInnerAttrs as) stmts') + where + stmts' | null stmts = [] + | otherwise = body ++ [ lastStmt ] + + body = printStmt `map` Prelude.init stmts + + lastStmt = case last stmts of + NoSemi expr _ -> printExprOuterAttrStyle expr False + stmt -> printStmt stmt + +-- | Print an @else@ expression (@print_else@) +printElse :: Maybe (Expr a) -> Doc a +printElse Nothing = mempty +printElse (Just (If _ e t s x)) = annotate x (hsep [ "else if", printExpr e, printBlock t, printElse s ]) +printElse (Just (IfLet _ p e t s x)) = annotate x (hsep [ "else if let", printPats p, "=", printExpr e, printBlock t, printElse s ]) +printElse (Just (BlockExpr _ blk x)) = annotate x (hsep [ "else", printBlock blk ]) +printElse _ = error "printElse saw `if` with a weird alternative" + +-- | Print a binary operator +printBinOp :: BinOp -> Doc a +printBinOp AddOp = "+" +printBinOp SubOp = "-" +printBinOp MulOp = "*" +printBinOp DivOp = "/" +printBinOp RemOp = "%" +printBinOp AndOp = "&&" +printBinOp OrOp = "||" +printBinOp BitXorOp = "^" +printBinOp BitAndOp = "&" +printBinOp BitOrOp = "|" +printBinOp ShlOp = "<<" +printBinOp ShrOp = ">>" +printBinOp EqOp = "==" +printBinOp LtOp = "<" +printBinOp LeOp = "<=" +printBinOp NeOp = "!=" +printBinOp GeOp = ">=" +printBinOp GtOp = ">" + +-- | Print a unary operator +printUnOp :: UnOp -> Doc a +printUnOp Deref = "*" +printUnOp Not = "!" +printUnOp Neg = "-" + +-- | Print inner attributes (@print_inner_attributes@ or @print_inner_attributes_inline@ +-- or @print_inner_attributes_nodbreak@ - distinction has to be made at callsite +-- whether to force newline) +printInnerAttrs :: [Attribute a] -> Doc a +printInnerAttrs attrs = printEitherAttrs attrs Inner False + +-- | Print outer attributes (@print_outer_attributes@ or @print_outer_attributes_no_trailing_hardbreak@) +printOuterAttrs :: [Attribute a] -> Doc a +printOuterAttrs attrs = printEitherAttrs attrs Outer False + +-- | Print either type of attributes (@print_either_attributes@) +printEitherAttrs :: [Attribute a] -> AttrStyle -> Bool -> Doc a +printEitherAttrs attrs kind inline = unless (null attrs') (glue attrs') + where glue = if inline then hsep else vcat + attrs' = [ printAttr attr inline | attr <- attrs, style attr == kind ] + + style (Attribute sty _ _ _) = sty + style (SugaredDoc sty _ _ _) = sty + +-- | Print an attribute (@print_attribute_inline@ or @print_attribute@) +printAttr :: Attribute a -> Bool -> Doc a +printAttr (Attribute Inner p ts x) _ = annotate x ("#![" <> printPath p True <> printTokenStreamSp ts <> printTokenStream ts <> "]") +printAttr (Attribute Outer p ts x) _ = annotate x ("#[" <> printPath p True <> printTokenStreamSp ts <> printTokenStream ts <> "]") +printAttr (SugaredDoc Inner True c x) _ = annotate x (noIndent ("/*!" <> string hardline c <> "*/")) +printAttr (SugaredDoc Outer True c x) _ = annotate x (noIndent ("/**" <> string hardline c <> "*/")) +printAttr (SugaredDoc Inner False c x) _ = annotate x (flatAlt ("//!" <> pretty c) ("/*!" <> pretty c <> "*/")) +printAttr (SugaredDoc Outer False c x) _ = annotate x (flatAlt ("///" <> pretty c) ("/**" <> pretty c <> "*/")) + +-- | Print an identifier as is, or as cooked string if containing a hyphen +printCookedIdent :: Ident -> Doc a +printCookedIdent ident@(Ident (Name str) raw _) + | '-' `elem` str && not raw = printStr Cooked str + | otherwise = printIdent ident +printCookedIdent ident@(Ident (HaskellName _) _ _) + = printIdent ident + +-- | Print an item (@print_item@) +printItem :: Item a -> Doc a +printItem (ExternCrate as vis ident p x) = annotate x $ align $ printOuterAttrs as <#> + hsep [ printVis vis, "extern", "crate", perhaps (\p' -> printCookedIdent p' <+> "as") p, printIdent ident <> ";" ] + +printItem (Use as vis ut x) = annotate x $ align $ printOuterAttrs as <#> + hsep [ printVis vis, "use", printUseTree ut <> ";" ] + +printItem (Static as vis ident ty m e x) = annotate x $ align $ printOuterAttrs as <#> + hsep [ printVis vis, "static", printMutability m, printIdent ident <> ":", printType ty, "=", printExpr e <> ";" ] + +printItem (ConstItem as vis ident t e x) = annotate x $ align $ printOuterAttrs as <#> + hsep [ printVis vis, "const", printIdent ident <> ":", printType t, "=", printExpr e <> ";" ] + +printItem (Fn as vis ident d s c a t b x) = annotate x $ align $ printOuterAttrs as <#> + printFn d s c a (Just ident) t vis (Just (b, as)) + +printItem (Mod as vis ident items x) = annotate x $ align $ printOuterAttrs as <#> + hsep [ printVis vis, "mod", printMod ident items as ] + +printItem (ForeignMod as vis a i x) = annotate x $ align $ printOuterAttrs as <#> + hsep [ printVis vis, printAbi a, printForeignMod i as ] + +printItem (TyAlias as vis ident ty ps x) = annotate x $ align $ printOuterAttrs as <#> + let wc = printWhereClause True (whereClause ps) + leading = printVis vis <+> "type" <+> printIdent ident <> printGenerics ps + in emptyElim (group (leading <+> "=" <#> indent n (printType ty <> ";"))) + (\w -> vsep [leading, w, "=" <+> printType ty <> ";"]) + wc + +printItem (Enum as vis ident vars ps x) = annotate x $ align $ printOuterAttrs as <#> + printEnumDef vars ps ident vis + +printItem (StructItem as vis ident s g x) = annotate x $ align $ printOuterAttrs as <#> + hsep [ printVis vis, "struct", printStruct s g ident True True ] + +printItem (Union as vis ident s g x) = annotate x $ align $ printOuterAttrs as <#> + hsep [ printVis vis, "union", printStruct s g ident True True ] + +printItem (Trait as vis ident a u g tys i x) = annotate x $ align $ printOuterAttrs as <#> + let leading = hsep [ printVis vis, printUnsafety u, when a "auto", "trait" + , printIdent ident <> printGenerics g <> printBounds ":" tys + ] + lagging = block Brace False mempty (printInnerAttrs as) (printTraitItem `map` i) + wc = printWhereClause True (whereClause g) + in emptyElim (leading <+> lagging) + (\w -> vsep [leading, w, lagging]) + wc + +printItem (TraitAlias as vis ident g bds x) = annotate x $ align $ printOuterAttrs as <#> + let leading = printVis vis <+> "trait" <+> printIdent ident <> printGenerics g + in group (leading <#> indent n (printBounds "=" (toList bds)) <> ";") + +printItem (Impl as vis d u p g t ty i x) = annotate x $ align $ printOuterAttrs as <#> + let generics = case g of { Generics [] [] _ _ -> mempty; _ -> printGenerics g } + traitref = perhaps (\t' -> printPolarity p <> printTraitRef t' <+> "for") t + leading = hsep [ printVis vis, printDef d, printUnsafety u + , "impl" <> generics, traitref, printType ty + ] + lagging = block Brace False mempty (printInnerAttrs as) (printImplItem `map` i) + wc = printWhereClause True (whereClause g) + in emptyElim (leading <+> lagging) + (\w -> vsep [leading, w, lagging]) + wc + +printItem (MacItem as i (Mac p ts y) x) = annotate x $ annotate y $ align $ printOuterAttrs as <#> + (printPath p True <> "!" <+> perhaps printIdent i <+> block Brace True mempty mempty [ printTokenStream ts ]) + +printItem (MacroDef as i ts x) = annotate x $ align $ printOuterAttrs as <#> + ("macro_rules" <> "!" <+> printIdent i <+> block Brace True mempty mempty [ printTokenStream ts ]) + + +-- | Print a trait item (@print_trait_item@) +printTraitItem :: TraitItem a -> Doc a +printTraitItem (ConstT as ident ty expr x) = annotate x $ printOuterAttrs as <#> printAssociatedConst ident ty expr InheritedV +printTraitItem (MethodT as ident g sig body x) = annotate x $ printOuterAttrs as <#> printMethodSig ident g sig InheritedV (fmap (\b -> (b, as)) body) +printTraitItem (TypeT as ident bounds ty x) = annotate x $ printOuterAttrs as <#> printAssociatedType ident (Just bounds) ty +printTraitItem (MacroT as m x) = annotate x $ printOuterAttrs as <#> printMac Paren m <> ";" + +-- | Print type parameter bounds with the given prefix, but only if there are any bounds (@print_bounds@) +printBounds :: Doc a -> [TyParamBound a] -> Doc a +printBounds _ [] = mempty +printBounds prefix bs = group (prefix <#> ungroup (block NoDelim False " +" mempty (printBound `map` bs))) + +-- | Print a type parameter bound +printBound :: TyParamBound a -> Doc a +printBound (RegionTyParamBound lt x) = annotate x $ printLifetime lt +printBound (TraitTyParamBound tref modi x) = annotate x $ when (modi == Maybe) "?" <> printPolyTraitRef tref + +-- | Print the formal lifetime list (@print_formal_lifetime_list@) +printFormalLifetimeList :: [LifetimeDef a] -> Doc a +printFormalLifetimeList [] = mempty +printFormalLifetimeList defs = "for" <> angles (align (fillSep (punctuate "," (printDef `map` defs)))) + where printDef (LifetimeDef as lt bds x) = annotate x (printOuterAttrs as <+> flatten (printLifetimeBounds lt bds)) + +-- | Print an impl item (@print_impl_item@) +printImplItem :: ImplItem a -> Doc a +printImplItem (ConstI as vis def ident ty expr x) = annotate x $ printOuterAttrs as <#> + (printVis vis <+> printDef def <+> printAssociatedConst ident ty (Just expr) InheritedV) +printImplItem (MethodI as vis def ident g sig body x) = annotate x $ printOuterAttrs as <#> + (printVis vis <+> printDef def <+> printMethodSig ident g sig InheritedV (Just (body, as))) +printImplItem (TypeI as vis def ident ty x) = annotate x $ printOuterAttrs as <#> + (printVis vis <+> printDef def <+> printAssociatedType ident Nothing (Just ty)) +printImplItem (MacroI as def mac x) = annotate x $ printOuterAttrs as <#> + (printDef def <+> printMac Paren mac <> ";") + +-- | Print defaultness (@Defaultness@) +printDef :: Defaultness -> Doc a +printDef Default = "default" +printDef Final = mempty + +-- | Print an associated type (@printAssociatedType@) +printAssociatedType :: Ident -> Maybe [TyParamBound a] -> Maybe (Ty a) -> Doc a +printAssociatedType ident bounds_m ty_m = "type" <+> (printIdent ident + <> perhaps (printBounds ":") bounds_m) + <+> perhaps (\ty -> "=" <+> printType ty) ty_m + <> ";" + +-- | Print a method signature (@print_method_sig@) +printMethodSig :: Ident -> Generics a -> MethodSig a -> Visibility a -> Maybe (Block a, [Attribute a]) -> Doc a +printMethodSig ident generics (MethodSig unsafety constness abi decl) + = printFn decl unsafety constness abi (Just ident) generics + +-- | Print an associated constant (@print_associated_const@) +printAssociatedConst :: Ident -> Ty a -> Maybe (Expr a) -> Visibility a -> Doc a +printAssociatedConst ident ty default_m vis = printVis vis + <+> "const" <+> printIdent ident <> ":" <+> printType ty + <+> perhaps (\expr -> "=" <+> printExpr expr) default_m + <> ";" + +-- | Print the polarity of a trait +printPolarity :: ImplPolarity -> Doc a +printPolarity Negative = "!" +printPolarity Positive = mempty + +-- | Print visibility (@print_visibility@) +printVis :: Visibility a -> Doc a +printVis PublicV = "pub" +printVis CrateV = "pub(crate)" +printVis (RestrictedV path@(Path False [PathSegment "super" Nothing _] _)) = "pub(" <> printPath path False <> ")" +printVis (RestrictedV path@(Path False [PathSegment "self" Nothing _] _)) = "pub(" <> printPath path False <> ")" +printVis (RestrictedV path) = "pub(" <> "in" <+> printPath path False <> ")" +printVis InheritedV = mempty + +-- | Print a foreign item (@print_foreign_item@) +printForeignItem :: ForeignItem a -> Doc a +printForeignItem (ForeignFn attrs vis ident decl generics x) = annotate x $ + printOuterAttrs attrs <#> printFn decl Normal NotConst Rust (Just ident) generics vis Nothing +printForeignItem (ForeignStatic attrs vis ident ty mut x) = annotate x $ + printOuterAttrs attrs <#> printVis vis <+> "static" <+> printMutability mut <+> printIdent ident <> ":" <+> printType ty <> ";" +printForeignItem (ForeignTy attrs vis ident x) = annotate x $ + printOuterAttrs attrs <#> printVis vis <+> "type" <+> printIdent ident <> ";" + +-- | Print a struct definition (@print_struct@) +printStruct :: VariantData a -> Generics a -> Ident -> Bool -> Bool -> Doc a +printStruct structDef generics ident printFinalizer annotateGenerics = + printIdent ident <> gen + <> case (structDef, whereClause generics) of + (StructD fields x, WhereClause [] _) -> annotate x $ space <> block Brace False "," mempty (printStructField `map` fields) + (StructD fields x, wc) -> annotate x $ line <> printWhereClause True wc <#> block Brace False "," mempty (printStructField `map` fields) + (TupleD fields x, WhereClause [] _) -> annotate x $ block Paren True "," mempty (printStructField `map` fields) <> when printFinalizer ";" + (TupleD fields x, wc) -> annotate x $ block Paren True "," mempty (printStructField `map` fields) <#> printWhereClause (not printFinalizer) wc <> when printFinalizer ";" + (UnitD x, WhereClause [] _) -> annotate x $ when printFinalizer ";" + (UnitD x, wc) -> annotate x $ line <> printWhereClause (not printFinalizer) wc <> when printFinalizer ";" + where gen = if annotateGenerics then printGenerics generics else unAnnotate (printGenerics generics) + +-- | Print a struct field +printStructField :: StructField a -> Doc a +printStructField (StructField i v t as x) = annotate x (printOuterAttrs as <#> hsep [ printVis v, perhaps (\i' -> printIdent i' <> ":") i, printType t ]) + +-- | Pretty print unsafety (@print_unsafety@) +printUnsafety :: Unsafety -> Doc a +printUnsafety Normal = mempty +printUnsafety Unsafe = "unsafe" + +-- | Print an enum definition (@print_enum_def@) +printEnumDef :: [Variant a] -> Generics a -> Ident -> Visibility a -> Doc a +printEnumDef variants generics ident vis = + case whereClause generics of + WhereClause [] _ -> leading <+> lagging + wc -> leading <#> printWhereClause True wc <#> lagging + where leading = printVis vis <+> "enum" <+> (printIdent ident <> printGenerics generics) + lagging = block Brace False "," mempty [ printOuterAttrs as <#> printVariant v | v@(Variant _ as _ _ _) <- variants ] + +-- | Print a variant (@print_variant@) +printVariant :: Variant a -> Doc a +printVariant (Variant i _ _data e x) = annotate x (body <+> disc) + where body = printStruct _data (Generics [] [] (WhereClause [] undefined) undefined) i False False + disc = perhaps (\e' -> "=" <+> printExpr e') e + +-- | Print a where clause (@print_where_clause@). The 'Bool' argument indicates whether to have a +-- trailing comma or not. +printWhereClause :: Bool -> WhereClause a -> Doc a +printWhereClause trailing (WhereClause predicates x) + | null predicates = mempty + | trailing = annotate x ("where" <#> block NoDelim False "," mempty (printWherePredicate `map` predicates)) + | otherwise = annotate x ("where" <#> block NoDelim False mempty mempty (punctuate "," (printWherePredicate `map` predicates))) + +-- | Print a where clause predicate +printWherePredicate :: WherePredicate a -> Doc a +printWherePredicate (BoundPredicate blt ty bds y) = annotate y (printFormalLifetimeList blt <+> printType ty <> printBounds ":" bds) +printWherePredicate (RegionPredicate lt bds y) = annotate y (printLifetimeBounds lt bds) +printWherePredicate (EqPredicate lhs rhs y) = annotate y (printType lhs <+> "=" <+> printType rhs) + +-- | Print a function (@print_fn@) +printFn :: FnDecl a -> Unsafety -> Constness -> Abi -> Maybe Ident -> Generics a -> Visibility a -> Maybe (Block a, [Attribute a]) -> Doc a +printFn decl unsafety constness abi name generics vis blkAttrs = + printFnHeaderInfo unsafety constness abi vis + <+> perhaps printIdent name + <> printGenerics generics + <> printFnArgsAndRet decl + <+#> whereBlk + where + ((<+#>), whereBlk) = case (whereClause generics, blkAttrs) of + (WhereClause [] _, Nothing) -> ((<>), ";") + (WhereClause [] _, Just (blk, attrs)) -> ((<+>), printBlockWithAttrs False blk attrs) + (wc, Nothing) -> ((<#>), printWhereClause False wc <> ";") + (wc, Just (blk, attrs)) -> ((<#>), printWhereClause True wc <#> printBlockWithAttrs False blk attrs) + + +-- | Print the function arguments and the return type (@print_fn_args_and_ret@) +printFnArgsAndRet :: FnDecl a -> Doc a +printFnArgsAndRet (FnDecl args ret var x) + | var = annotate x (block Paren True mempty mempty ([ printArg a False <> "," | a <- args ] ++ [ "..." ]) <+> ret') + | otherwise = annotate x (block Paren True "," mempty [ printArg a False | a <- args ] <+> ret') + where ret' = perhaps (\t -> "->" <+> printType t) ret + +-- | Print an argument (@print_arg@) +printArg :: Arg a -> Bool -> Doc a +printArg (Arg (Just pat) (Infer x') x) True = annotate x $ annotate x' (printPat pat) +printArg (Arg Nothing ty x) _ = annotate x (printType ty) +printArg (Arg (Just pat) ty x) _ = annotate x (printPat pat <> ":" <+> printType ty) +printArg (SelfValue mut x) _ = annotate x (printMutability mut <+> "self") +printArg (SelfRegion lt mut x) _ = annotate x ("&" <> hsep [perhaps printLifetime lt, printMutability mut, "self"]) +printArg (SelfExplicit ty mut x) _ = annotate x (printMutability mut <+> "self" <> ":" <+> printType ty) + +-- | Print a lifetime (@print_lifetime@) +printLifetime :: Lifetime a -> Doc a +printLifetime (Lifetime n x) = annotate x ("'" <> printName n) + +-- | Print a lifetime definition +printLifetimeDef :: LifetimeDef a -> Doc a +printLifetimeDef (LifetimeDef as lt bds x) = annotate x (printOuterAttrs as <+> printLifetimeBounds lt bds) + +-- | Print mutability (@print_mutability@) +printMutability :: Mutability -> Doc a +printMutability Mutable = "mut" +printMutability Immutable = mempty + +-- | Like 'printMutability', but prints @const@ in the immutable case +printFullMutability :: Mutability -> Doc a +printFullMutability Mutable = "mut" +printFullMutability Immutable = "const" + +-- | Print a pattern (@print_pat@) +printPat :: Pat a -> Doc a +printPat (WildP x) = annotate x "_" +printPat (IdentP bm p s x) = annotate x (printBindingMode bm <+> printIdent p <+> perhaps (\p' -> "@" <+> printPat p') s) +printPat (StructP p fs False x) = annotate x (printPath p True <+> block Brace True "," mempty (printFieldPat `map` fs)) +printPat (StructP p fs True x) = annotate x (printPath p True <+> block Brace True mempty mempty ([ printFieldPat f <> "," | f <- fs ] ++ [ ".." ])) +printPat (TupleStructP p es Nothing x) = annotate x (printPath p True <> "(" <> commas es printPat <> ")") +printPat (TupleStructP p es (Just d) x) = let (before,after) = splitAt d es + in annotate x (printPath p True <> "(" <> commas before printPat <> when (d /= 0) "," + <+> ".." <> when (d /= length es) ("," <+> commas after printPat) <> ")") +printPat (PathP Nothing path x) = annotate x (printPath path True) +printPat (PathP (Just qself) path x) = annotate x (printQPath path qself True) +printPat (TupleP [elt] Nothing x) = annotate x ("(" <> printPat elt <> ",)") +printPat (TupleP elts Nothing x) = annotate x ("(" <> commas elts printPat <> ")") +printPat (TupleP elts (Just ddpos) _) = let (before,after) = splitAt ddpos elts + in "(" <> commas before printPat <> unless (null before) "," + <+> ".." <> unless (null after) ("," <+> commas after printPat) <> ")" +printPat (BoxP inner x) = annotate x ("box" <+> printPat inner) +printPat (RefP inner mutbl x) = annotate x ("&" <> printMutability mutbl <+> printPat inner) +printPat (LitP expr x) = annotate x (printExpr expr) +printPat (RangeP lo hi x) = annotate x (printExpr lo <+> "..=" <+> printExpr hi) +printPat (SliceP pb Nothing pa x) = annotate x ("[" <> commas (pb ++ pa) printPat <> "]") +printPat (SliceP pb (Just ps) pa x) = annotate x ("[" <> commas pb printPat <> ps' <+> commas pa printPat <> "]") + where ps' = hcat [ unless (null pb) "," + , space + , case ps of WildP{} -> mempty + _ -> printPat ps + , ".." + , unless (null pa) "," + ] +printPat (MacP m x) = annotate x (printMac Paren m) + +-- | Print a field pattern +printFieldPat :: FieldPat a -> Doc a +printFieldPat (FieldPat i p x) = annotate x (perhaps (\i -> printIdent i <> ":") i <+> printPat p) + +-- | Print a binding mode +printBindingMode :: BindingMode -> Doc a +printBindingMode (ByRef mutbl) = "ref" <+> printMutability mutbl +printBindingMode (ByValue Immutable) = mempty +printBindingMode (ByValue Mutable) = "mut" + +-- | Print the prefix of a function - all the stuff up to and including @fn@ (@print_fn_header_info@) +printFnHeaderInfo :: Unsafety -> Constness -> Abi -> Visibility a -> Doc a +printFnHeaderInfo u c a v = hsep [ printVis v, case c of { Const -> "const"; _ -> mempty } + , printUnsafety u, printAbi a, "fn" ] + +-- | Print the ABI +printAbi :: Abi -> Doc a +printAbi Rust = mempty +printAbi abi = "extern" <+> "\"" <> root abi <> "\"" + where + root :: Abi -> Doc a + root Cdecl = "cdecl" + root Stdcall = "stdcall" + root Fastcall = "fastcall" + root Vectorcall = "vectorcall" + root Aapcs = "aapcs" + root Win64 = "win64" + root SysV64 = "sysv64" + root PtxKernel = "ptx-kernel" + root Msp430Interrupt = "msp430-interrupt" + root X86Interrupt = "x86-interrupt" + root Rust = "Rust" + root C = "C" + root System = "system" + root RustIntrinsic = "rust-intrinsic" + root RustCall = "rust-call" + root PlatformIntrinsic = "platform-intrinsic" + root Unadjusted = "unadjusted" + + +-- | Print the interior of a module given the list of items and attributes in it (@print_mod@) +printMod :: Ident -> Maybe [Item a] -> [Attribute a] -> Doc a +printMod i (Just items) attrs = printIdent i <+> block Brace False mempty (printInnerAttrs attrs) (punctuate line' (printItem `map` items)) +printMod i Nothing _ = printIdent i <> ";" + +-- | Print the interior of a foreign module given the list of items and attributes in it (@print_mod@) +printForeignMod :: [ForeignItem a] -> [Attribute a] -> Doc a +printForeignMod items attrs = block Brace False mempty (printInnerAttrs attrs) (printForeignItem `map` items) + +-- | Print generics (@print_generics@) +-- Remark: we are discarding the where clause because it gets printed seperately from the rest of +-- the generic. +printGenerics :: Generics a -> Doc a +printGenerics (Generics lifetimes tyParams _ x) + | null lifetimes && null tyParams = mempty + | otherwise = let lifetimes' = printLifetimeDef `map` lifetimes + bounds' = [ printTyParam param | param<-tyParams ] + in annotate x (group ("<" <##> ungroup (block NoDelim True "," mempty (lifetimes' ++ bounds')) <##> ">")) + +-- | Print a poly-trait ref (@print_poly_trait_ref@) +printPolyTraitRef :: PolyTraitRef a -> Doc a +printPolyTraitRef (PolyTraitRef lts tref x) = annotate x (printFormalLifetimeList lts <+> printTraitRef tref) + +-- | Print a trait ref (@print_trait_ref@) +printTraitRef :: TraitRef a -> Doc a +printTraitRef (TraitRef path) = printPath path False + +-- | Print a path parameter and signal whether its generic (if any) should start with a colon (@print_path_parameters@) +printPathParameters :: PathParameters a -> Bool -> Doc a +printPathParameters (Parenthesized ins out x) colons = annotate x $ + when colons "::" <> parens (commas ins printType) <+> perhaps (\t -> "->" <+> printType t) out +printPathParameters (AngleBracketed lts tys bds x) colons = annotate x (when colons "::" <> "<" <> hsep (punctuate "," (lts' ++ tys' ++ bds')) <> ">") + where + lts' = printLifetime <$> lts + tys' = printType <$> tys + bds' = (\(ident,ty) -> printIdent ident <+> "=" <+> printType ty) <$> bds + + +-- | Print a path, specifiying explicitly whether to include colons (@::@) before generics +-- or not (so expression style or type style generics) (@print_path@) +printPath :: Path a -> Bool -> Doc a +printPath (Path global segs x) colons = annotate x (when global "::" <> hcat (punctuate "::" (map (`printSegment` colons) segs))) + +-- | Print a path segment +printSegment :: PathSegment a -> Bool -> Doc a +printSegment (PathSegment i ps x) colons = annotate x (printIdent i <> params) + where params = perhaps (\p -> printPathParameters p colons) ps + + +-- | Print a qualified path, specifiying explicitly whether to include colons (@::@) before +-- generics or not (so expression style or type style generics) (@print_qpath@) +printQPath :: Path a -> QSelf a -> Bool -> Doc a +printQPath (Path global segs x) (QSelf ty n) colons = hcat [ "<", printType ty <+> aliasedDoc, ">", "::", restDoc ] + where + (aliased, rest) = splitAt n segs + + aliasedDoc = case aliased of + [] -> mempty + segs -> "as" <+> printPath (Path global segs x) False + + restDoc = printPath (Path False rest x) colons + +-- | Print a use tree +printUseTree :: UseTree a -> Doc a +printUseTree (UseTreeSimple p Nothing x) = annotate x (printPath p True) +printUseTree (UseTreeSimple p (Just i) x) = annotate x (printPath p True <+> "as" <+> printIdent i) +printUseTree (UseTreeGlob p@(Path _ [] _) x) = annotate x (printPath p True <> "*") +printUseTree (UseTreeGlob p x) = annotate x (printPath p True <> "::*") +printUseTree (UseTreeNested p@(Path _ [] _) n x) = annotate x (printPath p True <> "{" <> hcat (punctuate ", " (map printUseTree n)) <> "}") +printUseTree (UseTreeNested p n x) = annotate x (printPath p True <> "::{" <> hcat (punctuate ", " (map printUseTree n)) <> "}") + +-- | Print a type parameters (@print_ty_param@) +printTyParam :: TyParam a -> Doc a +printTyParam (TyParam as i bds def x) = annotate x $ hsep + [ printOuterAttrs as + , printIdent i <> printBounds ":" bds + , perhaps (\def' -> "=" <+> printType def') def + ] + +-- | Print lifetime bounds (@print_lifetime_bounds@) +printLifetimeBounds :: Lifetime a -> [Lifetime a] -> Doc a +printLifetimeBounds lifetime bounds = printLifetime lifetime + <> unless (null bounds) (":" <+> foldr1 (\x y -> x <+> "+" <+> y) (printLifetime <$> bounds)) + diff --git a/src/Language/Rust/Pretty/Literals.hs b/src/Language/Rust/Pretty/Literals.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Pretty/Literals.hs @@ -0,0 +1,138 @@ +{-| +Module : Language.Rust.Pretty.Literals +Description : Parsing literals +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : portable + +Functions for pretty printing literals. +-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Rust.Pretty.Literals ( + printLit, + printLitSuffix, +) where + +import Language.Rust.Syntax.AST +import Language.Rust.Pretty.Util + +import Data.Text.Prettyprint.Doc ( hcat, annotate, (<>), Doc, pretty, group, hardline, flatAlt ) + +import Data.Char ( intToDigit, ord, chr ) +import Data.Word ( Word8 ) + +-- | Print a literal (@print_literal@) +printLit :: Lit a -> Doc a +printLit lit = noIndent $ case lit of + Str str Cooked s x -> annotate x (hcat [ "\"", group (foldMap (escapeChar True) str), "\"", suf s ]) + Str str (Raw m) s x -> annotate x (hcat [ "r", pad m, "\"", string hardline str, "\"", pad m, suf s ]) + ByteStr str Cooked s x -> annotate x (hcat [ "b\"", group (foldMap (escapeByte True) str), "\"", suf s ]) + ByteStr str (Raw m) s x -> annotate x (hcat [ "br", pad m, "\"", string hardline (map byte2Char str), "\"", pad m, suf s ]) + Char c s x -> annotate x (hcat [ "'", escapeChar False c, "'", suf s ]) + Byte b s x -> annotate x (hcat [ "b'", escapeByte False b, "'", suf s ]) + Int b i l s x -> annotate x (hcat [ printIntLit i b l, suf s ]) + Float d s x -> annotate x (hcat [ pretty d, suf s ]) + Bool True s x -> annotate x (hcat [ "true", suf s ]) + Bool False s x -> annotate x (hcat [ "false", suf s ]) + where + pad :: Int -> Doc a + pad m = pretty (replicate m '#') + + suf :: Suffix -> Doc a + suf = printLitSuffix + +-- | Print literal suffix +printLitSuffix :: Suffix -> Doc a +printLitSuffix Unsuffixed = mempty +printLitSuffix Is = "isize" +printLitSuffix I8 = "i8" +printLitSuffix I16 = "i16" +printLitSuffix I32 = "i32" +printLitSuffix I64 = "i64" +printLitSuffix I128 = "i128" +printLitSuffix Us = "usize" +printLitSuffix U8 = "u8" +printLitSuffix U16 = "u16" +printLitSuffix U32 = "u32" +printLitSuffix U64 = "u64" +printLitSuffix U128 = "u128" +printLitSuffix F32 = "f32" +printLitSuffix F64 = "f64" + +-- | Print an integer literal +printIntLit :: Integer -> IntRep -> String -> Doc a +printIntLit i r len + | i < 0 = "-" <> baseRep r <> printIntPrefix (show $ toNBase (abs i) (baseVal r)) len <> toNBase (abs i) (baseVal r) + | i == 0 = baseRep r <> printIntPrefix "" len -- <> "0" + | otherwise = baseRep r <> printIntPrefix (show $ toNBase (abs i) (baseVal r)) len <> toNBase (abs i) (baseVal r) + where + baseRep :: IntRep -> Doc a + baseRep Bin = "0b" + baseRep Oct = "0o" + baseRep Dec = mempty + baseRep Hex = "0x" + + baseVal :: IntRep -> Integer + baseVal Bin = 2 + baseVal Oct = 8 + baseVal Dec = 10 + baseVal Hex = 16 + + printIntPrefix :: String -> String -> Doc a + printIntPrefix out ('0':'b':rest) = pretty $ replicate ((length rest) - (length out)) '0' + printIntPrefix out ('0':'o':rest) = pretty $ replicate ((length rest) - (length out)) '0' + printIntPrefix out ('0':'x':rest) = pretty $ replicate ((length rest) - (length out)) '0' + printIntPrefix out rest = pretty $ replicate ((length rest) - (length out)) '0' + -- = pretty $ take (fromIntegral $ l - (fromIntegral thing)) (repeat '0') + + toDigit :: Integer -> Char + toDigit l = "0123456789ABCDEF" !! fromIntegral l + + toNBase :: Integer -> Integer -> Doc a + l `toNBase` b | l < b = pretty (toDigit l) + | otherwise = let ~(d,e) = l `quotRem` b in toNBase d b <> pretty (toDigit e) + + +-- | Extend a byte into a unicode character +byte2Char :: Word8 -> Char +byte2Char = chr . fromIntegral + +-- | Constrain a unicode character to a byte +-- This assumes the character is in the right range already +char2Byte :: Char -> Word8 +char2Byte = fromIntegral . ord + +-- | Escape a byte. Based on @std::ascii::escape_default@. +-- +-- If the first argument is true, newlines may become a literal newline characters if the string is +-- too long. +escapeByte :: Bool -> Word8 -> Doc a +escapeByte nl w8 = case byte2Char w8 of + '\t' -> "\\t" + '\r' -> "\\r" + '\\' -> "\\\\" + '\'' -> "\\'" + '"' -> "\\\"" + '\n'| nl -> flatAlt hardline "\\n" + | otherwise -> "\\n" + c | 0x20 <= w8 && w8 <= 0x7e -> pretty c + _ -> "\\x" <> padHex 2 w8 + +-- | Escape a unicode character. Based on @std::ascii::escape_default@. +-- +-- If the first argument is true, newlines may become a literal newline characters if the string is +-- too long. +escapeChar :: Bool -> Char -> Doc a +escapeChar nl c | c <= '\x7f' = escapeByte nl (char2Byte c) + | c <= '\xffff' = "\\u{" <> padHex 4 (ord c) <> "}" + | otherwise = "\\u{" <> padHex 6 (ord c) <> "}" + +-- | Convert a number to its padded hexadecimal form +padHex :: Integral a => Int -> a -> Doc b +padHex i 0 = pretty (replicate i '0') +padHex i m = let (m',r) = m `divMod` 0x10 + in padHex (i-1) m' <> pretty (intToDigit (fromIntegral r)) + diff --git a/src/Language/Rust/Pretty/Resolve.hs b/src/Language/Rust/Pretty/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Pretty/Resolve.hs @@ -0,0 +1,1515 @@ +{-| +Module : Language.Rust.Pretty.Resolve +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : portable + +/NOTE:/ the following uses hithero unimplemented antiquoting syntax + +An AST and its text form /should/ be completely isomorphic, with @parse@ and @pretty@ being the +functions allowing you to go back and forth between these forms. Unfortunately, this cannot really +be the case. The AST form can express programs which cannot be literally pretty printed and still +make sense. Sometimes, extra parens or semicolons need to be added. + +== Simple example + +For example, consider the following interaction + +>>> import Language.Rust.Quote +>>> import Language.Rust.Pretty +>>> :set -XQuasiQuotes +>>> x = [expr| 2 + 3 |] +>>> y = [expr| 1 * $x |] +>>> pretty y +0 * 1 + 2 + +The problem is that we haven't introduced the paren AST node (which we would have gotten had we +parsed @1 * (2 + 3)@. This is where 'resolve' steps in. + +>>> Right y' = resolve y +>>> pretty y' +0 * (1 + 2) + +== More involved example + +From the above, it is tempting to say: your pretty printer should be smarter! However, things are +not always so simple. Consider the less obvious example: + +>>> fnBody = [expr| { let y = x; x += 1; y } + x |] +>>> fn = [item| fn foo(mut x: i32) -> i32 { $fnBody } |] +>>> pretty fn +fn foo(mut x: i32) -> i32 { + { let y = x; x += 1; y } + x +} + +This is clearly not the desired output - this won't compile with @rustc@ because of an invariant in +blocks: if the block ends in an expression, that expression cannot start with a block. To fix this, +we call 'resolve' on the AST before pretty printing it. + +>>> Right fn' = resolve fn +>>> pretty fn' +fn foo(mut x: i32) -> i32 { + ({ let y = x; x += 1; y }) + x +} + +And now we have generated valid code. + +-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedLists #-} + +module Language.Rust.Pretty.Resolve ( + Resolve(resolve, resolve', resolveVerbose), + Issue(..), + Severity(..), + ResolveFail(..), +) where + +import Language.Rust.Syntax + +import Language.Rust.Data.Ident ( Ident(..), mkIdent, IdentName(..) ) +import Language.Rust.Data.InputStream ( inputStreamFromString ) +import Language.Rust.Data.Position ( initPos, Spanned(..) ) + +import Language.Rust.Parser.Lexer ( lexTokens, lexToken ) +import Language.Rust.Parser.ParseMonad ( execParser ) + +import Control.Exception ( throw, Exception ) +import Control.Monad ( when ) +import Control.Monad.Trans.RWS + +import Data.Dynamic ( Dynamic, toDyn, Typeable ) +import Data.List ( find ) +import Language.Rust.Parser.NonEmpty ( NonEmpty(..) ) +import qualified Language.Rust.Parser.NonEmpty as N +import qualified Data.List.NonEmpty as N2 ( NonEmpty(..) ) +import Data.Maybe ( fromJust ) +import Data.Semigroup ( (<>) ) + +{-# ANN module "HLint: ignore Reduce duplication" #-} + +-- TODO: +-- * See where attributes are not allowed +-- * resolve in a better monad (`type ResolveM a = ReaderT [Doc] (Except ErrorType a)`) + +-- | Diagnostic for how severe an 'Issue' is. +data Severity + = Clean -- ^ Everything is normal (this variant is returned when there was nothing to resolve) + | Warning -- ^ There is something fishy looking (AST is valid, but may not be what you expect) + | Correction -- ^ The AST was invalid, but in a way that could be corrected + | Error -- ^ The AST was invalid in some way that could not be automatically fixed + deriving (Eq, Ord, Enum, Bounded, Show) + +-- | Localized information about an issue in a syntax tree. +data Issue = Issue + { description :: String + -- ^ Description of the issue + + , severity :: !Severity + -- ^ Severity of the issue + + , location :: [Dynamic] + -- ^ The first element in this list is the syntax tree where the issue occurs. The next elements + -- are increasingly zoomed out syntax trees centered on the first element. In lieu of positional + -- information, this provides a next best way of debugging exactly where the problem is. + } deriving (Show) + +-- | Monad in which to resolve a syntax tree. +-- +-- * Reader is @['Dynamic']@ storing the path from root to the current syntax tree node +-- * Writer is @['Issue']@ accumulating issues met through the traversal +-- * State is 'Severity' accumulating the most severe 'Issue' found so far in the traversal +-- +type ResolveM = RWS [Dynamic] [Issue] Severity + +-- | Log an 'Issue' +logIssue :: String -- ^ description of the issue + -> Severity -- ^ severity of the issue + -> ResolveM () +logIssue desc sev = do + loc <- ask + tell [Issue desc sev loc] + modify (max sev) + +-- | Log a 'Warning' +warn :: String -> ResolveM () +warn desc = desc `logIssue` Warning + +-- | Log a 'Correction' +correct :: String -> ResolveM () +correct desc = desc `logIssue` Correction + +-- | Log an 'Error' +err :: a -> String -> ResolveM a +err x desc = (desc `logIssue` Error) *> pure x + +-- | Enter a new syntax tree +scope :: Typeable a => a -> ResolveM b -> ResolveM b +scope x = local (toDyn x :) + +-- | Exceptions that occur during resolving. Unlike parse errors, we don't have positional +-- information. Instead, we try to provide some context via a list of syntax trees which +-- let you "zoom out" from the problematic node. +data ResolveFail = ResolveFail [Dynamic] String deriving (Typeable) + +-- | Does not show context information +instance Show ResolveFail where + showsPrec p (ResolveFail _ msg) = showParen (p >= 11) (showString expl) + where expl = unwords [ "invalid AST", "(" ++ msg ++ ")" ] + +instance Exception ResolveFail + + +-- | Since it is possible to have well-typed Haskell expressions which represent invalid Rust ASTs, +-- it is convenient to fix, warn, or fail ASTs before printing them. The 'Resolve' typeclass +-- provides such a facility. +-- +-- A non-exhaustive list of the more obvious issues it covers: +-- +-- * missing parens +-- * invalid identifiers +-- * invalid paths (for example, generic arguments on a module path) +-- * inner attributes on things that support only outer attributes (and vice-versa) +-- +class Resolve a where + -- | Convert some value to its /resolved/ form. Informally, resolving a value involves checking + -- that its invariants hold and, if they don't, report an error message or adjust the value so + -- that the invariant holds. + -- + -- A value of a type satsifying 'Language.Rust.Parser.Parse' and 'Language.Rust.Pretty.Pretty' + -- is resolved if @'Language.Rust.Parser.parse' . 'Language.Rust.Pretty.pretty'@ is an identity + -- operation on it. We further expect that 'resolve' be an identity operation on any output of + -- 'Language.Rust.Parser.parse'. + resolve :: a -> Either ResolveFail a + resolve x = case runRWS (resolveM x) [] Clean of + (_, Error, issues) -> + let Issue desc _ locs = fromJust (find (\i -> severity i == Error) issues) + in Left (ResolveFail locs desc) + (t, _, _) -> Right t + + -- | Same as 'resolve', but throws a 'ResolveFail' exception if it cannot resolve. Although + -- this function should not be used, it summarizes nicely the laws around 'Resolve': + -- + -- prop> parse' . pretty' . resolve' == id + -- prop> resolve' . parse' = parse' + -- + resolve' :: a -> a + resolve' = either throw id . resolve + + -- | Run resolution and get back the altered syntax tree, the highest 'Severity' of issues, and + -- the list of issues found. This allows you to see what corrections were applied to the tree. + -- If the output severity is 'Error', the syntax tree returned will still be invalid. + resolveVerbose :: a -> (a, Severity, [Issue]) + resolveVerbose x = runRWS (resolveM x) [] Clean + + -- | Internal recursive helper + resolveM :: a -> ResolveM a + + +-- | A valid sourcefile needs +-- +-- * the shebang to be one-line not conflicting with attributes +-- * the attributes to be inner +-- * the items to be 'ModItems' +-- +resolveSourceFile :: (Typeable a, Monoid a) => SourceFile a -> ResolveM (SourceFile a) +resolveSourceFile s@(SourceFile sh as is) = scope s $ do + sh' <- case sh of + Just ('[':_) -> err sh "shebang cannot start with `['" + Just s' | '\n' `elem` s' -> err sh "shebang cannot contain newlines" + _ -> pure sh + as' <- traverse (resolveAttr InnerAttr) as + is' <- traverse (resolveItem ModItem) is + pure (SourceFile sh' as' is') + +instance (Typeable a, Monoid a) => Resolve (SourceFile a) where resolveM = resolveSourceFile + +-- | An identifier can be invalid if +-- +-- * it does not lex into an identifier +-- * it is a keyword +-- +resolveIdent :: Ident -> ResolveM Ident +resolveIdent i@(Ident (Name s) r _) = + scope i $ case toks of + Right [Spanned (IdentTok i') _] + | i /= i' -> err i ("identifier `" ++ s ++ "' does not lex properly") + | i `elem` keywords && not r -> do + correct ("identifier `" ++ s ++ "' is a keyword") + pure i{ raw = True } + | otherwise -> pure i + _ -> err i ("identifier `" ++ s ++ "' does not lex properly") + + where + + keywords = map mkIdent $ words "as box break const continue crate else enum extern false fn for\ + \ if impl in let loop match mod move mut pub ref return Self self\ + \ static struct super trait true type unsafe use where while\ + \ abstract alignof become do final macro offsetof override priv\ + \ proc pure sizeof typeof unsized virtual yield" + + s' = (if r then "r#" else "") ++ s + toks = execParser (lexTokens lexToken) (inputStreamFromString s') initPos + +resolveIdent i@(Ident (HaskellName _) _ _) = pure i + +instance Resolve Ident where resolveM = resolveIdent + + +---------------- +-- Attributes -- +---------------- + +-- | Attribute type to against which to resolve +data AttrType + = EitherAttr -- ^ inner or outer attribute + | InnerAttr -- ^ only innner attribute + | OuterAttr -- ^ only outer attribute + +-- | A sugared doc is invalid if +-- +-- * the expected attribute style does not match the actual one +-- * its content starts with a '/' / '*' when it is an outer line / inline comment +-- * it is a line comment whose content spans multiple lines +-- +-- A regular attribute is invalid if +-- +-- * the expected attribute style does not match the actual one +-- * the underlying path / tokenstream are invalid +-- * the tokenstream starts with a '::' +-- +resolveAttr :: (Typeable a, Monoid a) => AttrType -> Attribute a -> ResolveM (Attribute a) +resolveAttr typ s@(SugaredDoc sty inl con x) = scope s $ do + sty' <- case (typ, sty) of + (OuterAttr, Inner) -> correct "inner attribute was turned into outer attribute" *> pure Outer + (InnerAttr, Outer) -> correct "outer attribute was turned into inner attribute" *> pure Inner + (_, sty' ) -> pure sty' + con' <- case (con, inl, sty') of + ('/':_, False, Outer) -> correct "the content of an outer (line) doc comment cannot start with a `/'" *> pure (' ':con) + ('*':_, True, Outer) -> correct "the contents of an outer (inline) doc comment cannot start with a a`*'" *> pure (' ':con) + (_, False, _) | '\n' `elem` con -> err con "a doc comment that is not inline cannot have multiple lines" + _ -> pure con + pure (SugaredDoc sty' inl con' x) + +resolveAttr typ a@(Attribute sty p ts x) = scope a $ do + sty' <- case (typ, sty) of + (OuterAttr, Inner) -> correct "inner attribute was turned into outer attribute" *> pure Outer + (InnerAttr, Outer) -> correct "outer attribute was turned into inner attribute" *> pure Inner + (_, sty' ) -> pure sty' + p' <- resolvePath ModPath p + ts' <- resolveTokenStream ts + case nextTok ts' of + Just ModSep -> err () "the first token in the token stream `::' will be considered part of the path" + _ -> pure () + pure (Attribute sty' p' ts' x) + + where + + nextTok :: TokenStream -> Maybe Token + nextTok (Tree (Token _ t)) = Just t + nextTok (Tree (Delimited _ d _)) = Just (OpenDelim d) + nextTok (Stream (s:_)) = nextTok s + nextTok (Stream []) = Nothing + +instance (Typeable a, Monoid a) => Resolve (Attribute a) where resolveM = resolveAttr EitherAttr + + +-------------- +-- Literals -- +-------------- + +-- | A literal cannot be invalid +resolveLit :: Lit a -> ResolveM (Lit a) +resolveLit = pure + +instance Resolve (Lit a) where resolveM = resolveLit + + +----------- +-- Paths -- +----------- + +-- | Recall that paths are reused for expressions, modules, and types. However, these paths have +-- different underlying invariants. +data PathType + = ModPath + | UsePath -- ^ similar to 'ModPath', but can have no segments + | TypePath + | ExprPath + deriving (Eq) + +instance Show PathType where + show ModPath = "mod path" + show UsePath = "use tree path" + show TypePath = "type path" + show ExprPath = "expression path" + +-- | A path can be invalid if +-- +-- * it has path parameters of the wrong type +-- * it has identifiers not meant for paths +-- +-- TODO: guard against no path segments... +resolvePath :: (Typeable a, Monoid a) => PathType -> Path a -> ResolveM (Path a) +resolvePath t p@(Path _ [] _) | t /= UsePath = scope p $ err p "path must have at least one segment" +resolvePath t p@(Path g segs x) = scope p $ + if null [ () | PathSegment _ (Just a) _ <- segs, not (isParamsForPath t a) ] + then Path g <$> traverse resolveSeg segs <*> pure x + else err p "path parameter is not valid for this type of path" + where + resolveSeg :: (Typeable a, Monoid a) => PathSegment a -> ResolveM (PathSegment a) + resolveSeg (PathSegment i a x') = do + i' <- case i of + Ident (Name "self") False _ -> pure i + Ident (Name "Self") False _ -> pure i + Ident (Name "super") False _ -> pure i + Ident (Name "crate") False _ -> pure i + _ -> resolveIdent i + a' <- traverse resolvePathParameters a + pure (PathSegment i' a' x') + + isParamsForPath :: PathType -> PathParameters a -> Bool + isParamsForPath t' AngleBracketed{} = t' `elem` ([TypePath, ExprPath] :: [PathType]) + isParamsForPath t' Parenthesized{} = t' `elem` ([TypePath] :: [PathType]) + +-- | There are three potential instances for resolving a path (depending on what type it is). The +-- 'Resolve' instance for 'Path' will let through any path. +instance (Typeable a, Monoid a) => Resolve (Path a) where + resolveM = resolvePath TypePath + +-- | A path parameter can be invalid if any of its constituent components are invalid +resolvePathParameters :: (Typeable a, Monoid a) => PathParameters a -> ResolveM (PathParameters a) +resolvePathParameters p@(AngleBracketed lts tys bds x) = scope p $ do + lts' <- traverse resolveLifetime lts + tys' <- traverse (resolveTy AnyType) tys + bds' <- traverse (\(i,t) -> (,) <$> resolveIdent i <*> resolveTy NoSumType t) bds + pure (AngleBracketed lts' tys' bds' x) +resolvePathParameters p@(Parenthesized tys tym x) = scope p $ do + tys' <- traverse (resolveTy AnyType) tys + tym' <- traverse (resolveTy NoSumType) tym + pure (Parenthesized tys' tym' x) + +instance (Typeable a, Monoid a) => Resolve (PathParameters a) where resolveM = resolvePathParameters + +-- | A QSelf by itself is only invalid when the underlying type is +resolveQSelf :: (Typeable a, Monoid a) => QSelf a -> ResolveM (QSelf a) +resolveQSelf q@(QSelf t p) = scope q (QSelf <$> resolveTy AnyType t <*> pure p) + +instance (Typeable a, Monoid a) => Resolve (QSelf a) where resolveM = resolveQSelf + + +----------- +-- Types -- +----------- + +-- | A lifetime can only be invalid if the underlying identifier is. Note that lifetimes cannot use +-- keywords. +resolveLifetime :: Typeable a => Lifetime a -> ResolveM (Lifetime a) +resolveLifetime l@(Lifetime n _) + | n == "static" = pure l + | n == "_" = pure l + | otherwise = scope l (resolveIdent (mkIdent n) *> pure l) + +instance Typeable a => Resolve (Lifetime a) where resolveM = resolveLifetime + +-- | A trait ref is invalid if the underlying type path is. +resolveTraitRef :: (Typeable a, Monoid a) => TraitRef a -> ResolveM (TraitRef a) +resolveTraitRef t@(TraitRef p) = scope t (TraitRef <$> resolvePath TypePath p) + +instance (Typeable a, Monoid a) => Resolve (TraitRef a) where resolveM = resolveTraitRef + +-- | There a a variety of constraints imposed on types, representing different invariants +data TyType + = AnyType -- ^ No restrictions + | NoSumType -- ^ Any type except for 'TraitObject' with a '+' + | PrimParenType -- ^ Types not starting with '<' or '(', or paren types with no sum types inside + | NoForType -- ^ Non-sum types not starting with a 'for' + +-- | Resolve a given type, and a constraint on it (see the parser 'Internal.y' for more details on +-- these cases). +resolveTy :: (Typeable a, Monoid a) => TyType -> Ty a -> ResolveM (Ty a) +-- TraitObject +resolveTy NoSumType o@(TraitObject b _) | length b > 1 = scope o (correct "added parens around trait object type" *> resolveTy NoSumType (ParenTy o mempty)) +resolveTy NoForType o@TraitObject{} = scope o (correct "added parens around trait object type" *> resolveTy NoForType (ParenTy o mempty)) +resolveTy _ o@(TraitObject bds@(NonEmpty (TraitTyParamBound{} N2.:| _)) x) + = scope o (TraitObject <$> traverse (resolveTyParamBound ModBound) bds <*> pure x) +resolveTy _ o@TraitObject{} = scope o (err o "first bound in trait object should be a trait bound") +-- ParenTy +resolveTy PrimParenType p@(ParenTy ty' x) = scope p (ParenTy <$> resolveTy NoSumType ty' <*> pure x) +resolveTy _ p@(ParenTy ty' x) = scope p (ParenTy <$> resolveTy AnyType ty' <*> pure x) +-- TupTy +resolveTy PrimParenType t@TupTy{} = scope t (correct "added parens around tuple type" *> resolveTy PrimParenType (ParenTy t mempty)) +resolveTy _ t@(TupTy tys x) = scope t (TupTy <$> traverse (resolveTy AnyType) tys <*> pure x) +-- ImplTrait +resolveTy _ i@(ImplTrait bds x) = scope i (ImplTrait <$> traverse (resolveTyParamBound ModBound) bds <*> pure x) +-- PathTy +resolveTy PrimParenType p@(PathTy (Just _) _ _) = scope p (correct "added parents around path type" *> resolveTy PrimParenType (ParenTy p mempty)) +resolveTy _ p@(PathTy q p'@(Path _ s _) x) = scope p $ + case q of + Just (QSelf _ i) + | 0 <= i && i < length s -> PathTy <$> traverse resolveQSelf q <*> resolvePath TypePath p' <*> pure x + | otherwise -> err p "index given by QSelf is outside the possible range" + Nothing -> PathTy Nothing <$> resolvePath TypePath p' <*> pure x +-- BareFn +resolveTy NoForType f@(BareFn _ _ (_:_) _ _) = scope f (correct "added parens around `for' function type" *> resolveTy NoForType (ParenTy f mempty)) +resolveTy _ f@(BareFn u a lts fd x) = scope f (BareFn u a <$> traverse resolveLifetimeDef lts <*> resolveFnDecl declTy GeneralArg fd <*> pure x) + where declTy = if a == C then VarNoSelf else NoSelf +-- Other types (don't care about the context) +resolveTy _ (Never x) = pure (Never x) +resolveTy _ p@(Ptr mut ty' x) = scope p (Ptr mut <$> resolveTy NoSumType ty' <*> pure x) +resolveTy _ r@(Rptr lt mut ty' x) = scope r (Rptr <$> traverse resolveLifetime lt <*> pure mut <*> resolveTy NoSumType ty' <*> pure x) +resolveTy _ t@(Typeof e x) = scope t (Typeof <$> resolveExpr AnyExpr e <*> pure x) +resolveTy _ (Infer x) = pure (Infer x) +resolveTy _ s@(Slice ty' x) = scope s (Slice <$> resolveTy AnyType ty' <*> pure x) +resolveTy _ a@(Array ty' e x) = scope a (Array <$> resolveTy AnyType ty' <*> resolveExpr AnyExpr e <*> pure x) +resolveTy _ m@(MacTy (Mac p t x) x') = scope m $ do + p' <- resolvePath TypePath p + MacTy <$> resolveMac TypePath (Mac p' t x) <*> pure x' + +instance (Typeable a, Monoid a) => Resolve (Ty a) where resolveM = resolveTy AnyType + +-- In some cases, the first argument of a function declaration may be a 'self' +data FnDeclType + = NoSelf -- ^ the first argument cannot be self + | VarNoSelf -- ^ the first argument cannot be self, and the function can be variadic + | AllowSelf -- ^ the first argument can be self + deriving (Eq) + +-- | A function declaration can be invalid if it has self arguments in the wrong places (or when it +-- shouldn't) +resolveFnDecl :: (Typeable a, Monoid a) => FnDeclType -> ArgType -> FnDecl a -> ResolveM (FnDecl a) +resolveFnDecl fn _ f@(FnDecl (s : _) _ _ _) | isSelfArg s && fn /= AllowSelf = scope f (err f "self argument is not allowed in this function declaration") +resolveFnDecl _ _ f@(FnDecl (_ : as) _ _ _) | any isSelfArg as = scope f (err f "self arguments must always be the first arguments") +resolveFnDecl fn _ f@(FnDecl _ _ True _) | fn /= VarNoSelf = scope f (err f "this function declaration cannot be variadic") +resolveFnDecl _ at f@(FnDecl as o v x) = scope f (FnDecl <$> traverse (resolveArg at) as <*> traverse (resolveTy AnyType) o <*> pure v <*> pure x) + +-- | Check whether an argument is one of the "self" forms +isSelfArg :: Arg a -> Bool +isSelfArg Arg{} = False +isSelfArg _ = True + +instance (Typeable a, Monoid a) => Resolve (FnDecl a) where resolveM = resolveFnDecl AllowSelf NamedArg + +-- | Only some type parameter bounds allow trait bounds to start with ? +data TyParamBoundType + = NoneBound -- ^ Don't allow '? poly_trait_ref' + | ModBound -- ^ Allow '? poly_trait_ref' + +-- | A type parameter bound is invalid if +-- +-- * an underlying lifetime or traitref is +-- * it is 'NoneBound' but is a trait bound with a '?' (as in 'ObjectTrait') +-- +resolveTyParamBound :: (Typeable a, Monoid a) => TyParamBoundType -> TyParamBound a -> ResolveM (TyParamBound a) +resolveTyParamBound _ b@(RegionTyParamBound lt x) = scope b (RegionTyParamBound <$> resolveLifetime lt <*> pure x) +resolveTyParamBound NoneBound b@(TraitTyParamBound _ Maybe _) = scope b (err b "? trait is not allowed in this type param bound") +resolveTyParamBound _ b@(TraitTyParamBound p t x) = scope b (TraitTyParamBound <$> resolvePolyTraitRef p <*> pure t <*> pure x) + +instance (Typeable a, Monoid a) => Resolve (TyParamBound a) where resolveM = resolveTyParamBound ModBound + +-- | There are several restricted forms of arguments allowed +data ArgType + = GeneralArg -- ^ Arguments allowed in places without implementation (optional limited pattern followed by a type) + | NamedArg -- ^ Arguments allowed in most places (any pattern followed by any type) + -- This includes lambda arguments + +-- | The only types of patterns supported by arguments are wild or identifiers +resolveArg :: (Typeable a, Monoid a) => ArgType -> Arg a -> ResolveM (Arg a) +resolveArg _ s@SelfValue{} = pure s +resolveArg _ a@(SelfRegion lt m x) = scope a (SelfRegion <$> traverse resolveLifetime lt <*> pure m <*> pure x) +resolveArg _ a@(SelfExplicit t m x) = scope a (SelfExplicit <$> resolveTy AnyType t <*> pure m <*> pure x) +resolveArg NamedArg a@(Arg Nothing _ _) = scope a (err a "named arguments must have patterns") +resolveArg NamedArg a@(Arg p t x) = scope a $ do + when (isSelfAlike a) $ + warn "argument looks like a self argument - did you mean to use 'SelfValue', 'SelfRegion', or 'SelfExplicit'?" + + p' <- traverse resolvePat p + t' <- resolveTy AnyType t + pure (Arg p' t' x) + +resolveArg GeneralArg a@(Arg p t x) = scope a $ do + when (isSelfAlike a) $ + warn "argument looks like a self argument - did you mean to use 'SelfValue', 'SelfRegion', or 'SelfExplicit'?" + + p' <- case p of + Nothing -> pure Nothing + Just WildP{} -> traverse resolvePat p + Just IdentP{} -> traverse resolvePat p + Just (RefP WildP{} Immutable _) -> traverse resolvePat p + Just (RefP (IdentP (ByValue Immutable) _ _ _) Immutable _) -> traverse resolvePat p + Just (RefP (RefP WildP{} Immutable _) Immutable _) -> traverse resolvePat p + Just (RefP (RefP (IdentP (ByValue Immutable) _ _ _) Immutable _) Immutable _) -> traverse resolvePat p + _ -> scope p (err p "this pattern is not allowed for this type of argument") + t' <- resolveTy AnyType t + pure (Arg p' t' x) + +-- | Check whether an argument is one of the "self"-alike forms +isSelfAlike :: Arg a -> Bool +isSelfAlike (Arg Nothing (PathTy Nothing (Path False [PathSegment (Ident (Name "self") False _) Nothing _] _) _) _) = True +isSelfAlike (Arg Nothing (Rptr _ _ (PathTy Nothing (Path False [PathSegment (Ident (Name "self") False _) Nothing _] _) _) _) _) = True +isSelfAlike _ = False + +instance (Typeable a, Monoid a) => Resolve (Arg a) where resolveM = resolveArg NamedArg + +-- | A Poly trait ref is valid whenever the underlying trait ref is. +resolvePolyTraitRef :: (Typeable a, Monoid a) => PolyTraitRef a -> ResolveM (PolyTraitRef a) +resolvePolyTraitRef p@(PolyTraitRef lts t x) = scope p $ do + lts' <- traverse resolveLifetimeDef lts + t' <- resolveTraitRef t + pure (PolyTraitRef lts' t' x) + +instance (Typeable a, Monoid a) => Resolve (PolyTraitRef a) where resolveM = resolvePolyTraitRef + +-- | A lifetime def is invalid if it has non-outer attributes +resolveLifetimeDef :: (Typeable a, Monoid a) => LifetimeDef a -> ResolveM (LifetimeDef a) +resolveLifetimeDef lts@(LifetimeDef as l bds x) = scope lts $ do + as' <- traverse (resolveAttr OuterAttr) as + l' <- resolveLifetime l + bds' <- traverse resolveLifetime bds + pure (LifetimeDef as' l' bds' x) + +instance (Typeable a, Monoid a) => Resolve (LifetimeDef a) where resolveM = resolveLifetimeDef + + +-------------- +-- Patterns -- +-------------- + +-- | A pattern can be invalid of +-- +-- * the index of the '...' in the tuple/tuple-struct is out of range +-- * the index of the qself path is out of range +-- * any underlying component is invalid +-- +resolvePat :: (Typeable a, Monoid a) => Pat a -> ResolveM (Pat a) +-- TupleStruct +resolvePat t@(TupleStructP p fs im x) = scope t $ do + p' <- resolvePath ExprPath p + fs' <- traverse resolvePat fs + im' <- case im of + Nothing -> pure Nothing + Just i | 0 <= i && i <= length fs -> pure (Just i) + _ -> err im "index of ... in tuple struct pattern is outside of field range" + pure (TupleStructP p' fs' im' x) +-- PathP +resolvePat p@(PathP Nothing a x) = scope p (PathP Nothing <$> resolvePath ExprPath a <*> pure x) +resolvePat p@(PathP q@(Just (QSelf _ i)) p'@(Path g s x) x') + | i < 0 || i >= length s = scope p (err p "index given by QSelf is outside the possible range") + | i == 0 = scope p (PathP <$> traverse resolveQSelf q <*> resolvePath ExprPath p' <*> pure x) + | otherwise = scope p $ do + Path _ tyPSegs _ <- resolvePath TypePath $ Path g (take i s) mempty + Path _ exprPSegs _ <- resolvePath ExprPath $ Path False (drop i s) x + q' <- traverse resolveQSelf q + pure (PathP q' (Path g (tyPSegs <> exprPSegs) x) x') +-- TupleP +resolvePat p@(TupleP ps i x) = scope p $ do + ps' <- traverse resolvePat ps + i' <- case i of + Nothing -> pure Nothing + Just j | 0 <= j && j <= length ps -> pure i + | otherwise -> err i "index of ... in tuple pattern is outside of range" + pure (TupleP ps' i' x) + +-- Everything else... +resolvePat p@(LitP e x) = scope p (LitP <$> resolveExpr LitExpr e <*> pure x) +resolvePat p@(RangeP l h x) = scope p (RangeP <$> resolveExpr LitOrPathExpr l <*> resolveExpr LitOrPathExpr h <*> pure x) +resolvePat p@(WildP x) = scope p (pure (WildP x)) +resolvePat p@(IdentP m i p' x) = scope p (IdentP m <$> resolveIdent i <*> traverse resolvePat p' <*> pure x) +resolvePat p@(StructP p' fs b x) = scope p (StructP <$> resolvePath ExprPath p' <*> traverse resolveFieldPat fs <*> pure b <*> pure x) +resolvePat p@(BoxP p' x) = scope p (BoxP <$> resolvePat p' <*> pure x) +resolvePat p@(RefP p' m x) = scope p (RefP <$> resolvePat p' <*> pure m <*> pure x) +resolvePat p@(SliceP b m a x) = scope p (SliceP <$> traverse resolvePat b <*> traverse resolvePat m <*> traverse resolvePat a <*> pure x) +resolvePat p@(MacP m x) = scope p (MacP <$> resolveMac ExprPath m <*> pure x) + +instance (Typeable a, Monoid a) => Resolve (Pat a) where resolveM = resolvePat + +-- | Field patterns are only invalid if the underlying pattern / identifier is +resolveFieldPat :: (Typeable a, Monoid a) => FieldPat a -> ResolveM (FieldPat a) +resolveFieldPat f@(FieldPat Nothing p x) = scope f $ + case p of (IdentP _ _ Nothing _) -> FieldPat Nothing <$> resolvePat p <*> pure x + (BoxP (IdentP _ _ Nothing _) _) -> FieldPat Nothing <$> resolvePat p <*> pure x + _ -> err f "patterns for fields without an identifier must be (possibly box) identifiers" +resolveFieldPat f@(FieldPat i p x) = scope f (FieldPat <$> traverse resolveIdent i <*> resolvePat p <*> pure x) + +instance (Typeable a, Monoid a) => Resolve (FieldPat a) where resolveM = resolveFieldPat + + +----------------- +-- Expressions -- +----------------- + +-- Invariants on expressions +data ExprType + = AnyExpr -- ^ Any expression, no restrictions + | LitExpr -- ^ Either an immediate literal, or a negated literal + | LitOrPathExpr -- ^ A literal, negated literal, expression path, or qualified expression path + | NoStructExpr -- ^ No struct literals are allowed + | NoStructBlockExpr -- ^ No struct literals or block expressions (block-like things like 'if' are fine) + | SemiExpr -- ^ Forbids expressions starting with blocks (things like '{ 1 } + 2') unless + -- the leading block has a postfix expression, allows expressions that are + -- just one big block. Forbids '{ 1 }[0]' since it is treated as '{ 1 }; [0]' + -- and '{ 1 }(0)' since it is treated as '{ 1 }; (0)' +{- +-- Check if an expression has the form of a "postfix" (if that's the case, then you don't worry +-- about what is inside). +-- +-- ie: `if i[0] == j[0] { i } else { j } [1]` +lhsSemiExpr :: (Typeable a, Monoid a) => Int -> Expr a -> ResolveM (Expr a) +lhsSemiExpr p t@(Try _ e _) = resolveExprP p AnyExpr + +lhsSemiExpr p (FieldAccess _ e _ _) | isBlockLike e = +lhsSemiExpr p (Try _ e _) +lhsSemiExpr p (Try _ e _) + +-} + +resolveLhsExprP :: (Typeable a, Monoid a) => Int -> ExprType -> Expr a -> ResolveM (Expr a) +resolveLhsExprP p SemiExpr l@Try{} = resolveExprP p AnyExpr l +resolveLhsExprP p SemiExpr l@FieldAccess{} = resolveExprP p AnyExpr l +resolveLhsExprP p SemiExpr l@MethodCall{} = resolveExprP p AnyExpr l +resolveLhsExprP p SemiExpr l@TupField{} = resolveExprP p AnyExpr l +resolveLhsExprP _ SemiExpr l | isBlockLike l = parenthesize l +resolveLhsExprP p t l = resolveExprP p (lhs t) l + where + -- | Given the type of expression, what type of expression is allowed on the LHS + lhs :: ExprType -> ExprType + lhs LitExpr = error "literal expressions never have a left hand side" + lhs LitOrPathExpr = error "literal or path expressions never have a left hand side" + lhs AnyExpr = AnyExpr + lhs NoStructExpr = NoStructExpr + lhs NoStructBlockExpr = NoStructBlockExpr + lhs SemiExpr = AnyExpr + +-- | Given the type of expression, what type of expression is allowed on the RHS +rhs :: ExprType -> ExprType +rhs LitExpr = error "literal expressions never have a right hand side" +rhs LitOrPathExpr = error "literal or path expressions never have a right hand side" +rhs AnyExpr = AnyExpr +rhs NoStructExpr = NoStructExpr +rhs NoStructBlockExpr = NoStructExpr +rhs SemiExpr = AnyExpr + +-- | Given the type of expression, what type of expression is allowed on the RHS (after '..'/'...') +rhs2 :: ExprType -> ExprType +rhs2 LitExpr = error "literal expressions never have a right hand side (2)" +rhs2 LitOrPathExpr = error "literal or path expressions never have a right hand side (2)" +rhs2 AnyExpr = AnyExpr +rhs2 NoStructExpr = NoStructBlockExpr +rhs2 NoStructBlockExpr = NoStructBlockExpr +rhs2 SemiExpr = AnyExpr + +-- | Resolve an expression of the given type in a general context +resolveExpr :: (Typeable a, Monoid a) => ExprType -> Expr a -> ResolveM (Expr a) +resolveExpr = resolveExprP 0 + +instance (Typeable a, Monoid a) => Resolve (Expr a) where resolveM = resolveExpr AnyExpr + +parenthesize :: (Typeable a, Monoid a) => Expr a -> ResolveM (Expr a) +parenthesize e = do + correct "added parens around expression" + e' <- resolveExprP 0 AnyExpr e + pure (ParenExpr [] e' mempty) + +{- +Precedences (from 'Internal.y') +=============================== + +0 %nonassoc box return break continue LAMBDA +1 %right '=' '>>=' '<<=' '-=' '+=' '*=' '/=' '^=' '|=' '&=' '%=' +2 %right '<-' + %nonassoc SINGLERNG -- '..' +3 %nonassoc INFIXRNG -- e1 '..' e2 +4 %nonassoc POSTFIXRNG -- e1 '..' +5 %nonassoc PREFIXRNG -- '..' e2 +6 %left '||' +7 %left '&&' +8 %left '==' '!=' '<' '>' '<=' '>=' +9 %left '|' +10 %left '^' +11 %left '&' +12 %left '<<' '>>' +13 %left '+' '-' +14 %left '*' '/' '%' +15 %left ':' as +16 %nonassoc UNARY -- 'UNARY' is introduced here for '*', '!', '-', '&' +17 %nonassoc POSTFIX -- 'POSTFIX' is introduced here for things like '?' +-} + +-- | This has a double role: to resolve the expression and keep track of precedences +resolveExprP :: (Typeable a, Monoid a) => Int -> ExprType -> Expr a -> ResolveM (Expr a) +-- Cover the 'LitExpr' type of expression +resolveExprP p LitExpr l@Lit{} = resolveExprP p AnyExpr l +resolveExprP p LitExpr n@(Unary _ Neg Lit{} _) = resolveExprP p AnyExpr n +resolveExprP _ LitExpr l = scope l (err l "expression is not literal or negated literal") +-- Cover the 'LitOrPathExpr' type of expression +resolveExprP p LitOrPathExpr l@Lit{} = resolveExprP p AnyExpr l +resolveExprP p LitOrPathExpr n@(Unary _ Neg Lit{} _) = resolveExprP p AnyExpr n +resolveExprP p LitOrPathExpr p'@PathExpr{} = resolveExprP p AnyExpr p' +resolveExprP _ LitOrPathExpr l = scope l (err l "expression is not literal, negated literal, path, or qualified path") +-- The following group of expression variants work in all of the remaining contexts (see +-- 'gen_expression' in the parser) +resolveExprP p c b@(Box as e x) = scope b $ parenE (p > 0) $ do + as' <- traverse (resolveAttr OuterAttr) as + e' <- resolveExprP 0 (rhs c) e + pure (Box as' e' x) +resolveExprP p c r@(Ret as me x) = scope r $ parenE (p > 0) $ do + as' <- traverse (resolveAttr OuterAttr) as + me' <- traverse (resolveExprP 0 (rhs c)) me + pure (Ret as' me' x) +resolveExprP p c r@(Yield as me x) = scope r $ parenE (p > 0) $ do + as' <- traverse (resolveAttr OuterAttr) as + me' <- traverse (resolveExprP 0 (rhs c)) me + pure (Yield as' me' x) +resolveExprP p c b@(Break as ml me x) = scope b $ parenE (p > 0) $ do + as' <- traverse (resolveAttr OuterAttr) as + ml' <- traverse resolveLbl ml + me' <- traverse (resolveExprP 0 (rhs c)) me + pure (Break as' ml' me' x) +resolveExprP p _ c@(Continue as ml x) = scope c $ parenE (p > 0) $ do + as' <- traverse (resolveAttr OuterAttr) as + ml' <- traverse resolveLbl ml + pure (Continue as' ml' x) +-- Closures +resolveExprP _ _ c@(Closure _ _ _ (FnDecl _ _ True _) _ _) = scope c (err c "closures can never be variadic") +resolveExprP p c e@(Closure as m cb fn@(FnDecl _ ret _ _) b x) = scope c $ + case (c, ret, b) of + (NoStructExpr, Just _, BlockExpr{}) -> parenthesize e + (NoStructBlockExpr, Just _, BlockExpr{}) -> parenthesize e + (NoStructExpr, Just _, _ ) -> parenthesize (Closure as m cb fn (asBlock b) x) + (NoStructBlockExpr, Just _, _ ) -> parenthesize (Closure as m cb fn (asBlock b) x) + (_, Just _, BlockExpr{}) -> resolved AnyExpr + (_, Just _, _ ) -> parenthesize (Closure as m cb fn (asBlock b) x) + _ -> resolved (rhs c) + where + asBlock ex = BlockExpr [] (Block [NoSemi ex mempty] Normal mempty) mempty + + resolved c' = parenE (p > 0) $ do + as' <- traverse (resolveAttr OuterAttr) as + fn' <- resolveFnDecl NoSelf NamedArg fn + b' <- resolveExprP 0 c' b + pure (Closure as' m cb fn' b' x) +-- Assignment/in-place expressions +resolveExprP p c a@(Assign as l r x) = scope a $ parenE (p > 1) $ do + as' <- traverse (resolveAttr OuterAttr) as + --l' <- resolveExprP 2 (lhs c) l + l' <- resolveLhsExprP 2 c l + r' <- resolveExprP 1 (rhs c) r + pure (Assign as' l' r' x) +resolveExprP p c a@(AssignOp as o l r x) = scope a $ parenE (p > 1) $ do + as' <- traverse (resolveAttr OuterAttr) as + --l' <- resolveExprP 2 (lhs c) l + l' <- resolveLhsExprP 2 c l + r' <- resolveExprP 1 (rhs c) r + pure (AssignOp as' o l' r' x) +resolveExprP p c i@(InPlace as l r x) = scope i $ parenE (p > 2) $ do + as' <- traverse (resolveAttr OuterAttr) as + --l' <- resolveExprP 3 (lhs c) l + l' <- resolveLhsExprP 3 c l + r' <- resolveExprP 2 (rhs c) r + pure (InPlace as' l' r' x) +-- Range expressions +resolveExprP _ _ r@(Range _ _ Nothing Closed _) = scope r (err r "inclusive ranges must be bounded at the end") +resolveExprP _ _ r@(Range as Nothing Nothing rl x) = scope r $ do + as' <- traverse (resolveAttr OuterAttr) as + pure (Range as' Nothing Nothing rl x) +resolveExprP p c a@(Range as (Just l) (Just r) rl x) = scope a $ parenE (p > 3) $ do + as' <- traverse (resolveAttr OuterAttr) as + -- l' <- resolveExprP 4 (lhs c) l + l' <- resolveLhsExprP 4 c l + r' <- resolveExprP 4 (rhs2 c) r + pure (Range as' (Just l') (Just r') rl x) +resolveExprP p c r@(Range as (Just l) Nothing rl x) = scope r $ parenE (p > 4) $ do + as' <- traverse (resolveAttr OuterAttr) as + -- l' <- resolveExprP 4 (lhs c) l + l' <- resolveLhsExprP 4 c l + pure (Range as' (Just l') Nothing rl x) +resolveExprP p c a@(Range as Nothing (Just r) rl x) = scope a $ parenE (p > 5) $ do + as' <- traverse (resolveAttr OuterAttr) as + r' <- resolveExprP 5 (rhs2 c) r + pure (Range as' Nothing (Just r') rl x) +-- Binary expressions +resolveExprP p c b@(Binary as o l r x) = scope b $ parenE (p > p') $ do + as' <- traverse (resolveAttr OuterAttr) as + -- l' <- resolveExprP p' (lhs c) l + l' <- resolveLhsExprP p' c l + r' <- resolveExprP (p' + 1) (rhs c) r + pure (Binary as' o l' r' x) + where + p' = opPrec o + + opPrec :: BinOp -> Int + opPrec AddOp = 13 + opPrec SubOp = 13 + opPrec MulOp = 14 + opPrec DivOp = 14 + opPrec RemOp = 14 + opPrec AndOp = 7 + opPrec OrOp = 6 + opPrec BitXorOp = 10 + opPrec BitAndOp = 11 + opPrec BitOrOp = 9 + opPrec ShlOp = 12 + opPrec ShrOp = 12 + opPrec EqOp = 8 + opPrec LtOp = 8 + opPrec LeOp = 8 + opPrec NeOp = 8 + opPrec GeOp = 8 + opPrec GtOp = 8 +-- Cast and type ascriptions expressions +resolveExprP p c a@(Cast as e t x) = scope a $ parenE (p > 15) $ do + as' <- traverse (resolveAttr OuterAttr) as + --e' <- resolveExprP 15 (lhs c) e + e' <- resolveLhsExprP 15 c e + t' <- resolveTy NoSumType t + pure (Cast as' e' t' x) +resolveExprP p c a@(TypeAscription as e t x) = scope a $ parenE (p > 15) $ do + as' <- traverse (resolveAttr OuterAttr) as + --e' <- resolveExprP 15 (lhs c) e + e' <- resolveLhsExprP 15 c e + t' <- resolveTy NoSumType t + pure (TypeAscription as' e' t' x) +-- Unary expressions +resolveExprP p c u@(Unary as o e x) = scope u $ parenE (p > 16) $ do + as' <- traverse (resolveAttr OuterAttr) as + e' <- resolveExprP 16 (rhs c) e + pure (Unary as' o e' x) +resolveExprP p c a@(AddrOf as m e x) = scope a $ parenE (p > 16) $ do + as' <- traverse (resolveAttr OuterAttr) as + e' <- resolveExprP 16 (rhs c) e + pure (AddrOf as' m e' x) +-- Postfix expressions +resolveExprP p c a@(Index as e i x) = scope a $ parenE (p > 17) $ do + as' <- traverse (resolveAttr OuterAttr) as + --e' <- resolveExprP 17 (lhs c) e + e' <- resolveLhsExprP 17 c e + i' <- resolveExprP 0 AnyExpr i + pure (Index as' e' i' x) +resolveExprP p SemiExpr t@Try{} = resolveExprP p AnyExpr t +resolveExprP p c t@(Try as e x) = scope t $ parenE (p > 17) $ do + as' <- traverse (resolveAttr OuterAttr) as + --e' <- resolveExprP 17 (lhs c) e + e' <- resolveLhsExprP 17 c e + pure (Try as' e' x) +resolveExprP p c a@(Call as f xs x) = scope a $ parenE (p > 17) $ do + as' <- traverse (resolveAttr OuterAttr) as + --f' <- resolveExprP 17 (lhs c) f + f' <- resolveLhsExprP 17 c f + xs' <- traverse (resolveExprP 0 AnyExpr) xs + pure (Call as' f' xs' x) +resolveExprP p SemiExpr m@MethodCall{} = resolveExprP p AnyExpr m +resolveExprP p c m@(MethodCall as e i mt es x) = scope m $ parenE (p > 17) $ do + as' <- traverse (resolveAttr OuterAttr) as + --e' <- resolveExprP 17 (lhs c) e + e' <- resolveLhsExprP 17 c e + i' <- resolveIdent i + mt' <- case mt of + Just t -> Just <$> traverse (resolveTy AnyType) t + Nothing -> pure Nothing + es' <- traverse (resolveExprP 0 AnyExpr) es + pure (MethodCall as' e' i' mt' es' x) +resolveExprP p SemiExpr t@TupField{} = resolveExprP p AnyExpr t +resolveExprP p c t@(TupField as e i x) = scope t $ parenE (p > 17) $ do + as' <- traverse (resolveAttr OuterAttr) as + --e' <- resolveExprP 17 (lhs c) e + e' <- resolveLhsExprP 17 c e + pure (TupField as' e' i x) +resolveExprP p SemiExpr f@FieldAccess{} = resolveExprP p AnyExpr f +resolveExprP p c f@(FieldAccess as e i x) = scope f $ parenE (p > 17) $ do + as' <- traverse (resolveAttr OuterAttr) as + --e' <- resolveExprP 17 (lhs c) e + e' <- resolveLhsExprP 17 c e + i' <- resolveIdent i + pure (FieldAccess as' e' i' x) +-- Immediate expressions +resolveExprP _ _ v@(Vec as es x) = scope v $ do + as' <- traverse (resolveAttr EitherAttr) as + es' <- traverse (resolveExprP 0 AnyExpr) es + pure (Vec as' es' x) +resolveExprP _ _ p@(PathExpr as Nothing p' x) = scope p $ do + as' <- traverse (resolveAttr OuterAttr) as + p'' <- resolvePath ExprPath p' + pure (PathExpr as' Nothing p'' x) +resolveExprP _ _ p@(PathExpr as q@(Just (QSelf _ i)) p'@(Path g s x) x') + | i < 0 || i >= length s = scope p (err p "index given by QSelf is outside the possible range") + | i == 0 = scope p $ do + as' <- traverse (resolveAttr OuterAttr) as + q' <- traverse resolveQSelf q + p'' <- resolvePath ExprPath p' + pure (PathExpr as' q' p'' x) + | otherwise = scope p $ do + as' <- traverse (resolveAttr OuterAttr) as + Path _ tyPSegs _ <- resolvePath TypePath $ Path g (take i s) mempty + Path _ exprPSegs _ <- resolvePath ExprPath $ Path False (drop i s) x + q' <- traverse resolveQSelf q + pure (PathExpr as' q' (Path g (tyPSegs <> exprPSegs) x) x') +resolveExprP _ _ i@(Lit as l x) = scope i $ do + as' <- traverse (resolveAttr OuterAttr) as + l' <- resolveLit l + pure (Lit as' l' x) +resolveExprP _ _ a@(Repeat as e r x) = scope a $ do + as' <- traverse (resolveAttr OuterAttr) as + e' <- resolveExprP 0 AnyExpr e + r' <- resolveExprP 0 AnyExpr r + pure (Repeat as' e' r' x) +-- Macro expressions +resolveExprP _ _ a@(MacExpr as m x) = scope a $ do + as' <- traverse (resolveAttr OuterAttr) as + m' <- resolveMac ExprPath m + pure (MacExpr as' m' x) +-- Paren expressions +resolveExprP _ _ p@(ParenExpr as e x) = scope p $ do + as' <- traverse (resolveAttr EitherAttr) as + e' <- resolveExprP 0 AnyExpr e + pure (ParenExpr as' e' x) +resolveExprP _ _ t@(TupExpr as es x) = scope t $ do + as' <- traverse (resolveAttr EitherAttr) as + es' <- traverse (resolveExprP 0 AnyExpr) es + pure (TupExpr as' es' x) +-- Block expressions +resolveExprP _ NoStructBlockExpr e@BlockExpr{} = parenthesize e +resolveExprP _ _ l@(BlockExpr as b x) = scope l $ do + as' <- traverse (resolveAttr EitherAttr) as + b' <- resolveBlock b + pure (BlockExpr as' b' x) +-- Struct expressions +resolveExprP _ NoStructExpr e@Struct{} = parenthesize e +resolveExprP _ NoStructBlockExpr e@Struct{} = parenthesize e +resolveExprP _ _ s@(Struct as p' fs e x) = scope s $ do + as' <- traverse (resolveAttr OuterAttr) as + p'' <- resolvePath ExprPath p' + fs' <- traverse resolveField fs + e' <- traverse (resolveExprP 0 AnyExpr) e + pure (Struct as' p'' fs' e' x) +-- Block-like expressions +resolveExprP p c i@(If as e b es x) = scope i $ do + as' <- traverse (resolveAttr OuterAttr) as + e' <- resolveExprP 0 NoStructExpr e + b' <- resolveBlock b + es' <- case es of + Nothing -> pure Nothing + (Just If{}) -> traverse (resolveExprP p c) es + (Just IfLet{}) -> traverse (resolveExprP p c) es + (Just BlockExpr{}) -> traverse (resolveExprP p c) es + (Just e'') -> Just <$> resolveExprP p c (BlockExpr [] (Block [NoSemi e'' mempty] Normal mempty) mempty) + pure (If as' e' b' es' x) +resolveExprP p c i@(IfLet as p' e b es x) = scope i $ do + as' <- traverse (resolveAttr OuterAttr) as + p'' <- traverse resolvePat p' + e' <- resolveExprP 0 NoStructExpr e + b' <- resolveBlock b + es' <- case es of + Nothing -> pure Nothing + (Just If{}) -> traverse (resolveExprP p c) es + (Just IfLet{}) -> traverse (resolveExprP p c) es + (Just BlockExpr{}) -> traverse (resolveExprP p c) es + (Just e'') -> Just <$> resolveExprP p c (BlockExpr [] (Block [NoSemi e'' mempty] Normal mempty) mempty) + pure (IfLet as' p'' e' b' es' x) +resolveExprP _ _ w@(While as e b l x) = scope w $ do + as' <- traverse (resolveAttr EitherAttr) as + e' <- resolveExprP 0 NoStructExpr e + b' <- resolveBlock b + l' <- traverse resolveLbl l + pure (While as' e' b' l' x) +resolveExprP _ _ w@(WhileLet as p' e b l x) = scope w $ do + as' <- traverse (resolveAttr EitherAttr) as + p'' <- traverse resolvePat p' + e' <- resolveExprP 0 NoStructExpr e + b' <- resolveBlock b + l' <- traverse resolveLbl l + pure (WhileLet as' p'' e' b' l' x) +resolveExprP _ _ f@(ForLoop as p' e b l x) = scope f $ do + as' <- traverse (resolveAttr EitherAttr) as + p'' <- resolvePat p' + e' <- resolveExprP 0 NoStructExpr e + b' <- resolveBlock b + l' <- traverse resolveLbl l + pure (ForLoop as' p'' e' b' l' x) +resolveExprP _ _ o@(Loop as b l x) = scope o $ do + as' <- traverse (resolveAttr EitherAttr) as + b' <- resolveBlock b + l' <- traverse resolveLbl l + pure (Loop as' b' l' x) +resolveExprP _ _ m@(Match as e ar x) = scope m $ do + as' <- traverse (resolveAttr EitherAttr) as + e' <- resolveExprP 0 AnyExpr e + ar' <- traverse resolveArm ar + pure (Match as' e' ar' x) +resolveExprP _ _ c@(Catch as b x) = scope c $ do + as' <- traverse (resolveAttr EitherAttr) as + b' <- resolveBlock b + pure (Catch as' b' x) +resolveExprP _ _ e@(EmbeddedExpr as code x) = scope e $ do + as' <- traverse (resolveAttr EitherAttr) as + pure (EmbeddedExpr as' code x) + +isBlockLike :: Expr a -> Bool +isBlockLike If{} = True +isBlockLike IfLet{} = True +isBlockLike Loop{} = True +isBlockLike ForLoop{} = True +isBlockLike While{} = True +isBlockLike WhileLet{} = True +isBlockLike Match{} = True +isBlockLike BlockExpr{} = True +isBlockLike _ = False + +resolveLbl :: Typeable a => Label a -> ResolveM (Label a) +resolveLbl l@(Label n _) = scope l (resolveIdent (mkIdent n) *> pure l) + +-- | Wrap an expression in parens if the condition given holds +parenE :: (Typeable a, Monoid a) => Bool -> ResolveM (Expr a) -> ResolveM (Expr a) +parenE True e = ParenExpr [] <$> e <*> pure mempty +parenE False e = e + +-- | A field just requires the identifier and expression to be valid +resolveField :: (Typeable a, Monoid a) => Field a -> ResolveM (Field a) +resolveField f@(Field i e x) = scope f $ do + i' <- resolveIdent i + e' <- traverse (resolveExpr AnyExpr) e + pure (Field i' e' x) + +instance (Typeable a, Monoid a) => Resolve (Field a) where resolveM = resolveField + +-- | Arms are invalid only if the underlying consitutents are +resolveArm :: (Typeable a, Monoid a) => Arm a -> ResolveM (Arm a) +resolveArm a@(Arm as ps g b x) = scope a $ do + as' <- traverse (resolveAttr OuterAttr) as + ps' <- traverse resolvePat ps + g' <- traverse (resolveExpr AnyExpr) g + b' <- resolveExpr SemiExpr b + pure (Arm as' ps' g' b' x) + +instance (Typeable a, Monoid a) => Resolve (Arm a) where resolveM = resolveArm + + +---------------- +-- Statements -- +---------------- + +-- Invariants on statements +data StmtType + = TermStmt -- ^ require a statement be terminated (so another statement can follow it)? + | AnyStmt -- ^ any statement + +-- | Statements are invalid only when the underlying components are. +resolveStmt :: (Typeable a, Monoid a) => StmtType -> Stmt a -> ResolveM (Stmt a) +resolveStmt _ l@(Local p t i as x) = scope l $ do + p' <- resolvePat p + t' <- traverse (resolveTy AnyType) t + i' <- traverse (resolveExpr AnyExpr) i + as' <- traverse (resolveAttr OuterAttr) as + pure (Local p' t' i' as' x) +resolveStmt _ s@(ItemStmt i x) = scope s (ItemStmt <$> resolveItem StmtItem i <*> pure x) +resolveStmt _ s@(Semi e x) | isBlockLike e = scope s (Semi <$> resolveExpr AnyExpr e <*> pure x) +resolveStmt _ s@(Semi e x) = scope s (Semi <$> resolveExpr SemiExpr e <*> pure x) +resolveStmt _ n@(NoSemi e x) | isBlockLike e = scope n (NoSemi <$> resolveExpr AnyExpr e <*> pure x) +resolveStmt AnyStmt n@(NoSemi e x) = scope n (NoSemi <$> resolveExpr SemiExpr e <*> pure x) +resolveStmt TermStmt n@(NoSemi e x) = scope n (NoSemi <$> resolveExpr AnyExpr (BlockExpr [] (Block [NoSemi e mempty] Normal mempty) mempty) <*> pure x) +resolveStmt _ a@(MacStmt m s as x) = scope a $ do + m' <- resolveMac ExprPath m + as' <- traverse (resolveAttr OuterAttr) as + pure (MacStmt m' s as' x) + +instance (Typeable a, Monoid a) => Resolve (Stmt a) where resolveM = resolveStmt AnyStmt + +-- | A block must a a series of terminated statements ended by one possibly unterminated one +resolveBlock :: (Typeable a, Monoid a) => Block a -> ResolveM (Block a) +resolveBlock b@(Block [] _ _) = pure b +resolveBlock b@(Block (s:ss) r x) = scope b $ do + ss' <- traverse (resolveStmt TermStmt) (N.init $ NonEmpty (s N2.:| ss)) + s' <- resolveStmt AnyStmt (N.last $ NonEmpty (s N2.:| ss)) + pure (Block (ss' ++ [s']) r x) + +instance (Typeable a, Monoid a) => Resolve (Block a) where resolveM = resolveBlock + + +----------- +-- Items -- +----------- + +-- Whether the item is a statement item, or a general item +data ItemType + = StmtItem -- ^ Corresponds to 'stmt_item' - basically limited visbility and no macros + | ModItem -- ^ General item + +resolveVisibility' :: Typeable a => ItemType -> Visibility a -> ResolveM (Visibility a) +resolveVisibility' StmtItem PublicV = pure PublicV +resolveVisibility' StmtItem InheritedV = pure InheritedV +resolveVisibility' StmtItem v = scope v $ err v "statement items can only have public or inherited visibility" +resolveVisibility' ModItem v = pure v + +-- | An item can be invalid if +-- +-- * it is a macro but has 'StmtItem' restriction +-- * it has visibility other than public/inherited but has 'StmtItem' restriction +-- * an underlying component is invalid +-- +resolveItem :: (Typeable a, Monoid a) => ItemType -> Item a -> ResolveM (Item a) +resolveItem t e@(ExternCrate as v i r x) = scope e $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility' t v + i' <- resolveIdent i + r' <- traverse resolveIdent r + pure (ExternCrate as' v' i' r' x) + +resolveItem t u@(Use as v p x) = scope u $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility' t v + p' <- resolveUseTree p + pure (Use as' v' p' x) + +resolveItem t s@(Static as v i t' m e x) = scope s $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility' t v + i' <- resolveIdent i + t'' <- resolveTy AnyType t' + e' <- resolveExpr AnyExpr e + pure (Static as' v' i' t'' m e' x) + +resolveItem t c@(ConstItem as v i t' e x) = scope c $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility' t v + i' <- resolveIdent i + t'' <- resolveTy AnyType t' + e' <- resolveExpr AnyExpr e + pure (ConstItem as' v' i' t'' e' x) + +resolveItem t f@(Fn as v i d u c a g b x) = scope f $ do + as' <- traverse (resolveAttr EitherAttr) as + v' <- resolveVisibility' t v + i' <- resolveIdent i + d' <- resolveFnDecl NoSelf NamedArg d + g' <- resolveGenerics g + b' <- resolveBlock b + pure (Fn as' v' i' d' u c a g' b' x) + +resolveItem t m@(Mod as v i (Just is) x) = scope m $ do + as' <- traverse (resolveAttr EitherAttr) as + v' <- resolveVisibility' t v + i' <- resolveIdent i + is' <- traverse (resolveItem ModItem) is + pure (Mod as' v' i' (Just is') x) + +resolveItem t m@(Mod as v i Nothing x) = scope m $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility' t v + i' <- resolveIdent i + pure (Mod as' v' i' Nothing x) + +resolveItem t m@(ForeignMod as v a is x) = scope m $ do + as' <- traverse (resolveAttr EitherAttr) as + v' <- resolveVisibility' t v + is' <- traverse (resolveForeignItem a) is + pure (ForeignMod as' v' a is' x) + +resolveItem t a@(TyAlias as v i t' g x) = scope a $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility' t v + i' <- resolveIdent i + t'' <- resolveTy AnyType t' + g' <- resolveGenerics g + pure (TyAlias as' v' i' t'' g' x) + +resolveItem t e@(Enum as v i vs g x) = scope e $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility' t v + i' <- resolveIdent i + vs' <- traverse resolveVariant vs + g' <- resolveGenerics g + pure (Enum as' v' i' vs' g' x) + +resolveItem t s@(StructItem as v i vd g x) = scope s $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility' t v + i' <- resolveIdent i + vd' <- resolveVariantData vd + g' <- resolveGenerics g + pure (StructItem as' v' i' vd' g' x) + +resolveItem t u@(Union as v i vd g x) = scope u $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility' t v + i' <- resolveIdent i + vd' <- resolveVariantData vd + g' <- resolveGenerics g + pure (Union as' v' i' vd' g' x) + +resolveItem t r@(Trait as v i a u g bd is x) = scope r $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility' t v + i' <- resolveIdent i + g' <- resolveGenerics g + bd' <- traverse (resolveTyParamBound NoneBound) bd + is' <- traverse resolveTraitItem is + pure (Trait as' v' i' a u g' bd' is' x) + +resolveItem t r@(TraitAlias as v i g bd x) = scope r $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility' t v + i' <- resolveIdent i + g' <- resolveGenerics g + bd' <- traverse (resolveTyParamBound NoneBound) bd + pure (TraitAlias as' v' i' g' bd' x) + +resolveItem t i'@(Impl as v d u i g mt t' is x) = scope i' $ do + as' <- traverse (resolveAttr EitherAttr) as + v' <- resolveVisibility' t v + g' <- resolveGenerics g + mt' <- traverse resolveTraitRef mt + t'' <- case mt of + Nothing -> resolveTy PrimParenType t' + Just _ -> resolveTy AnyType t' + is' <- traverse resolveImplItem is + pure (Impl as' v' d u i g' mt' t'' is' x) + +resolveItem StmtItem m@MacItem{} = scope m (err m "macro items cannot be in statement items") +resolveItem _ a@(MacItem as i m x) = scope a $ do + as' <- traverse (resolveAttr OuterAttr) as + i' <- traverse resolveIdent i + m' <- resolveMac ExprPath m + pure (MacItem as' i' m' x) + +resolveItem _ m@(MacroDef as i ts x) = scope m $ do + as' <- traverse (resolveAttr OuterAttr) as + i' <- resolveIdent i + ts' <- resolveTokenStream ts + pure (MacroDef as' i' ts' x) + +instance (Typeable a, Monoid a) => Resolve (Item a) where resolveM = resolveItem ModItem + +-- | A foreign item is invalid only if any of its underlying constituents are +resolveForeignItem :: (Typeable a, Monoid a) => Abi -> ForeignItem a -> ResolveM (ForeignItem a) +resolveForeignItem a f@(ForeignFn as v i fn g x) = scope f $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility v + i' <- resolveIdent i + fn' <- resolveFnDecl (case a of { C -> VarNoSelf; _ -> NoSelf }) NamedArg fn + g' <- resolveGenerics g + pure (ForeignFn as' v' i' fn' g' x) +resolveForeignItem _ f@(ForeignStatic as v i t m x) = scope f $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility v + i' <- resolveIdent i + t' <- resolveTy AnyType t + pure (ForeignStatic as' v' i' t' m x) +resolveForeignItem _ f@(ForeignTy as v i x) = scope f $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility v + i' <- resolveIdent i + pure (ForeignTy as' v' i' x) + +instance (Typeable a, Monoid a) => Resolve (ForeignItem a) where resolveM = resolveForeignItem C + +-- | A where clause is valid only if the underlying predicates are +resolveWhereClause :: (Typeable a, Monoid a) => WhereClause a -> ResolveM (WhereClause a) +resolveWhereClause w@(WhereClause p x) = scope w (WhereClause <$> traverse resolveWherePredicate p <*> pure x) + +instance (Typeable a, Monoid a) => Resolve (WhereClause a) where resolveM = resolveWhereClause + +-- | Generics are only invalid if the underlying lifetimes or type parameters are +resolveGenerics :: (Typeable a, Monoid a) => Generics a -> ResolveM (Generics a) +resolveGenerics g@(Generics lts typ wc x) = scope g $ do + lts' <- traverse resolveLifetimeDef lts + typ' <- traverse resolveTyParam typ + wc' <- resolveWhereClause wc + pure (Generics lts' typ' wc' x) + +instance (Typeable a, Monoid a) => Resolve (Generics a) where resolveM = resolveGenerics + +-- | A type parameter is invalid only when the underlying components are +resolveTyParam :: (Typeable a, Monoid a) => TyParam a -> ResolveM (TyParam a) +resolveTyParam p@(TyParam as i bds t x) = scope p $ do + as' <- traverse (resolveAttr OuterAttr) as + i' <- resolveIdent i + bds' <- traverse (resolveTyParamBound ModBound) bds + t' <- traverse (resolveTy AnyType) t + pure (TyParam as' i' bds' t' x) + +instance (Typeable a, Monoid a) => Resolve (TyParam a) where resolveM = resolveTyParam + +-- Invariants for struct fields +data StructFieldType + = IdentStructField -- ^ struct style field + | BareStructField -- ^ tuple-struct style field + +-- | A variant is valid if the underlying components are +resolveVariant :: (Typeable a, Monoid a) => Variant a -> ResolveM (Variant a) +resolveVariant v@(Variant i as n e x) = scope v $ do + i' <- resolveIdent i + as' <- traverse (resolveAttr OuterAttr) as + n' <- resolveVariantData n + e' <- traverse (resolveExpr AnyExpr) e + pure (Variant i' as' n' e' x) + +instance (Typeable a, Monoid a) => Resolve (Variant a) where resolveM = resolveVariant + +-- | A variant data is valid if the underlying components are +resolveVariantData :: (Typeable a, Monoid a) => VariantData a -> ResolveM (VariantData a) +resolveVariantData v@(StructD fs x) = scope v (StructD <$> traverse (resolveStructField IdentStructField) fs <*> pure x) +resolveVariantData v@(TupleD fs x) = scope v (TupleD <$> traverse (resolveStructField BareStructField) fs <*> pure x) +resolveVariantData (UnitD x) = pure (UnitD x) + +instance (Typeable a, Monoid a) => Resolve (VariantData a) where resolveM = resolveVariantData + +-- | A struct field is invalid if +-- +-- * it has the invariant that it needs an identifier, but it doesn't have one +-- * it has the invariant that should not have an identifier, but it doe have one +-- * any of the underlying components are invalid +-- +resolveStructField :: (Typeable a, Monoid a) => StructFieldType -> StructField a -> ResolveM (StructField a) +resolveStructField IdentStructField s@(StructField Nothing _ _ _ _) = scope s $ err s "struct field needs an identifier" +resolveStructField IdentStructField s@(StructField (Just i) v t as x) = scope s $ do + i' <- resolveIdent i + v' <- resolveVisibility v + t' <- resolveTy AnyType t + as' <- traverse (resolveAttr OuterAttr) as + pure (StructField (Just i') v' t' as' x) +resolveStructField BareStructField s@(StructField (Just _) _ _ _ _) = scope s $ err s "tuple-struct field cannot have an identifier" +resolveStructField BareStructField s@(StructField Nothing v t as x) = scope s $ do + v' <- resolveVisibility v + t' <- resolveTy AnyType t + as' <- traverse (resolveAttr OuterAttr) as + pure (StructField Nothing v' t' as' x) + +instance (Typeable a, Monoid a) => Resolve (StructField a) where resolveM = resolveStructField IdentStructField + +-- | A where predicate is invalid only if the underlying lifetimes are +resolveWherePredicate :: (Typeable a, Monoid a) => WherePredicate a -> ResolveM (WherePredicate a) +resolveWherePredicate p@(EqPredicate t1 t2 x) = scope p (EqPredicate <$> resolveTy NoForType t1 <*> resolveTy AnyType t2 <*> pure x) +resolveWherePredicate p@(RegionPredicate l ls x) = scope p $ do + l' <- resolveLifetime l + ls' <- traverse resolveLifetime ls + pure (RegionPredicate l' ls' x) +resolveWherePredicate p@(BoundPredicate lts t bds x) = scope p $ do + lts' <- traverse resolveLifetimeDef lts + t' <- resolveTy NoForType t + bds' <- traverse (resolveTyParamBound ModBound) bds + pure (BoundPredicate lts' t' bds' x) + +instance (Typeable a, Monoid a) => Resolve (WherePredicate a) where resolveM = resolveWherePredicate + +-- | A trait item is valid if the underlying components are +resolveTraitItem :: (Typeable a, Monoid a) => TraitItem a -> ResolveM (TraitItem a) +resolveTraitItem n@(ConstT as i t e x) = scope n $ do + as' <- traverse (resolveAttr OuterAttr) as + i' <- resolveIdent i + t' <- resolveTy AnyType t + e' <- traverse (resolveExpr AnyExpr) e + pure (ConstT as' i' t' e' x) +resolveTraitItem n@(MethodT as i g m b x) = scope n $ do + as' <- traverse (resolveAttr OuterAttr) as + i' <- resolveIdent i + g' <- resolveGenerics g + m' <- resolveMethodSig GeneralArg m + b' <- traverse resolveBlock b + pure (MethodT as' i' g' m' b' x) +resolveTraitItem n@(TypeT as i bd t x) = scope n $ do + as' <- traverse (resolveAttr OuterAttr) as + i' <- resolveIdent i + bd' <- traverse (resolveTyParamBound ModBound) bd + t' <- traverse (resolveTy AnyType) t + pure (TypeT as' i' bd' t' x) +resolveTraitItem n@(MacroT as m x) = scope n $ do + as' <- traverse (resolveAttr OuterAttr) as + m' <- resolveMac ModPath m + pure (MacroT as' m' x) + +instance (Typeable a, Monoid a) => Resolve (TraitItem a) where resolveM = resolveTraitItem + +-- | An impl item is valid if the underlying components are +resolveImplItem :: (Typeable a, Monoid a) => ImplItem a -> ResolveM (ImplItem a) +resolveImplItem n@(ConstI as v d i t e x) = scope n $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility v + i' <- resolveIdent i + t' <- resolveTy AnyType t + e' <- resolveExpr AnyExpr e + pure (ConstI as' v' d i' t' e' x) +resolveImplItem n@(MethodI as v d i g m b x) = scope n $ do + as' <- traverse (resolveAttr EitherAttr) as + v' <- resolveVisibility v + i' <- resolveIdent i + g' <- resolveGenerics g + m' <- resolveMethodSig NamedArg m + b' <- resolveBlock b + pure (MethodI as' v' d i' g' m' b' x) +resolveImplItem n@(TypeI as v d i t x) = scope n $ do + as' <- traverse (resolveAttr OuterAttr) as + v' <- resolveVisibility v + i' <- resolveIdent i + t' <- resolveTy AnyType t + pure (TypeI as' v' d i' t' x) +resolveImplItem n@(MacroI as d m x) = scope n $ do + as' <- traverse (resolveAttr OuterAttr) as + m' <- resolveMac ModPath m + pure (MacroI as' d m' x) + +instance (Typeable a, Monoid a) => Resolve (ImplItem a) where resolveM = resolveImplItem + +-- | The 'Monoid' constraint is theoretically not necessary - restricted visibility paths are mod paths, +-- so they should never have generics. +resolveVisibility :: (Typeable a, Monoid a) => Visibility a -> ResolveM (Visibility a) +resolveVisibility PublicV = pure PublicV +resolveVisibility InheritedV = pure InheritedV +resolveVisibility CrateV = pure CrateV +resolveVisibility v@(RestrictedV p) = scope v (RestrictedV <$> resolvePath ModPath p) + +instance (Typeable a, Monoid a) => Resolve (Visibility a) where resolveM = resolveVisibility + +-- | A method signature is valid if the underlying components are +resolveMethodSig :: (Typeable a, Monoid a) => ArgType -> MethodSig a -> ResolveM (MethodSig a) +resolveMethodSig at m@(MethodSig u c a f) = scope m (MethodSig u c a <$> resolveFnDecl AllowSelf at f) + +instance (Typeable a, Monoid a) => Resolve (MethodSig a) where resolveM = resolveMethodSig NamedArg + +-- | A view path is valid if the underlying components are +resolveUseTree :: (Typeable a, Monoid a) => UseTree a -> ResolveM (UseTree a) +resolveUseTree v@(UseTreeSimple p i x) = scope v $ do + p' <- resolvePath ModPath p + i' <- traverse resolveIdent i + pure (UseTreeSimple p' i' x) +resolveUseTree v@(UseTreeGlob p x) = scope v $ do + p' <- resolvePath UsePath p + pure (UseTreeGlob p' x) +resolveUseTree v@(UseTreeNested p ns x) = scope v $ do + p' <- resolvePath UsePath p + ns' <- traverse resolveUseTree ns + pure (UseTreeNested p' ns' x) + +instance (Typeable a, Monoid a) => Resolve (UseTree a) where resolveM = resolveUseTree + + +------------------- +-- Macro related -- +------------------- + +-- | A macro call is only invalid if any of the underlying components are +resolveMac :: (Typeable a, Monoid a) => PathType -> Mac a -> ResolveM (Mac a) +resolveMac t m@(Mac p ts x) = scope m (Mac <$> resolvePath t p <*> resolveTokenStream ts <*> pure x) + +instance (Typeable a, Monoid a) => Resolve (Mac a) where + resolveM m@(Mac p ts x) = scope m (Mac <$> resolveM p <*> resolveTokenStream ts <*> pure x) + +-- | A token tree is invalid when +-- +-- * there is an open or close delim token (those should be balanced and in 'Delimited') +-- * the underlying token trees are invalid +-- +resolveTt :: TokenTree -> ResolveM TokenTree +resolveTt t@(Token _ (OpenDelim _)) = scope t (err t "open delimiter is not allowed as a token in a token tree") +resolveTt t@(Token _ (CloseDelim _)) = scope t (err t "close delimiter is not allowed as a token in a token tree") +resolveTt t@Token{} = pure t +resolveTt t@(Delimited s d ts) = scope t (Delimited s d <$> resolveTokenStream ts) + +instance Resolve TokenTree where resolveM = resolveTt + +resolveTokenStream :: TokenStream -> ResolveM TokenStream +resolveTokenStream s@(Tree tt) = scope s (Tree <$> resolveTt tt) +resolveTokenStream s@(Stream ts) = scope s (Stream <$> mapM resolveTokenStream ts) + +instance Resolve TokenStream where resolveM = resolveTokenStream + diff --git a/src/Language/Rust/Pretty/Util.hs b/src/Language/Rust/Pretty/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Pretty/Util.hs @@ -0,0 +1,161 @@ +{-| +Module : Language.Rust.Pretty.Util +Description : pretty printing utilities +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : portable + +This module contains a variety of utility functions for pretty printing. Most of these require +inspecting the internal structure of 'Doc'. + +Wadler's take on pretty printing is super useful because it allows us to print thinks like blocks +much more nicely (see [this](http://stackoverflow.com/a/41424946/3072788)) that Hughes'. +Unfortunately, unlike Hughes', Wadler does not have 'mempty' as the identity of @<+>@ - the +space between the arguments of @<+>@ does not go away even if either argument is empty. The +same problem shows up for @hsep@, @<#>@, @vsep@, @@, etc. + +My solution has been to redefine my versions of these functions which _do_ treat 'mempty' as a +neutral element for @<+>@, @hsep@, @<#>@, @vsep@, and @@. +-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Rust.Pretty.Util where + +import Data.Monoid as M + +import qualified Data.Text.Prettyprint.Doc as PP +import Data.Text.Prettyprint.Doc.Internal.Type ( Doc(..) ) + +import Language.Rust.Syntax.Token ( Delim(..) ) + +-- | Indentation level +n :: Int +n = 2 + +-- | Similar to 'maybe', but where the 'Nothing' case is an empty 'Doc' +emptyElim :: Doc a -- ^ result if scrutinee is empty + -> (Doc a -> Doc a) -- ^ how to process scrutinee if it is not empty + -> Doc a -- ^ scrutinee 'Doc' + -> Doc a +emptyElim a _ Empty = a +emptyElim _ f doc = f doc + +-- | Vertically concatenate two 'Doc's with a collapsible line between them +(<##>) :: Doc a -> Doc a -> Doc a +d1 <##> d2 = d1 M.<> PP.line' M.<> d2 + +-- | Flatten a 'Doc' +flatten :: Doc a -> Doc a +flatten d@Fail{} = d +flatten d@Empty{} = d +flatten d@Char{} = d +flatten d@Text{} = d +flatten d@Line{} = d +flatten (FlatAlt _ d) = d +flatten (Cat d1 d2) = Cat (flatten d1) (flatten d2) +flatten (Nest i d) = Nest i (flatten d) +flatten (Union d _) = flatten d +flatten (Column f) = Column (flatten . f) +flatten (WithPageWidth f) = WithPageWidth (flatten . f) +flatten (Nesting f) = Nesting (flatten . f) +flatten (Annotated a d) = Annotated a (flatten d) + +-- | Map the list of items into 'Doc's using the provided function and add comma punctuation +commas :: [a] -> (a -> Doc b) -> Doc b +commas xs f = PP.hsep (PP.punctuate "," (map f xs)) + +-- | Take a binary operation on docs and lift it to one that has (left and right) identity 'mempty' +liftOp :: (Doc a -> Doc a -> Doc a) -> Doc a -> Doc a -> Doc a +liftOp _ Empty d = d +liftOp _ d Empty = d +liftOp (#) d d' = d # d' + +-- | Lifted version of Wadler's @<+>@ +(<+>) :: Doc a -> Doc a -> Doc a +(<+>) = liftOp (PP.<+>) + +-- | Lifted version of Wadler's @hsep@ +hsep :: Foldable f => f (Doc a) -> Doc a +hsep = foldr (<+>) mempty + +-- | Lifted version of Wadler's @<#>@ +(<#>) :: Doc a -> Doc a -> Doc a +(<#>) = liftOp (\x y -> x <> PP.line <> y) + +-- | Lifted version of Wadler's @vsep@ +vsep :: Foldable f => f (Doc a) -> Doc a +vsep = foldr (<#>) mempty + +-- | Lifted version of Wadler's @@ +() :: Doc a -> Doc a -> Doc a +() = liftOp (\x y -> x <> PP.softline <> y) + +-- | Unless the condition holds, print the document +unless :: Bool -> Doc a -> Doc a +unless b = when (not b) + +-- | When the condition holds, print the document +when :: Bool -> Doc a -> Doc a +when cond d = if cond then d else mempty + +-- | Apply a printing function to an optional value. If the value is 'Nothing', 'perhaps' returns +-- the empty 'Doc'. +perhaps :: (a -> Doc b) -> Maybe a -> Doc b +perhaps = maybe mempty + +-- | Indent the given 'Doc', but only if multi-line +indent :: Int -> Doc a -> Doc a +indent m doc = PP.flatAlt (PP.indent m doc) (flatten doc) + +-- | Undo what group does. This function is pretty dangerous... +ungroup :: Doc a -> Doc a +ungroup (Union _ x) = x +ungroup y = y + +-- | Remove all indent +noIndent :: Doc a -> Doc a +noIndent d = PP.nesting (\i -> PP.nest (negate i) d) + +-- | Translate '\n' in a string using the provided 'Doc' instead of 'line' +string :: Doc a -> String -> Doc a +string new = foldMap (\c -> case c of { '\n' -> new; _ -> Char c }) + +-- | This is the most general function for printing blocks. It operates with any delimiter, any +-- seperator, an optional leading attribute doc (which isn't followed by a seperator), and wraps a +-- list of entries. It has been tweaked to look Just Right (TM) for the usual cases. +-- +-- Note that this will try to fit things on one line when possible, so if you want a block that is +-- sure /not/ to be condensed on one line (e.g. for a function), you have to construct it manually. +block :: Delim -- ^ outer delimiters + -> Bool -- ^ prefer to be on one line (as opposed to multiline)? + -> Doc a -- ^ seperator + -> Doc a -- ^ attributes doc, after which no seperator will (use 'mempty' to ignore) + -> [Doc a] -- ^ entries + -> Doc a +block delim p s as xs = group' (lDel # PP.vsep (as' ++ ys) # rDel) + where + group' = if p || null (as' ++ ys) then PP.group else id + + -- left and right delimiter lists + (lDel,rDel) = case delim of + Paren -> ("(", ")") + Bracket -> ("[", "]") + Brace -> ("{", "}") + NoDelim -> (mempty, mempty) + + -- method of contenating delimiters with the rest of the body + (#) = case delim of { Paren -> (<##>); _ -> (<#>) } + + -- attributes + as' = case as of + Empty -> [] + _ -> [ PP.flatAlt (PP.indent n as) (flatten as) ] + + -- list of entries + ys = go xs where go [] = [] + go [z] = [ PP.flatAlt (PP.indent n z <> s) (flatten z) ] + go (z:zs) = PP.flatAlt (PP.indent n z <> s) (flatten z <> s) : go zs + + diff --git a/src/Language/Rust/Quote.hs b/src/Language/Rust/Quote.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Quote.hs @@ -0,0 +1,232 @@ +{-| +Module : Language.Rust.Quote +Description : Quasiquotes for Rust AST +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : GHC + +Quasiquoters for converting Rust code into the equivalent Haskell patterns and expressions. +These are just convenience wrappers over 'dataToExpQ' and 'dataToPatQ'. These quasiquoters +only work as expressions and patterns, not as declarations or types. The pattern quasiquoters +recursively ignore any 'Span' or 'Position' fields (replacing them with wildcard patterns). + +Using quasiquotes instead of manually writing out the AST means that even if the AST evolves +(perhaps by adding extra fields to certain nodes), your code is likely to continue to work. + +The examples below assume the following GHCi flag and import: + +>>> :set -XQuasiQuotes +>>> import Control.Monad ( void ) +-} +{-# LANGUAGE RankNTypes, QuasiQuotes, TemplateHaskell #-} + +module Language.Rust.Quote ( + lit, attr, ty, pat, stmt, expr, item, sourceFile, implItem, traitItem, tokenTree, block, + stmts, items, implItems +) where + +{- +In the future, we may try to do something similar to Rust macros to extract or inject ASTs out or +into the quasiquotes. + +Eventually, one should be able to just import this module for code generation. The following +interaction is what should eventually work. + +>>> import qualified Language.Rust.Quote as Q +>>> :set -XQuasiQuotes +t +>>> let one = [Q.expr| 1i32 |] +one :: Expr Span +>>> [Q.expr| |x: i32| -> $retTy:ty $body:block |] = [Q.expr| |x: i32| -> i32 { ($one) + x } |] +retTy :: Ty Span +body :: Block Span +>>> import Language.Rust.Pretty +>>> pretty retTy +i32 +>>> pretty body +{ (1i32) + x } + +For now, however, you cannot use @$x@ or @$x:ty@ meta variables. +-} + +import Language.Rust.Parser.ParseMonad +import Language.Rust.Parser.Internal +import Language.Rust.Data.InputStream ( inputStreamFromString ) +import Language.Rust.Data.Position ( Position(..), Span ) +import Language.Rust.Data.Ident ( Ident(..), IdentName(..), mkIdent ) +import Language.Rust.Syntax.AST ( Expr(EmbeddedExpr), TokenTree(..) ) +import Language.Rust.Syntax.Token ( Token(..) ) + +import Language.Haskell.TH.Syntax ( liftData ) -- liftData :: Data a => a -> Q Exp +import Language.Haskell.TH +import Language.Haskell.TH.Quote ( QuasiQuoter(..), dataToExpQ, dataToPatQ ) +import qualified Language.Haskell.Meta as LHM + +import Control.Applicative ( (<|>) ) +import Control.Monad ( (>=>) ) +import Data.Functor ( ($>) ) +import Data.Typeable ( cast, Typeable ) +import Data.Data ( Data ) + +-- | Given a parser, convert it into a quasiquoter. The quasiquoter produced does not support +-- declarations and types. For patterns, it replaces any 'Span' and 'Position' field with a +-- wild pattern. +quoter :: Data a => (forall b. Typeable b => b -> Maybe (Q Exp)) -> P a -> QuasiQuoter +--quoter :: P ExpQ -> QuasiQuoter +quoter exprTransformer p = QuasiQuoter + { quoteExp = parse >=> dataToExpQ exprTransformer + , quotePat = parse >=> dataToPatQ wildSpanPos + , quoteDec = error "this quasiquoter does not support declarations" + , quoteType = error "this quasiquoter does not support types" + } + where + -- | Given a parser and an input string, turn it into the corresponding Haskell expression/pattern. + parse inp = do + Loc{ loc_start = (r,c) } <- location + + -- Run the parser + case execParser p (inputStreamFromString inp) (Position 0 r c) of + Left (ParseFail _ msg) -> fail msg + Right x -> pure x + + -- | Replace 'Span' and 'Position' with wild patterns + wildSpanPos :: Typeable b => b -> Maybe (Q Pat) + wildSpanPos x = ((cast x :: Maybe Span) $> wildP) <|> ((cast x :: Maybe Position) $> wildP) + +castExpr :: Typeable b => b -> Maybe (String, Q Exp -> Q Exp) +castExpr b = do + (EmbeddedExpr _ code _) <- cast b :: Maybe (Expr Span) + pure (code, id) + +castIdent :: Typeable b => b -> Maybe (String, Q Exp -> Q Exp) +castIdent b = do + (Ident (HaskellName code) _ _) <- cast b :: Maybe Ident + pure (code, (\e -> [| mkIdent $(e) |])) + +castTokenIDENT :: Typeable b => b -> Maybe (String, Q Exp -> Q Exp) +castTokenIDENT b = do + (Token spn (EmbeddedIdent code)) <- cast b :: Maybe TokenTree + pure (code, \e -> [| Token $(liftData spn) (IdentTok $ mkIdent $(e)) |]) + +castTokenEXPR :: Typeable b => b -> Maybe (String, Q Exp -> Q Exp) +castTokenEXPR b = do + (Token spn (EmbeddedCode code)) <- cast b :: Maybe TokenTree + pure (code, \e -> [| Token $(liftData spn) $(e) |]) + +--(EmbeddedExpr _ code _) <- (cast b :: Maybe (Expr Span)) + +embeddedCode :: Typeable b => b -> Maybe (Q Exp) +embeddedCode b = do + (code, tsfm) <- castExpr b <|> castIdent b <|> castTokenIDENT b <|> castTokenEXPR b + pure $ case LHM.parseExp code of + Left err -> error $ "Could not parse embedded Haskell code: " ++ err + Right expTH -> tsfm $ return expTH + +-- | Quasiquoter for literals (see 'Language.Rust.Syntax.Lit'). +-- +-- >>> void [lit| 1.4e29f64 |] +-- Float 1.4e29 F64 () +-- +lit :: QuasiQuoter +lit = quoter (const Nothing) parseLit + +-- | Quasiquoter for attributes (see 'Language.Rust.Syntax.Attribute') +-- +-- >>> void [attr| #[no_mangle] |] +-- Attribute Outer (Path False [PathSegment "no_mangle" Nothing ()] ()) (Stream []) () +-- +attr :: QuasiQuoter +attr = quoter embeddedCode parseAttr + +-- | Quasiquoter for types (see 'Language.Rust.Syntax.Ty') +-- +-- >>> void [ty| &(_,_) |] +-- Rptr Nothing Immutable (TupTy [Infer (),Infer ()] ()) () +-- +ty :: QuasiQuoter +ty = quoter embeddedCode parseTy + +-- | Quasiquoter for patterns (see 'Language.Rust.Syntax.Pat') +-- +-- >>> void [pat| x @ 1...5 |] +-- IdentP (ByValue Immutable) "x" (Just (RangeP (Lit [] (Int Dec 1 Unsuffixed ()) ()) +-- (Lit [] (Int Dec 5 Unsuffixed ()) ()) ())) () +-- +pat :: QuasiQuoter +pat = quoter embeddedCode parsePat + +-- | Quasiquoter for statements (see 'Language.Rust.Syntax.Stmt') +-- +-- >>> void [stmt| let x = 4i32; |] +-- Local (IdentP (ByValue Immutable) "x" Nothing ()) Nothing (Just (Lit [] (Int Dec 4 I32 ()) ())) [] () +-- +stmt :: QuasiQuoter +stmt = quoter embeddedCode parseStmt +stmts :: QuasiQuoter +stmts = quoter embeddedCode parseStmts + +-- | Quasiquoter for expressions (see 'Language.Rust.Syntax.Expr') +-- +-- >>> void [expr| (x,) |] +-- TupExpr [] [PathExpr [] Nothing (Path False [PathSegment "x" Nothing ()] ()) ()] () +-- +expr :: QuasiQuoter +expr = quoter embeddedCode parseExpr + +-- | Quasiquoter for items (see 'Language.Rust.Syntax.Item') +-- +-- >>> void [item| type Unit = (); |] +-- TyAlias [] InheritedV "Unit" (TupTy [] ()) (Generics [] [] (WhereClause [] ()) ()) () +-- +item :: QuasiQuoter +item = quoter embeddedCode parseItem +items :: QuasiQuoter +items = quoter embeddedCode parseItems + +-- | Quasiquoter for a whole source file (see 'Language.Rust.Syntax.SourceFile') +-- +-- >>> void [sourceFile| fn main() { } |] +-- SourceFile Nothing [] [Fn [] InheritedV "main" +-- (FnDecl [] Nothing False ()) +-- Normal NotConst Rust +-- (Generics [] [] (WhereClause [] ()) ()) +-- (Block [] Normal ()) ()] +-- +sourceFile :: QuasiQuoter +sourceFile = quoter embeddedCode parseSourceFile + +-- | Quasiquoter for blocks (see 'Language.Rust.Syntax.Block') +-- +-- >>> void [block| unsafe { 1i32 } |] +-- Block [NoSemi (Lit [] (Int Dec 1 I32 ()) ()) ()] Unsafe () +-- +block :: QuasiQuoter +block = quoter embeddedCode parseBlock + +-- | Quasiquoter for impl items (see 'Language.Rust.Syntax.ImplItem') +-- +-- >>> void [implItem| type Item = (); |] +-- TypeI [] InheritedV Final "Item" (TupTy [] ()) () +-- +implItem :: QuasiQuoter +implItem = quoter embeddedCode parseImplItem +implItems :: QuasiQuoter +implItems = quoter embeddedCode parseImplItems + +-- | Quasiquoter for trait items (see 'Language.Rust.Syntax.TraitItem') +-- +-- >>> void [traitItem| type Item; |] +-- TypeT [] "Item" [] Nothing () +-- +traitItem :: QuasiQuoter +traitItem = quoter embeddedCode parseTraitItem + +-- | Quasiquoter for token trees (see 'Language.Rust.Syntax.TokenTree') +-- +-- >>> [tokenTree| fn |] +-- Token (Span (Position 1 2 14) (Position 3 2 16)) fn +-- +tokenTree :: QuasiQuoter +tokenTree = quoter embeddedCode parseTt + diff --git a/src/Language/Rust/Syntax.hs b/src/Language/Rust/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Syntax.hs @@ -0,0 +1,29 @@ +{-| +Module : Language.Rust.Syntax +Description : Syntax data defintions +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : GHC + +This module defines Haskell data types corresponding to the abstract syntax tree(s) of the Rust +language, based on the definitions @rustc@ uses (defined in @libsyntax@) whenever possible. +Unfortunately, since the internals of @rustc@ are not exposed, there are no official +docs. are the +unofficial docs. +-} + +module Language.Rust.Syntax ( + -- * Abstract syntax trees + module Language.Rust.Syntax.AST, + -- * Tokens + module Language.Rust.Syntax.Token, +) where + +import Language.Rust.Syntax.AST +import Language.Rust.Syntax.Token + +-- Using import/export shortcut screws up Haddock +{-# ANN module "HLint: ignore Use import/export shortcut" #-} + diff --git a/src/Language/Rust/Syntax/AST.hs b/src/Language/Rust/Syntax/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Syntax/AST.hs @@ -0,0 +1,1206 @@ +{-| +Module : Language.Rust.Syntax.AST +Description : Non-token AST definitions +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : GHC +-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Language.Rust.Syntax.AST ( + -- ** Top level + SourceFile(..), + + -- ** General + Mutability(..), + Unsafety(..), + Arg(..), + FnDecl(..), + + -- ** Paths + Path(..), + PathParameters(..), + PathSegment(..), + QSelf(..), + + -- ** Attributes + Attribute(..), + AttrStyle(..), + + -- ** Literals + Lit(..), + byteStr, + Suffix(..), + suffix, + IntRep(..), + StrStyle(..), + + -- ** Expressions + Expr(..), + Abi(..), + Arm(..), + UnOp(..), + BinOp(..), + Label(..), + CaptureBy(..), + Movability(..), + Field(..), + RangeLimits(..), + + -- ** Types and lifetimes + Ty(..), + Generics(..), + Lifetime(..), + LifetimeDef(..), + TyParam(..), + TyParamBound(..), + partitionTyParamBounds, + WhereClause(..), + whereClause, + WherePredicate(..), + PolyTraitRef(..), + TraitRef(..), + TraitBoundModifier(..), + + -- ** Patterns + Pat(..), + BindingMode(..), + FieldPat(..), + + -- ** Statements + Stmt(..), + + -- ** Items + Item(..), + ForeignItem(..), + ImplItem(..), + TraitItem(..), + Defaultness(..), + ImplPolarity(..), + StructField(..), + Variant(..), + VariantData(..), + UseTree(..), + Visibility(..), + Constness(..), + MethodSig(..), + + -- ** Blocks + Block(..), + + -- ** Token trees + TokenTree(..), + TokenStream(..), + unconsTokenStream, + Nonterminal(..), + Mac(..), + MacStmtStyle(..), +) where + +import Language.Rust.Data.Ident ( Ident, Name ) +import Language.Rust.Data.Position +import {-# SOURCE #-} Language.Rust.Syntax.Token ( Delim, Token ) + +import GHC.Generics ( Generic, Generic1 ) + +import Control.DeepSeq ( NFData ) +import Data.Data ( Data ) +import Data.Typeable ( Typeable ) + +import Data.Char ( ord ) +import Data.List ( partition ) +import Language.Rust.Parser.NonEmpty ( NonEmpty(..) ) +import Data.Semigroup as Sem ( Semigroup(..) ) +import Data.Word ( Word8 ) + +-- | ABIs support by Rust's foreign function interface (@syntax::abi::Abi@). Note that of these, +-- only 'Rust', 'C', 'System', 'RustIntrinsic', 'RustCall', and 'PlatformIntrinsic' and 'Unadjusted' +-- are cross-platform - all the rest are platform-specific. +-- +-- Example: @\"C\"@ as in @extern \"C\" fn foo(x: i32);@ +data Abi + -- Platform-specific ABIs + = Cdecl + | Stdcall + | Fastcall + | Vectorcall + | Aapcs + | Win64 + | SysV64 + | PtxKernel + | Msp430Interrupt + | X86Interrupt + -- Cross-platform ABIs + | Rust + | C + | System + | RustIntrinsic + | RustCall + | PlatformIntrinsic + | Unadjusted + deriving (Eq, Ord, Show, Read, Enum, Bounded, Typeable, Data, Generic, NFData) + +-- | An argument in a function header (@syntax::ast::Arg@, except with @SelfKind@ and @ExplicitSelf@ +-- inlined). +-- +-- Example: @x: usize@, @self@, @mut self@, @&self@, @&'lt mut self@, @mut self: Foo@ as in +-- +-- @ +-- trait Foo { +-- // Regular argument +-- fn new(x: usize) -> Foo; +-- +-- // Self argument, by value +-- fn foo(self) -> i32; +-- fn bar(mut self); +-- +-- // Self argument, by reference +-- fn baz(&self) -> Bar\<'lt\>; +-- fn qux(&'lt mut self) -> Bar\<'lt\>; +-- +-- // Explicit self argument +-- fn quux(mut self: Foo); +-- } +-- @ +data Arg a + = Arg (Maybe (Pat a)) (Ty a) a -- ^ Regular argument + | SelfValue Mutability a -- ^ Self argument, by value + | SelfRegion (Maybe (Lifetime a)) Mutability a -- ^ Self argument, by reference + | SelfExplicit (Ty a) Mutability a -- ^ Explicit self argument + deriving (Eq, Ord, Show, Functor, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Arg a) where + spanOf (Arg _ _ s) = spanOf s + spanOf (SelfValue _ s) = spanOf s + spanOf (SelfRegion _ _ s) = spanOf s + spanOf (SelfExplicit _ _ s) = spanOf s + +-- | An arm of a 'Match' expression (@syntax::ast::Arm@). An arm has at least one patten, possibly a +-- guard expression, and a body expression. +-- +-- Example: @n if n % 4 == 3 => { println!("{} % 4 = 3", n) }@ as in +-- +-- @ +-- match n { +-- n if n % 4 == 3 => { println!("{} % 4 = 3", n) } +-- n if n % 4 == 1 => { println!("{} % 4 = 1", n) } +-- _ => println!("{} % 2 = 0", n) +-- } +-- @ +data Arm a = Arm [Attribute a] (NonEmpty (Pat a)) (Maybe (Expr a)) (Expr a) a + deriving (Eq, Ord, Show, Functor, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Arm a) where spanOf (Arm _ _ _ _ s) = spanOf s + +-- | 'Attribute's are annotations for other AST nodes (@syntax::ast::Attribute@). Note that +-- doc-comments are promoted to attributes. +-- +-- Example: @#[derive(Copy,Clone)]@ as in +-- +-- @ +-- #[derive(Clone, Copy)] +-- struct Complex { re: f32, im: f32 } +-- @ +data Attribute a + -- | Regular attributes of the form @#[...]@ + = Attribute AttrStyle (Path a) TokenStream a + -- | Doc comment attributes. The 'Bool' argument identifies if the comment is inline or not, and + -- the 'Name' contains the actual doc comment content. + | SugaredDoc AttrStyle Bool Name a + deriving (Eq, Ord, Show, Functor, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Attribute a) where + spanOf (Attribute _ _ _ s) = spanOf s + spanOf (SugaredDoc _ _ _ s) = spanOf s + +-- | Distinguishes between attributes that are associated with the node that follows them and +-- attributes that are associated with the node that contains them (@syntax::ast::AttrStyle@). +-- These two cases need to be distinguished only for pretty printing - they are otherwise +-- fundamentally equivalent. +-- +-- Example: @#[repr(C)]@ is an outer attribute while @#![feature(slice_patterns)]@ is an inner one +data AttrStyle = Outer | Inner deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | Binary operators, used in the 'Binary' and 'AssignOp' constructors of 'Expr' +-- (@syntax::ast::BinOp@). +-- +-- Example: @+@ as in @1 + 1@ or @1 += 1@ +data BinOp + = AddOp -- ^ @+@ operator (addition) + | SubOp -- ^ @-@ operator (subtraction) + | MulOp -- ^ @*@ operator (multiplication) + | DivOp -- ^ @/@ operator (division) + | RemOp -- ^ @%@ operator (modulus) + | AndOp -- ^ @&&@ operator (logical and) + | OrOp -- ^ @||@ operator (logical or) + | BitXorOp -- ^ @^@ operator (bitwise xor) + | BitAndOp -- ^ @&@ operator (bitwise and) + | BitOrOp -- ^ @|@ operator (bitwise or) + | ShlOp -- ^ @<<@ operator (shift left) + | ShrOp -- ^ @>>@ operator (shift right) + | EqOp -- ^ @==@ operator (equality) + | LtOp -- ^ @< @operator (less than) + | LeOp -- ^ @<=@ operator (less than or equal to) + | NeOp -- ^ @!=@ operator (not equal to) + | GeOp -- ^ @>=@ operator (greater than or equal to) + | GtOp -- ^ @>@ operator (greater than) + deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | Describes how a value bound to an identifier in a pattern is going to be borrowed +-- (@syntax::ast::BindingMode@). +-- +-- Example: @&mut@ in @|&mut x: i32| -> { x += 1 }@ +data BindingMode + = ByRef Mutability + | ByValue Mutability + deriving (Eq, Ord, Show, Typeable, Data, Generic, NFData) + +-- | A curly brace delimited sequence of statements (@syntax::ast::Block@). The last statement in +-- the block can always be a 'NoSemi' expression. +-- +-- Example: @{ let x = 1; return x + y }@ as in @fn foo() { let x = 1; return x + y }@ +data Block a = Block [Stmt a] Unsafety a + deriving (Eq, Ord, Show, Functor, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Block a) where spanOf (Block _ _ s) = spanOf s + +-- | Describes how a 'Closure' should close over its free variables (@syntax::ast::CaptureBy@). +data CaptureBy + = Value -- ^ make copies of free variables closed over (@move@ closures) + | Ref -- ^ borrow free variables closed over + deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | Const annotation to specify if a function or method is allowed to be called in constants +-- context with constant arguments (@syntax::ast::Constness@). [Relevant +-- RFC](https://github.com/rust-lang/rfcs/blob/master/text/0911-const-fn.md) +-- +-- Example: @const@ in @const fn inc(x: i32) -> i32 { x + 1 }@ +data Constness = Const | NotConst deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | An 'ImplItem' can be marked @default@ (@syntax::ast::Defaultness@). +data Defaultness = Default | Final deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | Expression (@syntax::ast::Expr@). Note that Rust pushes into expressions an unusual number +-- of constructs including @if@, @while@, @match@, etc. +data Expr a + -- | box expression (example: @box x@) + = Box [Attribute a] (Expr a) a + -- | in-place expression - first 'Expr' is the place, second one is the value (example: @x <- y@) + | InPlace [Attribute a] (Expr a) (Expr a) a + -- | array literal (example: @[a, b, c, d]@) + | Vec [Attribute a] [Expr a] a + -- | function call where the first 'Expr' is the function itself, and the @['Expr']@ is the list of + -- arguments (example: @foo(1,2,x)@) + | Call [Attribute a] (Expr a) [Expr a] a + -- | method call where the first 'Expr' is the receiver, 'Ident' is the method name, @Maybe ['Ty']@ + -- the list of type arguments and '[Expr]' the arguments to the method. + -- (example: @x.foo::\(a, b, c, d)@ + | MethodCall [Attribute a] (Expr a) Ident (Maybe [Ty a]) [Expr a] a + -- | tuple (example: @(a, b, c ,d)@) + | TupExpr [Attribute a] [Expr a] a + -- | binary operation (example: @a + b@, @a * b@) + | Binary [Attribute a] BinOp (Expr a) (Expr a) a + -- | unary operation (example: @!x@, @*x@) + | Unary [Attribute a] UnOp (Expr a) a + -- | literal (example: @1@, @"foo"@) + | Lit [Attribute a] (Lit a) a + -- | cast (example: @foo as f64@) + | Cast [Attribute a] (Expr a) (Ty a) a + -- | type annotation (example: @x: i32@) + | TypeAscription [Attribute a] (Expr a) (Ty a) a + -- | if expression, with an optional @else@ block. In the case the @else@ block is missing, the + -- type of the @if@ is inferred to be @()@. (example: @if 1 == 2 { (1,1) } else { (2,2) }@ + | If [Attribute a] (Expr a) (Block a) (Maybe (Expr a)) a + -- | if-let expression with an optional else block (example: @if let Some(x) = None { () }@) + | IfLet [Attribute a] (NonEmpty (Pat a)) (Expr a) (Block a) (Maybe (Expr a)) a + -- | while loop, with an optional label (example: @'lbl: while 1 == 1 { break 'lbl }@) + | While [Attribute a] (Expr a) (Block a) (Maybe (Label a)) a + -- | while-let loop, with an optional label (example: @while let Some(x) = None { x }@) + | WhileLet [Attribute a] (NonEmpty (Pat a)) (Expr a) (Block a) (Maybe (Label a)) a + -- | for loop, with an optional label (example: @for i in 1..10 { println!("{}",i) }@) + | ForLoop [Attribute a] (Pat a) (Expr a) (Block a) (Maybe (Label a)) a + -- | conditionless loop (can be exited with 'Break', 'Continue', or 'Ret') + | Loop [Attribute a] (Block a) (Maybe (Label a)) a + -- | match block + | Match [Attribute a] (Expr a) [Arm a] a + -- | closure (example: @move |a, b, c| { a + b + c }@) + | Closure [Attribute a] Movability CaptureBy (FnDecl a) (Expr a) a + -- | (possibly unsafe) block (example: @unsafe { 1 }@) + | BlockExpr [Attribute a] (Block a) a + -- | a catch block (example: @do catch { 1 }@) + | Catch [Attribute a] (Block a) a + -- | assignment (example: @a = foo()@) + | Assign [Attribute a] (Expr a) (Expr a) a + -- | assignment with an operator (example: @a += 1@) + | AssignOp [Attribute a] BinOp (Expr a) (Expr a) a + -- | access of a named struct field (example: @obj.foo@) + | FieldAccess [Attribute a] (Expr a) Ident a + -- | access of an unnamed field of a struct or tuple-struct (example: @foo.0@) + | TupField [Attribute a] (Expr a) Int a + -- | indexing operation (example: @foo[2]@) + | Index [Attribute a] (Expr a) (Expr a) a + -- | range (examples: @1..2@, @1..@, @..2@, @1...2@, @1...@, @...2@) + | Range [Attribute a] (Maybe (Expr a)) (Maybe (Expr a)) RangeLimits a + -- | variable reference + | PathExpr [Attribute a] (Maybe (QSelf a)) (Path a) a + -- | referencing operation (example: @&a or &mut a@) + | AddrOf [Attribute a] Mutability (Expr a) a + -- | @break@ with an optional label and expression denoting what to break out of and what to + -- return (example: @break 'lbl 1@) + | Break [Attribute a] (Maybe (Label a)) (Maybe (Expr a)) a + -- | @continue@ with an optional label (example: @continue@) + | Continue [Attribute a] (Maybe (Label a)) a + -- | @return@ with an optional value to be returned (example: @return 1@) + | Ret [Attribute a] (Maybe (Expr a)) a + -- | macro invocation before expansion + | MacExpr [Attribute a] (Mac a) a + -- | struct literal expression (examples: @Foo { x: 1, y: 2 }@ or @Foo { x: 1, ..base }@) + | Struct [Attribute a] (Path a) [Field a] (Maybe (Expr a)) a + -- | array literal constructed from one repeated element (example: @[1; 5]@) + | Repeat [Attribute a] (Expr a) (Expr a) a + -- | no-op: used solely so we can pretty print faithfully + | ParenExpr [Attribute a] (Expr a) a + -- | sugar for error handling with @Result@ (example: @parsed_result?@) + | Try [Attribute a] (Expr a) a + -- | @yield@ with an optional value to yield (example: @yield 1@) + | Yield [Attribute a] (Maybe (Expr a)) a + -- | embedded Haskell expressions for use by quasiquoters + | EmbeddedExpr [Attribute a] String a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Expr a) where + spanOf (Box _ _ s) = spanOf s + spanOf (InPlace _ _ _ s) = spanOf s + spanOf (Vec _ _ s) = spanOf s + spanOf (Call _ _ _ s) = spanOf s + spanOf (MethodCall _ _ _ _ _ s) = spanOf s + spanOf (TupExpr _ _ s) = spanOf s + spanOf (Binary _ _ _ _ s) = spanOf s + spanOf (Unary _ _ _ s) = spanOf s + spanOf (Lit _ _ s) = spanOf s + spanOf (Cast _ _ _ s) = spanOf s + spanOf (TypeAscription _ _ _ s) = spanOf s + spanOf (If _ _ _ _ s) = spanOf s + spanOf (IfLet _ _ _ _ _ s) = spanOf s + spanOf (While _ _ _ _ s) = spanOf s + spanOf (WhileLet _ _ _ _ _ s) = spanOf s + spanOf (ForLoop _ _ _ _ _ s) = spanOf s + spanOf (Loop _ _ _ s) = spanOf s + spanOf (Match _ _ _ s) = spanOf s + spanOf (Closure _ _ _ _ _ s) = spanOf s + spanOf (BlockExpr _ _ s) = spanOf s + spanOf (Catch _ _ s) = spanOf s + spanOf (Assign _ _ _ s) = spanOf s + spanOf (AssignOp _ _ _ _ s) = spanOf s + spanOf (FieldAccess _ _ _ s) = spanOf s + spanOf (TupField _ _ _ s) = spanOf s + spanOf (Index _ _ _ s) = spanOf s + spanOf (Range _ _ _ _ s) = spanOf s + spanOf (PathExpr _ _ _ s) = spanOf s + spanOf (AddrOf _ _ _ s) = spanOf s + spanOf (Break _ _ _ s) = spanOf s + spanOf (Continue _ _ s) = spanOf s + spanOf (Ret _ _ s) = spanOf s + spanOf (MacExpr _ _ s) = spanOf s + spanOf (Struct _ _ _ _ s) = spanOf s + spanOf (Repeat _ _ _ s) = spanOf s + spanOf (ParenExpr _ _ s) = spanOf s + spanOf (Try _ _ s) = spanOf s + spanOf (Yield _ _ s) = spanOf s + spanOf (EmbeddedExpr _ _ s) = spanOf s + +-- | Field in a struct literal expression (@syntax::ast::Field@). +-- +-- Example: @x: 1@ in @Point { x: 1, y: 2 }@ +data Field a = Field Ident (Maybe (Expr a)) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Field a) where spanOf (Field _ _ s) = spanOf s + +-- | Field in a struct literal pattern (@syntax::ast::FieldPat@). The field name 'Ident' is optional +-- but, when it is 'Nothing', the pattern the field is destructured to must be 'IdentP'. +-- +-- Example: @x@ in @Point { x, y }@ +data FieldPat a = FieldPat (Maybe Ident) (Pat a) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (FieldPat a) where spanOf (FieldPat _ _ s) = spanOf s + +-- | Header (not the body) of a function declaration (@syntax::ast::FnDecl@). The 'Bool' argument +-- indicates whether the header is variadic (so whether the argument list ends in @...@). +-- +-- Example: @(bar: i32) -> i32@ as in +-- +-- @ +-- fn foo(bar: i32) -> i32 { +-- bar + 2 +-- } +-- @ +data FnDecl a = FnDecl [Arg a] (Maybe (Ty a)) Bool a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (FnDecl a) where spanOf (FnDecl _ _ _ s) = spanOf s + +-- | An item within an extern block (@syntax::ast::ForeignItem@ with @syntax::ast::ForeignItemKind@ +-- inlined). +-- +-- Example: @static ext: u8@ in @extern \"C\" { static ext: u8 }@ +data ForeignItem a + -- | Foreign function + -- + -- Example: @fn foo(x: i32);@ in @extern \"C\" { fn foo(x: i32); }@ + = ForeignFn [Attribute a] (Visibility a) Ident (FnDecl a) (Generics a) a + -- | Foreign static variable, optionally mutable + -- + -- Example: @static mut bar: i32;@ in @extern \"C\" { static mut bar: i32; }@ + | ForeignStatic [Attribute a] (Visibility a) Ident (Ty a) Mutability a + -- | Foreign type + -- + -- Example: @type Boo;@ + | ForeignTy [Attribute a] (Visibility a) Ident a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (ForeignItem a) where + spanOf (ForeignFn _ _ _ _ _ s) = spanOf s + spanOf (ForeignStatic _ _ _ _ _ s) = spanOf s + spanOf (ForeignTy _ _ _ s) = spanOf s + +-- | Represents lifetimes and type parameters attached to a declaration of a functions, enums, +-- traits, etc. (@syntax::ast::Generics@). Note that lifetime definitions are always required to be +-- before the type parameters. +-- +-- This one AST node is also a bit weird: it is the only node whose source representation is not +-- compact - the lifetimes and type parameters occur by themselves between @\<@ and @\>@ then a +-- bit further the where clause occurs after a @where@. +-- +-- Example: @\<\'a, \'b: \'c, T: \'a\>@ and @where Option\: Copy@ as in +-- +-- @ +-- fn nonsense\<\'a, \'b: \'c, T: \'a\>(x: i32) -\> i32 +-- where Option\: Copy { +-- 1 +-- }@. +data Generics a = Generics [LifetimeDef a] [TyParam a] (WhereClause a) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +-- | Extract the where clause from a 'Generics'. +whereClause :: Generics a -> WhereClause a +whereClause (Generics _ _ wc _) = wc + +instance Located a => Located (Generics a) where spanOf (Generics _ _ _ s) = spanOf s + +instance Sem.Semigroup a => Sem.Semigroup (Generics a) where + Generics lt1 tp1 wc1 x1 <> Generics lt2 tp2 wc2 x2 = Generics lts tps wcs xs + where lts = lt1 ++ lt2 + tps = tp1 ++ tp2 + wcs = wc1 <> wc2 + xs = x1 <> x2 + +instance (Sem.Semigroup a, Monoid a) => Monoid (Generics a) where + mappend = (<>) + mempty = Generics [] [] mempty mempty + +-- | An item within an impl (@syntax::ast::ImplItem@ with @syntax::ast::ImplItemKind@ inlined). +-- +-- Examples: +-- +-- @ +-- impl MyTrait { +-- // Associated constant +-- const ID: i32 = 1; +-- +-- // Method +-- fn area(&self) -> f64 { 1f64 } +-- +-- // Associated type +-- type N = i32; +-- +-- // Call to a macro +-- foo!{} +-- } +-- @ +data ImplItem a + -- | Associated constant + = ConstI [Attribute a] (Visibility a) Defaultness Ident (Ty a) (Expr a) a + -- | Method + | MethodI [Attribute a] (Visibility a) Defaultness Ident (Generics a) (MethodSig a) (Block a) a + -- | Associated type + | TypeI [Attribute a] (Visibility a) Defaultness Ident (Ty a) a + -- | Macro call + | MacroI [Attribute a] Defaultness (Mac a) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (ImplItem a) where + spanOf (ConstI _ _ _ _ _ _ s) = spanOf s + spanOf (MethodI _ _ _ _ _ _ _ s) = spanOf s + spanOf (TypeI _ _ _ _ _ s) = spanOf s + spanOf (MacroI _ _ _ s) = spanOf s + +-- | For traits with a default impl, one can "opt out" of that impl with a negative impl, by adding +-- @!@ mark before the trait name. [RFC on builtin +-- traits](https://github.com/rust-lang/rfcs/blob/master/text/0019-opt-in-builtin-traits.md) +-- +-- Example: @!@ as in @impl !Trait for Foo { }@ +data ImplPolarity = Positive | Negative deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | A top-level item, possibly in a 'Mod' or a 'ItemStmt' (@syntax::ast::Item@ with +-- @syntax::ast::ItemKind@ inlined). +-- +-- Example: @fn main() { return; }@ +data Item a + -- | extern crate item, with optional original crate name. + -- Examples: @extern crate foo@ or @extern crate foo_bar as foo@ + = ExternCrate [Attribute a] (Visibility a) Ident (Maybe Ident) a + -- | use declaration (@use@ or @pub use@) item. + -- Examples: @use foo;@, @use foo::bar;@, or @use foo::bar as FooBar;@ + | Use [Attribute a] (Visibility a) (UseTree a) a + -- | static item (@static@ or @pub static@). + -- Examples: @static FOO: i32 = 42;@ or @static FOO: &'static str = "bar";@ + | Static [Attribute a] (Visibility a) Ident (Ty a) Mutability (Expr a) a + -- | constant item (@const@ or @pub const@). + -- Example: @const FOO: i32 = 42;@ + | ConstItem [Attribute a] (Visibility a) Ident (Ty a) (Expr a) a + -- | function declaration (@fn@ or @pub fn@). + -- Example: @fn foo(bar: usize) -\> usize { .. }@ + | Fn [Attribute a] (Visibility a) Ident (FnDecl a) Unsafety Constness Abi (Generics a) (Block a) a + -- | module declaration (@mod@ or @pub mod@) (@syntax::ast::Mod@). + -- Example: @mod foo;@ or @mod foo { .. }@ + | Mod [Attribute a] (Visibility a) Ident (Maybe [Item a]) a + -- | external module (@extern@ or @pub extern@) (@syntax::ast::ForeignMod@). + -- Example: @extern { .. }@ or @extern \"C\" { .. }@ + | ForeignMod [Attribute a] (Visibility a) Abi [ForeignItem a] a + -- | type alias (@type@ or @pub type@). + -- Example: @type Foo = Bar\;@ + | TyAlias [Attribute a] (Visibility a) Ident (Ty a) (Generics a) a + -- | enum definition (@enum@ or @pub enum@) (@syntax::ast::EnumDef@). + -- Example: @enum Foo\ { C(A), D(B) }@ + | Enum [Attribute a] (Visibility a) Ident [Variant a] (Generics a) a + -- | struct definition (@struct@ or @pub struct@). + -- Example: @struct Foo\ { x: A }@ + | StructItem [Attribute a] (Visibility a) Ident (VariantData a) (Generics a) a + -- | union definition (@union@ or @pub union@). + -- Example: @union Foo\ { x: A, y: B }@ + | Union [Attribute a] (Visibility a) Ident (VariantData a) (Generics a) a + -- | trait declaration (@trait@ or @pub trait@). + -- Example: @trait Foo { .. }@ or @trait Foo\ { .. }@ + | Trait [Attribute a] (Visibility a) Ident Bool Unsafety (Generics a) [TyParamBound a] [TraitItem a] a + -- | trait alias + -- Example: @trait Foo = Bar + Quux;@ + | TraitAlias [Attribute a] (Visibility a) Ident (Generics a) (NonEmpty (TyParamBound a)) a + -- | implementation + -- Example: @impl\ Foo\ { .. }@ or @impl\ Trait for Foo\ { .. }@ + | Impl [Attribute a] (Visibility a) Defaultness Unsafety ImplPolarity (Generics a) (Maybe (TraitRef a)) (Ty a) [ImplItem a] a + -- | generated from a call to a macro + -- Example: @foo!{ .. }@ + | MacItem [Attribute a] (Maybe Ident) (Mac a) a + -- | definition of a macro via @macro_rules@ + -- Example: @macro_rules! foo { .. }@ + | MacroDef [Attribute a] Ident TokenStream a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Item a) where + spanOf (ExternCrate _ _ _ _ s) = spanOf s + spanOf (Use _ _ _ s) = spanOf s + spanOf (Static _ _ _ _ _ _ s) = spanOf s + spanOf (ConstItem _ _ _ _ _ s) = spanOf s + spanOf (Fn _ _ _ _ _ _ _ _ _ s) = spanOf s + spanOf (Mod _ _ _ _ s) = spanOf s + spanOf (ForeignMod _ _ _ _ s) = spanOf s + spanOf (TyAlias _ _ _ _ _ s) = spanOf s + spanOf (Enum _ _ _ _ _ s) = spanOf s + spanOf (StructItem _ _ _ _ _ s) = spanOf s + spanOf (Union _ _ _ _ _ s) = spanOf s + spanOf (Trait _ _ _ _ _ _ _ _ s) = spanOf s + spanOf (TraitAlias _ _ _ _ _ s) = spanOf s + spanOf (Impl _ _ _ _ _ _ _ _ _ s) = spanOf s + spanOf (MacItem _ _ _ s) = spanOf s + spanOf (MacroDef _ _ _ s) = spanOf s + +-- | Used to annotate loops, breaks, continues, etc. +data Label a = Label Name a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Label a) where spanOf (Label _ s) = spanOf s + +-- | A lifetime is a name for a scope in a program (@syntax::ast::Lifetime@). One of the novel +-- features of Rust is that code can be parametrized over lifetimes. Syntactically, they are like +-- regular identifiers, but start with a tick @\'@ mark. The 'Name' argument is /not/ supposed to +-- include that tick. +-- +-- Examples: @\'a@ or @\'static@ +data Lifetime a = Lifetime Name a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Lifetime a) where spanOf (Lifetime _ s) = spanOf s + +-- | A lifetime definition, introducing a lifetime and the other lifetimes that bound it +-- (@syntax::ast::LifetimeDef@). +-- +-- Example: @\'a: \'b + \'c + \'d@ +data LifetimeDef a = LifetimeDef [Attribute a] (Lifetime a) [Lifetime a] a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (LifetimeDef a) where spanOf (LifetimeDef _ _ _ s) = spanOf s + +-- | This is the fundamental unit of parsing - it represents the contents of one source file. It is +-- composed of an optional shebang line, inner attributes that follow, and then the module items. +-- +-- Example: +-- +-- @ +-- #!\/usr\/bin/env rust +-- +-- #![allow(dead_code)] +-- +-- fn main() { +-- println!("Hello world") +-- } +-- @ +data SourceFile a + = SourceFile (Maybe Name) [Attribute a] [Item a] + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +-- | The suffix on a literal (unifies @syntax::ast::LitIntType@, @syntax::ast::IntTy@, +-- @syntax::ast::UintTy@, and @syntax::ast::FloatTy@). As of today, only numeric types can have +-- suffixes, but the possibility of adding more (possibly arbitrary) suffixes to literals in general +-- is being kept open intentionally. [RFC about future-proofing literal +-- suffixes](https://github.com/rust-lang/rfcs/blob/master/text/0463-future-proof-literal-suffixes.md) +-- +-- Examples: @i32@, @isize@, and @f32@ +data Suffix + = Unsuffixed + | Is | I8 | I16 | I32 | I64 | I128 + | Us | U8 | U16 | U32 | U64 | U128 + | F32 | F64 + deriving (Eq, Ord, Show, Enum, Bounded, Typeable, Data, Generic, NFData) + +-- | Literals in Rust (@syntax::ast::Lit@). As discussed in 'Suffix', Rust AST is designed to parse +-- suffixes for all literals, even if they are currently only valid on 'Int' and 'Float' literals. +data Lit a + = Str String StrStyle Suffix a -- ^ string (example: @"foo"@) + | ByteStr [Word8] StrStyle Suffix a -- ^ byte string (example: @b"foo"@) + | Char Char Suffix a -- ^ character (example: @\'a\'@) + | Byte Word8 Suffix a -- ^ byte (example: @b\'f\'@) + | Int IntRep Integer String Suffix a -- ^ integer (example: @1i32@) + | Float Double Suffix a -- ^ float (example: @1.12e4@) + | Bool Bool Suffix a -- ^ boolean (example: @true@) + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Lit a) where + spanOf (Str _ _ _ s) = spanOf s + spanOf (ByteStr _ _ _ s) = spanOf s + spanOf (Char _ _ s) = spanOf s + spanOf (Byte _ _ s) = spanOf s + spanOf (Int _ _ _ _ s) = spanOf s + spanOf (Float _ _ s) = spanOf s + spanOf (Bool _ _ s) = spanOf s + +-- | Smart constructor for 'ByteStr'. +byteStr :: String -> StrStyle -> Suffix -> a -> Lit a +byteStr s = ByteStr (map (fromIntegral . ord) s) + +-- | Extract the suffix from a 'Lit'. +suffix :: Lit a -> Suffix +suffix (Str _ _ s _) = s +suffix (ByteStr _ _ s _) = s +suffix (Char _ s _) = s +suffix (Byte _ s _) = s +suffix (Int _ _ _ s _) = s +suffix (Float _ s _) = s +suffix (Bool _ s _) = s + +-- | The base of the number in an @Int@ literal can be binary (e.g. @0b1100@), octal (e.g. @0o14@), +-- decimal (e.g. @12@), or hexadecimal (e.g. @0xc@). +data IntRep + = Bin + | Oct + | Dec + | Hex + deriving (Eq, Ord, Show, Enum, Bounded, Typeable, Data, Generic, NFData) + +-- | Represents a macro invocation (@syntax::ast::Mac@). The 'Path' indicates which macro is being +-- invoked, and the 'TokenStream' contains the source of the macro invocation. +data Mac a = Mac (Path a) TokenStream a deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Mac a) where spanOf (Mac _ _ s) = spanOf s + +-- | Style of the macro statement (@syntax::ast::MacStmtStyle@). +data MacStmtStyle + = SemicolonMac -- ^ trailing semicolon (example: @foo! { ... };@, @ foo!(...);@, and @foo![...];@) + | BracesMac -- ^ braces (example: @foo! { ... }@) + deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | Represents a method's signature in a trait declaration, or in an implementation. +data MethodSig a = MethodSig Unsafety Constness Abi (FnDecl a) deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +-- | The movability of a generator / closure literal (@syntax::ast::Movability@). +data Movability = Immovable | Movable deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | Encodes whether something can be updated or changed (@syntax::ast::Mutability@). +data Mutability = Mutable | Immutable deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | For interpolation during macro expansion (@syntax::ast::NonTerminal@). +data Nonterminal a + = NtItem (Item a) + | NtBlock (Block a) + | NtStmt (Stmt a) + | NtPat (Pat a) + | NtExpr (Expr a) + | NtTy (Ty a) + | NtIdent Ident + | NtPath (Path a) + | NtTT TokenTree + | NtArm (Arm a) + | NtImplItem (ImplItem a) + | NtTraitItem (TraitItem a) + | NtGenerics (Generics a) + | NtWhereClause (WhereClause a) + | NtArg (Arg a) + | NtLit (Lit a) + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +-- | Patterns (@syntax::ast::Pat@). +data Pat a + -- | wildcard pattern: @_@ + = WildP a + -- | identifier pattern - either a new bound variable or a unit (tuple) struct pattern, or a + -- const pattern. Disambiguation cannot be done with parser alone, so it happens during name + -- resolution. (example: @mut x@) + | IdentP BindingMode Ident (Maybe (Pat a)) a + -- | struct pattern. The 'Bool' signals the presence of a @..@. (example: @Variant { x, y, .. }@) + | StructP (Path a) [FieldPat a] Bool a + -- | tuple struct pattern. If the @..@ pattern is present, the 'Maybe Int' denotes its position. + -- (example: @Variant(x, y, .., z)@) + | TupleStructP (Path a) [Pat a] (Maybe Int) a + -- | path pattern (example @A::B::C@) + | PathP (Maybe (QSelf a)) (Path a) a + -- | tuple pattern. If the @..@ pattern is present, the 'Maybe Int' denotes its position. + -- (example: @(a, b)@) + | TupleP [Pat a] (Maybe Int) a + -- | box pattern (example: @box _@) + | BoxP (Pat a) a + -- | reference pattern (example: @&mut (a, b)@) + | RefP (Pat a) Mutability a + -- | literal (example: @1@) + | LitP (Expr a) a + -- | range pattern (example: @1...2@) + | RangeP (Expr a) (Expr a) a + -- | slice pattern where, as per [this RFC](https://github.com/P1start/rfcs/blob/array-pattern-changes/text/0000-array-pattern-changes.md), + -- the pattern is split into the patterns before/after the @..@ and the pattern at the @..@. (example: @[a, b, ..i, y, z]@) + | SliceP [Pat a] (Maybe (Pat a)) [Pat a] a + -- | generated from a call to a macro (example: @LinkedList!(1,2,3)@) + | MacP (Mac a) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Pat a) where + spanOf (WildP s) = spanOf s + spanOf (IdentP _ _ _ s) = spanOf s + spanOf (StructP _ _ _ s) = spanOf s + spanOf (TupleStructP _ _ _ s) = spanOf s + spanOf (PathP _ _ s) = spanOf s + spanOf (TupleP _ _ s) = spanOf s + spanOf (BoxP _ s) = spanOf s + spanOf (RefP _ _ s) = spanOf s + spanOf (LitP _ s) = spanOf s + spanOf (RangeP _ _ s) = spanOf s + spanOf (SliceP _ _ _ s) = spanOf s + spanOf (MacP _ s) = spanOf s + +-- | Everything in Rust is namespaced using nested modules. A 'Path' represents a path into nested +-- modules, possibly instantiating type parameters along the way (@syntax::ast::Path@). Much like +-- file paths, these paths can be relative or absolute (global) with respect to the crate root. +-- +-- Paths are used to identify expressions (see 'PathExpr'), types (see 'PathTy'), and modules +-- (indirectly through 'ViewPath' and such). +-- +-- The 'Bool' argument identifies whether the path is relative or absolute. +-- +-- Example: @std::cmp::PartialEq@ +data Path a = Path Bool [PathSegment a] a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Path a) where spanOf (Path _ _ s) = spanOf s + +-- | Parameters on a path segment (@syntax::ast::PathParameters@). +data PathParameters a + -- | Parameters in a chevron comma-delimited list (@syntax::ast::AngleBracketedParameterData@). + -- Note that lifetimes must come before types, which must come before bindings. Bindings are + -- equality constraints on associated types (example: @Foo\@) + -- + -- Example: @\<\'a,A,B,C=i32\>@ in a path segment like @foo::\<'a,A,B,C=i32\>@ + = AngleBracketed [Lifetime a] [Ty a] [(Ident, Ty a)] a + -- | Parameters in a parenthesized comma-delimited list, with an optional output type + -- (@syntax::ast::ParenthesizedParameterData@). + -- + -- Example: @(A,B) -\> C@ in a path segment @Foo(A,B) -\> C@ + | Parenthesized [Ty a] (Maybe (Ty a)) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (PathParameters a) where + spanOf (AngleBracketed _ _ _ s) = spanOf s + spanOf (Parenthesized _ _ s) = spanOf s + +-- | Segment of a path (@syntax::ast::PathSegment@). +data PathSegment a + = PathSegment Ident (Maybe (PathParameters a)) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (PathSegment a) where spanOf (PathSegment _ _ s) = spanOf s + +-- | Trait ref parametrized over lifetimes introduced by a @for@ (@syntax::ast::PolyTraitRef@). +-- +-- Example: @for\<\'a,'b\> Foo\<&\'a Bar\>@ +data PolyTraitRef a = PolyTraitRef [LifetimeDef a] (TraitRef a) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (PolyTraitRef a) where spanOf (PolyTraitRef _ _ s) = spanOf s + +-- | The explicit @Self@ type in a "qualified path". The actual path, including the trait and the +-- associated item, is stored separately. The first argument is the type given to @Self@ and the +-- second is the index of the associated qualified with this @Self@ type +data QSelf a = QSelf (Ty a) Int + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +-- | Limit types of a 'Range' +data RangeLimits + = HalfOpen -- ^ Inclusive at the beginning, exclusive at the end + | Closed -- ^ Inclusive at the beginning and end + deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | A statement (@syntax::ast::Stmt@). Rust has relatively few types of statements by turning both +-- expressions (sometimes with a required semicolon at the end) and items into statements. +data Stmt a + -- | A local @let@ binding (@syntax::ast::Local@) (example: @let x: i32 = 1;@) + = Local (Pat a) (Maybe (Ty a)) (Maybe (Expr a)) [Attribute a] a + -- | Item definition (example: @fn foo(x: i32) { return x + 1 }@) + | ItemStmt (Item a) a + -- | Expression without a trailing semicolon (example: @x + 1@) + | NoSemi (Expr a) a + -- | Expression with a trailing semicolon (example: @x + 1;@) + | Semi (Expr a) a + -- | A macro call (example: @println!("hello world")@) + | MacStmt (Mac a) MacStmtStyle [Attribute a] a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Stmt a) where + spanOf (Local _ _ _ _ s) = spanOf s + spanOf (ItemStmt _ s) = spanOf s + spanOf (NoSemi _ s) = spanOf s + spanOf (Semi _ s) = spanOf s + spanOf (MacStmt _ _ _ s) = spanOf s + +-- | Style of a string literal (@syntax::ast::StrStyle@). +data StrStyle + = Cooked -- ^ regular strings (example: @\"foo\"@) + | Raw Int -- ^ raw strings, with the number of @#@ delimiters (example: @r##\"foo\"##@) + deriving (Eq, Ord, Show, Typeable, Data, Generic, NFData) + +-- | Field of a struct (@syntax::ast::StructField@) used in declarations +-- +-- Example: @bar: usize@ as in @struct Foo { bar: usize }@ +data StructField a = StructField (Maybe Ident) (Visibility a) (Ty a) [Attribute a] a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (StructField a) where spanOf (StructField _ _ _ _ s) = spanOf s + +-- | An abstract sequence of tokens, organized into a sequence (e.g. stream) of 'TokenTree', each of +-- which is a single 'Token' or a 'Delimited' subsequence of tokens. +data TokenStream + = Tree TokenTree -- ^ a single token or a single set of delimited tokens + | Stream [TokenStream] -- ^ stream of streams of tokens + deriving (Eq, Ord, Show, Typeable, Data, Generic, NFData) + +-- | A 'TokenStream' is at its core just a stream of 'TokenTree'. This function lets you get at that +-- directly. For example, you can use 'Data.List.unfoldr unconsTokenStream' to convert between a +-- 'TokenStream' and '[TokenTree]'. +unconsTokenStream :: TokenStream -> Maybe (TokenTree, TokenStream) +unconsTokenStream (Tree t) = Just (t, Stream []) +unconsTokenStream (Stream []) = Nothing +unconsTokenStream (Stream (ts:tss)) = case unconsTokenStream ts of + Nothing -> unconsTokenStream (Stream tss) + Just (t,ts') -> Just (t, Stream (ts':tss)) + +-- | 'Span' is not stored on 'TokenStream' - it is computed +instance Located TokenStream where + spanOf (Tree t) = spanOf t + spanOf (Stream tt) = spanOf tt + +-- | When the parser encounters a macro call, it parses what follows as a 'Delimited' token tree. +-- Basically, token trees let you store raw tokens or 'Sequence' forms inside of balanced +-- parens, braces, or brackets. This is a very loose structure, such that all sorts of different +-- AST-fragments can be passed to syntax extensions using a uniform type. +data TokenTree + -- | A single token + = Token Span Token + -- | A delimited sequence of tokens (@syntax::tokenstream::Delimited@) + -- Example: @{ [-\>+\<] }@ in @brainfuck!{ [-\>+\<] };@ + | Delimited + { span :: Span + , delim :: Delim -- ^ type of delimiter + , tts :: TokenStream -- ^ delimited sequence of tokens + } + deriving (Eq, Ord, Show, Typeable, Data, Generic, NFData) + +instance Located TokenTree where + spanOf (Token s _) = s + spanOf (Delimited s _ _) = s + +-- | Modifier on a bound, currently this is only used for @?Sized@, where the modifier is @Maybe@. +-- Negative bounds should also be handled here. +data TraitBoundModifier = None | Maybe deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | Item declaration within a trait declaration (@syntax::ast::TraitItem@ with +-- @syntax::ast::TraitItemKind@ inlined), possibly including a default implementation. A trait item +-- is either required (meaning it doesn't have an implementation, just a signature) or provided +-- (meaning it has a default implementation). +-- +-- Examples: +-- +-- @ +-- trait MyTrait { +-- // Associated constant +-- const ID: i32 = 1; +-- +-- // Method +-- fn area(&self) -> f64; +-- +-- // Associated type +-- type N: fmt::Display; +-- +-- // Call to a macro +-- foo!{} +-- } +-- @ +data TraitItem a + -- | Associated constants + = ConstT [Attribute a] Ident (Ty a) (Maybe (Expr a)) a + -- | Method with optional body + | MethodT [Attribute a] Ident (Generics a) (MethodSig a) (Maybe (Block a)) a + -- | Possibly abstract associated types + | TypeT [Attribute a] Ident [TyParamBound a] (Maybe (Ty a)) a + -- | Call to a macro + | MacroT [Attribute a] (Mac a) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (TraitItem a) where + spanOf (ConstT _ _ _ _ s) = spanOf s + spanOf (MethodT _ _ _ _ _ s) = spanOf s + spanOf (TypeT _ _ _ _ s) = spanOf s + spanOf (MacroT _ _ s) = spanOf s + +-- | A 'TraitRef' is a path which identifies a trait (@syntax::ast::TraitRef@). +newtype TraitRef a = TraitRef (Path a) deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (TraitRef a) where spanOf (TraitRef p) = spanOf p + +-- | Types (@syntax::ast::Ty@). +data Ty a + -- | variable length slice (example: @[T]@) + = Slice (Ty a) a + -- | fixed length array (example: @[T; n]@) + | Array (Ty a) (Expr a) a + -- | raw pointer (example: @*const T@ or @*mut T@) + | Ptr Mutability (Ty a) a + -- | reference (example: @&\'a T@ or @&\'a mut T@) + | Rptr (Maybe (Lifetime a)) Mutability (Ty a) a + -- | bare function (example: @fn(usize) -> bool@) + | BareFn Unsafety Abi [LifetimeDef a] (FnDecl a) a + -- | never type: @!@ + | Never a + -- | tuple (example: @(i32, i32)@) + | TupTy [Ty a] a + -- | path type (examples: @std::math::pi@, @\ as SomeTrait\>::SomeType@). + | PathTy (Maybe (QSelf a)) (Path a) a + -- | trait object type (example: @Bound1 + Bound2 + Bound3@) + | TraitObject (NonEmpty (TyParamBound a)) a + -- | impl trait type (see the + -- [RFC](https://github.com/rust-lang/rfcs/blob/master/text/1522-conservative-impl-trait.md)) + -- (example: @impl Bound1 + Bound2 + Bound3@). + | ImplTrait (NonEmpty (TyParamBound a)) a + -- | no-op; kept solely so that we can pretty print faithfully + | ParenTy (Ty a) a + -- | typeof, currently unsupported in @rustc@ (example: @typeof(1)@) + | Typeof (Expr a) a + -- | inferred type: @_@ + | Infer a + -- | generated from a call to a macro (example: @HList![i32,(),u8]@) + | MacTy (Mac a) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Ty a) where + spanOf (Slice _ s) = spanOf s + spanOf (Array _ _ s) = spanOf s + spanOf (Ptr _ _ s) = spanOf s + spanOf (Rptr _ _ _ s) = spanOf s + spanOf (BareFn _ _ _ _ s) = spanOf s + spanOf (Never s) = spanOf s + spanOf (TupTy _ s) = spanOf s + spanOf (PathTy _ _ s) = spanOf s + spanOf (TraitObject _ s) = spanOf s + spanOf (ImplTrait _ s) = spanOf s + spanOf (ParenTy _ s) = spanOf s + spanOf (Typeof _ s) = spanOf s + spanOf (Infer s) = spanOf s + spanOf (MacTy _ s) = spanOf s + +-- | Type parameter definition used in 'Generics' (@syntax::ast::TyParam@). Note that each +-- parameter can have any number of (lifetime or trait) bounds, as well as possibly a default type. +data TyParam a = TyParam [Attribute a] Ident [TyParamBound a] (Maybe (Ty a)) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (TyParam a) where spanOf (TyParam _ _ _ _ s) = spanOf s + +-- | Bounds that can be placed on types (@syntax::ast::TyParamBound@). These can be either traits or +-- lifetimes. +data TyParamBound a + = TraitTyParamBound (PolyTraitRef a) TraitBoundModifier a -- ^ trait bound + | RegionTyParamBound (Lifetime a) a -- ^ lifetime bound + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (TyParamBound a) where + spanOf (TraitTyParamBound _ _ s) = spanOf s + spanOf (RegionTyParamBound _ s) = spanOf s + +-- | Partition a list of 'TyParamBound' into a tuple of the 'TraitTyParamBound' and +-- 'RegionTyParamBound' variants. +partitionTyParamBounds :: [TyParamBound a] -> ([TyParamBound a], [TyParamBound a]) +partitionTyParamBounds = partition isTraitBound + where + isTraitBound TraitTyParamBound{} = True + isTraitBound RegionTyParamBound{} = False + +-- | Unary operators, used in the 'Unary' constructor of 'Expr' (@syntax::ast::UnOp@). +-- +-- Example: @!@ as in @!true@ +data UnOp + = Deref -- ^ @*@ operator (dereferencing) + | Not -- ^ @!@ operator (logical inversion) + | Neg -- ^ @-@ operator (negation) + deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | Qualifies whether something is using unsafe Rust or not (@syntax::ast::Unsafety@). Note that we +-- also use this to describe whether a 'Block' is unsafe or not, while Rust has a seperate structure +-- (@syntax::ast::BlockCheckMode@) for that. This is because they also need to keep track of whether +-- an unsafe block is compiler generated. +data Unsafety = Unsafe | Normal deriving (Eq, Ord, Enum, Bounded, Show, Typeable, Data, Generic, NFData) + +-- | A variant in Rust is a constructor (either in a 'StructItem', 'Union', or 'Enum') which groups +-- together fields (@syntax::ast::Variant@). In the case of a unit variant, there can also be an +-- explicit discriminant expression. +data Variant a = Variant Ident [Attribute a] (VariantData a) (Maybe (Expr a)) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (Variant a) where spanOf (Variant _ _ _ _ s) = spanOf s + +-- | Main payload in a 'Variant' (@syntax::ast::VariantData@). +-- +-- Examples: +-- +-- @ +-- enum Foo { +-- // Struct variant +-- Bar { x: f64 }, +-- +-- // Tuple variant +-- Baz(i32, i32), +-- +-- // Unit variant +-- Qux, +-- } +-- @ +data VariantData a + = StructD [StructField a] a -- ^ Struct variant + | TupleD [StructField a] a -- ^ Tuple variant + | UnitD a -- ^ Unit variant + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (VariantData a) where + spanOf (StructD _ s) = spanOf s + spanOf (TupleD _ s) = spanOf s + spanOf (UnitD s) = spanOf s + +-- | Paths used in 'Use' items (@ast::syntax::UseTree@). +-- +-- Examples: +-- +-- @ +-- // Simple use paths +-- use foo::bar::baz as quux; +-- use foo::bar::baz; +-- +-- // Glob use paths +-- use foo::bar::*; +-- +-- // Nested use paths +-- use foo::bar::{a, b, c::quux as d} +-- @ +data UseTree a + -- | Simple path, optionally ending in an @as@ + = UseTreeSimple (Path a) (Maybe Ident) a + -- | Path ending in a glob pattern + | UseTreeGlob (Path a) a + -- | Path ending in a list of more paths + | UseTreeNested (Path a) [UseTree a] a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (UseTree a) where + spanOf (UseTreeSimple _ _ s) = spanOf s + spanOf (UseTreeGlob _ s) = spanOf s + spanOf (UseTreeNested _ _ s) = spanOf s + +-- | The visibility modifier dictates from where one can access something +-- (@ast::syntax::Visibility@). [RFC about adding restricted +-- visibility](https://github.com/rust-lang/rfcs/blob/master/text/1422-pub-restricted.md) +data Visibility a + = PublicV -- ^ @pub@ is accessible from everywhere + | CrateV -- ^ @pub(crate)@ is accessible from within the crate + | RestrictedV (Path a) -- ^ for some path @p@, @pub(p)@ is visible at that path + | InheritedV -- ^ if no visbility is specified, this is the default + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +-- | A @where@ clause in a definition, where one can apply a series of constraints to the types +-- introduced and used by a 'Generic' clause (@syntax::ast::WhereClause@). In many cases, @where@ +-- is the /only/ way to express certain bounds (since those bounds may not be immediately on a type +-- defined in the generic, but on a type derived from types defined in the generic). +-- +-- Note that while 'WhereClause' is a field of 'Generic', not all uses of generics are coupled with +-- a where clause. In those cases, we leave the list of predicates empty. +-- +-- Example: @where Option\: Debug@ as in +-- +-- @ +-- impl\ PrintInOption for T where Option\: Debug { } +-- @ +data WhereClause a = WhereClause [WherePredicate a] a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (WhereClause a) where spanOf (WhereClause _ s) = spanOf s + +instance Sem.Semigroup a => Sem.Semigroup (WhereClause a) where + WhereClause wp1 x1 <> WhereClause wp2 x2 = WhereClause (wp1 ++ wp2) (x1 <> x2) + +instance (Sem.Semigroup a, Monoid a) => Monoid (WhereClause a) where + mappend = (<>) + mempty = WhereClause [] mempty + +-- | An individual predicate in a 'WhereClause' (@syntax::ast::WherePredicate@). +data WherePredicate a + -- | type bound (@syntax::ast::WhereBoundPredicate@) (example: @for\<\'c\> Foo: Send+Clone+\'c@) + = BoundPredicate [LifetimeDef a] (Ty a) [TyParamBound a] a + -- | lifetime predicate (@syntax::ast::WhereRegionPredicate@) (example: @\'a: \'b+\'c@) + | RegionPredicate (Lifetime a) [Lifetime a] a + -- | equality predicate (@syntax::ast::WhereEqPredicate@) (example: @T=int@). Note that this is + -- not currently supported. + | EqPredicate (Ty a) (Ty a) a + deriving (Eq, Ord, Functor, Show, Typeable, Data, Generic, Generic1, NFData) + +instance Located a => Located (WherePredicate a) where + spanOf (BoundPredicate _ _ _ s) = spanOf s + spanOf (RegionPredicate _ _ s) = spanOf s + spanOf (EqPredicate _ _ s) = spanOf s + diff --git a/src/Language/Rust/Syntax/Token.hs b/src/Language/Rust/Syntax/Token.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Syntax/Token.hs @@ -0,0 +1,376 @@ +{-| +Module : Language.Rust.Syntax.Token +Description : Token definitions +Copyright : (c) Alec Theriault, 2017-2018 +License : BSD-style +Maintainer : alec.theriault@gmail.com +Stability : experimental +Portability : GHC + +Contains roughly the same stuff as @syntax::parse::token@ - data definitions for tokens. +-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Language.Rust.Syntax.Token ( + Token(..), + spaceNeeded, + Space(..), + Delim(..), + LitTok(..), + AttrStyle(..), +) where + +import GHC.Generics ( Generic ) + +import Control.DeepSeq ( NFData ) +import Data.Data ( Data ) +import Data.Maybe ( fromMaybe ) +import Data.Typeable ( Typeable ) + +import Language.Rust.Data.Ident ( Ident(name), Name ) +import Language.Rust.Data.Position ( Span ) +import Language.Rust.Syntax.AST ( Nonterminal, AttrStyle(..) ) + +-- | A general token (based on @syntax::parse::token::Token@). +-- +-- Unlike its @libsyntax@ counterpart, 'Token' has folded in @syntax::parse::token::BinOpToken@ +-- and @syntax::parse::token::BinOpEqToken@ as regular tokens. +data Token + -- Single character expression-operator symbols. + = Equal -- ^ @=@ token + | Less -- ^ @<@ token + | Greater -- ^ @>@ token + | Ampersand -- ^ @&@ token + | Pipe -- ^ @|@ token + | Exclamation -- ^ @!@ token + | Tilde -- ^ @~@ token + | Plus -- ^ @+@ token + | Minus -- ^ @-@ token + | Star -- ^ @*@ token + | Slash -- ^ @/@ token + | Percent -- ^ @%@ token + | Caret -- ^ @^@ token + + -- Multi character expression-operator symbols + | GreaterEqual -- ^ @>=@ token + | GreaterGreaterEqual -- ^ @>>=@ token + | AmpersandAmpersand -- ^ @&&@ token + | PipePipe -- ^ @||@ token + | LessLess -- ^ @<<@ token + | GreaterGreater -- ^ @>>@ token + | EqualEqual -- ^ @==@ token + | NotEqual -- ^ @!=@ token + | LessEqual -- ^ @<=@ token + | LessLessEqual -- ^ @<<=@ token + | MinusEqual -- ^ @-=@ token + | AmpersandEqual -- ^ @&=@ token + | PipeEqual -- ^ @|=@ token + | PlusEqual -- ^ @+=@ token + | StarEqual -- ^ @*=@ token + | SlashEqual -- ^ @/=@ token + | CaretEqual -- ^ @^=@ token + | PercentEqual -- ^ @%=@ token + + -- Structural symbols + | At -- ^ @\@@ token + | Dot -- ^ @.@ token + | DotDot -- ^ @..@ token + | DotDotEqual -- ^ @..=@ token + | DotDotDot -- ^ @...@ token + | Comma -- ^ @,@ token + | Semicolon -- ^ @;@ token + | Colon -- ^ @:@ token + | ModSep -- ^ @::@ token + | RArrow -- ^ @->@ token + | LArrow -- ^ @<-@ token + | FatArrow -- ^ @=>@ token + | Pound -- ^ @#@ token + | Dollar -- ^ @$@ token + | Question -- ^ @?@ token + + -- Embedded code + | EmbeddedCode String -- ^ @${@ ... @}@ token containing embedded code + | EmbeddedIdent String -- ^ @${@ ... @}@ token containing embedded code + + -- Delimiters + | OpenDelim !Delim -- ^ One of @(@, @[@, @{@ + | CloseDelim !Delim -- ^ One of @)@, @]@, @}@ + + -- Literals + | LiteralTok LitTok (Maybe Name) -- ^ a literal token with an optional suffix (something like @i32@) + + -- Name components + | IdentTok Ident -- ^ an arbitrary identifier (something like @x@ or @foo@ or @and_then@) + | LifetimeTok Ident -- ^ a lifetime (something like @\'a@ or @\'static@) + | Space Space Name -- ^ whitespace + | Doc String !AttrStyle !Bool + -- ^ doc comment with its contents, whether it is outer/inner, and whether it is inline or not + | Shebang -- ^ @#!@ shebang token + | Eof -- ^ end of file token + + -- NOT PRODUCED IN TOKENIZATION!! + | Interpolated (Nonterminal Span) -- ^ can be expanded into several tokens in macro-expansion + deriving (Eq, Ord, Data, Typeable, Generic, NFData) + +-- | Rust is whitespace independent. Short of providing space between tokens, whitespace is all the +-- same to the parser. +data Space + = Whitespace -- ^ usual white space: @[\\ \\t\\n\\f\\v\\r]+@ + | Comment -- ^ comment (either inline or not) + deriving (Eq, Ord, Show, Enum, Bounded, Data, Typeable, Generic, NFData) + +-- TODO: BANISH NoDelim! (or rather: distinguish DelimToken from Delim, as rustc does) +-- | A delimiter token (@syntax::parse::token::DelimToken@). +data Delim + = Paren -- ^ round parenthesis: @(@ or @)@ + | Bracket -- ^ square bracket: @[@ or @]@ + | Brace -- ^ curly brace: @{@ or @}@ + | NoDelim -- ^ empty delimiter + deriving (Eq, Ord, Enum, Bounded, Show, Data, Typeable, Generic, NFData) + +-- | A literal token (@syntax::parse::token::Lit@) +data LitTok + = ByteTok Name -- ^ byte + | CharTok Name -- ^ character + | IntegerTok Name -- ^ integral literal (could have type @i32@, @int@, @u128@, etc.) + | FloatTok Name -- ^ floating point literal (could have type @f32@, @f64@, etc.) + | StrTok Name -- ^ string literal + | StrRawTok Name !Int -- ^ raw string literal and the number of @#@ marks around it + | ByteStrTok Name -- ^ byte string literal + | ByteStrRawTok Name !Int -- ^ raw byte string literal and the number of @#@ marks around it + deriving (Eq, Ord, Show, Data, Typeable, Generic, NFData) + + +-- | Check whether a space is needed between two tokens to avoid confusion. +spaceNeeded :: Token -> Token -> Bool +-- conflicts with 'GreaterEqual' +spaceNeeded Greater Equal = True +spaceNeeded Greater EqualEqual = True +spaceNeeded Greater FatArrow = True + +-- conflicts with 'GreaterGreaterEqual' +spaceNeeded Greater GreaterEqual = True +spaceNeeded GreaterGreater Equal = True +spaceNeeded GreaterGreater EqualEqual = True +spaceNeeded GreaterGreater FatArrow = True + +-- conflicts with 'AmpersandAmpersand' +spaceNeeded Ampersand Ampersand = True +spaceNeeded Ampersand AmpersandAmpersand = True +spaceNeeded Ampersand AmpersandEqual = True + +-- conflicts with 'PipePipe' +spaceNeeded Pipe Pipe = True +spaceNeeded Pipe PipePipe = True +spaceNeeded Pipe PipeEqual = True + +-- conflicts with 'LessLess' +spaceNeeded Less Less = True +spaceNeeded Less LessLess = True +spaceNeeded Less LessLessEqual = True +spaceNeeded Less LArrow = True + +-- conflicts with 'GreaterGreater' +spaceNeeded Greater Greater = True +spaceNeeded Greater GreaterGreater = True +spaceNeeded Greater GreaterGreaterEqual = True + +-- conflicts with 'EqualEqual' +spaceNeeded Equal Equal = True +spaceNeeded Equal EqualEqual = True +spaceNeeded Equal FatArrow = True + +-- conflicts with 'NotEqual' +spaceNeeded Exclamation Equal = True +spaceNeeded Exclamation EqualEqual = True +spaceNeeded Exclamation FatArrow = True + +-- conflicts with 'LessEqual' +spaceNeeded Less Equal = True +spaceNeeded Less EqualEqual = True +spaceNeeded Less FatArrow = True + +-- conflicts with 'LessLessEqual' +spaceNeeded Less LessEqual = True +spaceNeeded LessLess Equal = True +spaceNeeded LessLess EqualEqual = True +spaceNeeded LessLess FatArrow = True + +-- conflicts with 'MinusEqual' +spaceNeeded Minus Equal = True +spaceNeeded Minus EqualEqual = True +spaceNeeded Minus FatArrow = True + +-- conflicts with 'AmpersandEqual' +spaceNeeded Ampersand Equal = True +spaceNeeded Ampersand EqualEqual = True +spaceNeeded Ampersand FatArrow = True + +-- conflicts with 'PipeEqual' +spaceNeeded Pipe Equal = True +spaceNeeded Pipe EqualEqual = True +spaceNeeded Pipe FatArrow = True + +-- conflicts with 'PlusEqual' +spaceNeeded Plus Equal = True +spaceNeeded Plus EqualEqual = True +spaceNeeded Plus FatArrow = True + +-- conflicts with 'StarEqual' +spaceNeeded Star Equal = True +spaceNeeded Star EqualEqual = True +spaceNeeded Star FatArrow = True + +-- conflicts with 'SlashEqual' +spaceNeeded Slash Equal = True +spaceNeeded Slash EqualEqual = True +spaceNeeded Slash FatArrow = True + +-- conflicts with 'CaretEqual' +spaceNeeded Caret Equal = True +spaceNeeded Caret EqualEqual = True +spaceNeeded Caret FatArrow = True + +-- conflicts with 'PercentEqual' +spaceNeeded Percent Equal = True +spaceNeeded Percent EqualEqual = True +spaceNeeded Percent FatArrow = True + +-- conflicts with 'DotDot' +spaceNeeded Dot Dot = True +spaceNeeded Dot DotDot = True +spaceNeeded Dot DotDotDot = True + +-- conflicts with 'DotDotDot' +spaceNeeded DotDot Dot = True +spaceNeeded DotDot DotDot = True +spaceNeeded DotDot DotDotDot = True + +-- conflicts with 'DotDotEqual' +spaceNeeded DotDot Equal = True +spaceNeeded DotDot EqualEqual = True +spaceNeeded DotDot FatArrow = True + +-- conflicts with 'ModSep' +spaceNeeded Colon Colon = True +spaceNeeded Colon ModSep = True + +-- conflicts with 'RArrow' +spaceNeeded Minus Greater = True +spaceNeeded Minus GreaterGreater = True +spaceNeeded Minus GreaterEqual = True +spaceNeeded Minus GreaterGreaterEqual = True + +-- conflicts with 'LArrow' +spaceNeeded Less Minus = True +spaceNeeded Less MinusEqual = True +spaceNeeded Less RArrow = True + +-- conflicts with 'FatArrow' +spaceNeeded Equal Greater = True +spaceNeeded Equal GreaterGreater = True +spaceNeeded Equal GreaterEqual = True +spaceNeeded Equal GreaterGreaterEqual = True + +-- conflicts with 'LiteralTok' +spaceNeeded LiteralTok{} IdentTok{} = True + +-- conflicts with 'IdentTok' +spaceNeeded IdentTok{} IdentTok{} = True + +-- conflicts with 'Shebang' +spaceNeeded Pound Exclamation = True +spaceNeeded Pound NotEqual = True + +-- there are no other conflicts +spaceNeeded _ _ = False + + +-- | This instance is only for error messages and debugging purposes. +instance Show Token where + -- Single character expression-operator symbols. + show Equal = "=" + show Less = "<" + show Greater = ">" + show Ampersand = "&" + show Pipe = "|" + show Exclamation = "!" + show Tilde = "~" + show Plus = "+" + show Minus = "-" + show Star = "*" + show Slash = "/" + show Percent = "%" + -- Multi character eexpression-operator symbols + show GreaterEqual = ">=" + show GreaterGreaterEqual = ">>=" + show AmpersandAmpersand = "&&" + show PipePipe = "||" + show LessLess = "<<" + show GreaterGreater = ">>" + show EqualEqual = "==" + show NotEqual = "!=" + show LessEqual = "<=" + show LessLessEqual = "<<=" + show MinusEqual = "-=" + show AmpersandEqual = "&=" + show PipeEqual = "|=" + show PlusEqual = "+=" + show StarEqual = "*=" + show SlashEqual = "/=" + show CaretEqual = "^=" + show PercentEqual = "%=" + show Caret = "^" + -- Structural symbols + show At = "@" + show Dot = "." + show DotDot = ".." + show DotDotDot = "..." + show DotDotEqual = "..=" + show Comma = "," + show Semicolon = ";" + show Colon = ":" + show ModSep = "::" + show RArrow = "->" + show LArrow = "<-" + show FatArrow = "=>" + show Pound = "#" + show Dollar = "$" + show Question = "?" + -- Embedded code + show (EmbeddedCode s) = "${e|" ++ s ++ "|}" + show (EmbeddedIdent s) = "${i|" ++ s ++ "|}" + -- Delimiters, eg. @{@, @${@, @]@, @(@ + show (OpenDelim Paren) = "(" + show (OpenDelim Bracket) = "[" + show (OpenDelim Brace) = "{" + show (OpenDelim NoDelim) = "" + show (CloseDelim Paren) = ")" + show (CloseDelim Bracket) = "]" + show (CloseDelim Brace) = "}" + show (CloseDelim NoDelim) = "" + -- Literals + show (LiteralTok (ByteTok n) s) = "b'" ++ n ++ "'" ++ fromMaybe "" s + show (LiteralTok (CharTok n) s) = "'" ++ n ++ "'" ++ fromMaybe "" s + show (LiteralTok (IntegerTok n) s) = n ++ fromMaybe "" s + show (LiteralTok (FloatTok n) s) = n ++ fromMaybe "" s + show (LiteralTok (StrTok n) s) = "\"" ++ n ++ "\"" ++ fromMaybe "" s + show (LiteralTok (StrRawTok n i) s) = "r" ++ replicate i '#' ++ "\"" ++ n ++ "\"" ++ replicate i '#' ++ fromMaybe "" s + show (LiteralTok (ByteStrTok n) s) = "b\"" ++ n ++ "\"" ++ fromMaybe "" s + show (LiteralTok (ByteStrRawTok n i) s) = "br" ++ replicate i '#' ++ "\"" ++ n ++ "\"" ++ replicate i '#' ++ fromMaybe "" s + -- Name components + show (IdentTok i) = show $ name i + show (LifetimeTok l) = "'" ++ show l + show (Space Whitespace _) = "" + show (Space Comment n) = "/*" ++ show n ++ " */" + show (Doc d Inner True) = "/*!" ++ d ++ "*/" + show (Doc d Outer True) = "/**" ++ d ++ "*/" + show (Doc d Inner False) = "//!" ++ d + show (Doc d Outer False) = "///" ++ d + show Shebang = "#!" + show Eof = "" + -- Macro related + show Interpolated{} = "" + diff --git a/src/Language/Rust/Syntax/Token.hs-boot b/src/Language/Rust/Syntax/Token.hs-boot new file mode 100644 --- /dev/null +++ b/src/Language/Rust/Syntax/Token.hs-boot @@ -0,0 +1,38 @@ +-- .hs-boot files play badly with associated type families like 'Rep' +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-missing-methods #-} +#endif + +module Language.Rust.Syntax.Token where + +import GHC.Generics (Generic) +import Data.Data (Data) +-- import Data.Typeable (Typeable) +import Control.DeepSeq (NFData) + +data LitTok + +data Token +instance Eq Token +instance Ord Token +instance Show Token +instance Data Token +-- instance Typeable Token +instance Generic Token +instance NFData Token + +data Delim +instance Eq Delim +instance Ord Delim +instance Data Delim +-- instance Typeable Delim +instance Generic Delim +instance Show Delim +instance NFData Delim + +data Space +instance NFData Space +instance Eq Space +instance Ord Space + diff --git a/test/parser/Main.hs b/test/parser/Main.hs new file mode 100644 --- /dev/null +++ b/test/parser/Main.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable, BangPatterns, UnicodeSyntax #-} +module Main where +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit +--import Test.Framework.Providers.QuickCheck2 +--import Test.QuickCheck (Property, quickCheck, (==>)) + +import Language.Floorplan.Syntax +import Language.Floorplan.Token +import qualified Language.Floorplan.Parser as P +import System.IO (openFile, IOMode(..), hGetContents) +import qualified Debug.Trace as D +import Data.List (sort) + +import Language.Rust.Pretty (pretty) +import Language.Floorplan.Core.Compiler +import qualified Language.Floorplan.Rust as R + +{- +testTokenizes fn = testCase fn $ do + fd <- openFile fn ReadMode + contents <- hGetContents fd + let !xs = show $ P.tokenize contents + return () + +testParses fn = testCase fn $ do + fd <- openFile fn ReadMode + contents <- hGetContents fd + let !xs = P.parseFloorplanDemarcsGLR fn 0 0 contents + return () + +testParsesExp fn expected = testCase fn $ do + fd <- openFile fn ReadMode + contents <- hGetContents fd + let xs = P.parseFloorplanDemarcsGLR fn 0 0 contents + assertEqual "Not equal" xs expected +-} + +-- Happy parser generator versions: + +readme fn = do + fd <- openFile fn ReadMode + hGetContents fd + +mkTest fn cont = testCase fn $ readme fn >>= cont + +testTokenizes fn = mkTest fn $ \contents -> do + let !xs = show $ scanTokens contents + return () + +testParses fn = mkTest fn $ \contents -> do + let !xs = P.parseLayers contents + return () + +testGrafts fn = mkTest fn $ \contents -> do + let !xs = P.parseLayers contents + let !ys = map (grafting xs) xs + countGrafting ys @?= 0 + return () + +testParsesExp fn expected = mkTest fn $ \contents -> + expected @=? P.parseLayers contents + +test_b2i = + assertEqual "incorrect binary value" + (bin2int "0b1010") + 10 + +test_b2i' = + assertEqual "incorrect binary value" + (bin2int "0b000000") + 0 + +tokenizeSuite = testGroup "tokenization suite" + [ testTokenizes "examples/empty.flp" + ] + +parseSuite = testGroup "parsing suite" + [ testParses "examples/immix/layout.flp" + , testParses "examples/empty.flp" + , testParses "examples/seq.flp" + , testParses "examples/enum.flp" + , testParses "examples/union.flp" + , testParses "examples/layer.flp" + , testParses "examples/bits.flp" + , testParses "examples/arith_id.flp" + , testParses "examples/arith_power.flp" + , testParses "examples/bump.flp" + , testParses "examples/dynamic_prim.flp" + , testParses "examples/dyn_choice.flp" + , testParses "examples/dyn_seq.flp" +-- , testNotParses "examples/enum_bad0.flp" + , testParses "examples/map_bits.flp" + , testParses "examples/named_ref.flp" + , testParses "examples/nested.flp" + , testParses "examples/nested_union.flp" + , testParses "examples/app.flp" + , testParses "examples/parens.flp" + , testParsesExp "examples/arith.flp" theLayer + ] + +theLayer = + [ Layer + { name = "Arith" + , formals = [] + , magnitude = Just (SizeLit (Just (Lit 7)) Byte) + , alignment = Nothing + , magAlign = Nothing + , contains = [] + , rhs = Blob (SizeLit + (Just (Plus + (Times (Div (Lit 4) (Lit 2)) + (Lit 3)) + (Lit 1))) + Byte + ) + } + ] + +graftSuite = testGroup "grafting suite" + [ testGrafts "examples/immix/layout.flp" + , testCase "empty unique" $ [] @=? (checkUniqNames theLayer) + , mkTest "examples/uniq_fail.flp" $ \c -> (sort ["foo", "Outer"]) @=? (sort $ checkUniqNames (P.parseLayers c)) + ] + +testCompiles fn = mkTest fn $ \contents -> do + let !xs = P.parseLayers contents + let !ys = map (grafting xs) xs + countGrafting ys @?= 0 + let !zs = D.traceShowId $ map compile ys + let !rust = D.traceShowId $ R.genRust zs + let !_ = D.traceShowId $ pretty rust + return () + +compileSuite = testGroup "compiling suite" + [ testCase "enumBytes A" $ enumBytes (take 0 $ repeat "") @?= 0 -- Null enum requires no space. + , testCase "enumBytes B" $ enumBytes (take 1 $ repeat "") @?= 1 -- Singletone requires space. + , testCase "enumBytes C" $ enumBytes (take 128 $ repeat "") @?= 1 -- Most enums take 1 bytes. + , testCase "enumBytes D" $ enumBytes (take 256 $ repeat "") @?= 1 -- Including this one. + , testCase "enumBytes E" $ enumBytes (take 257 $ repeat "") @?= 2 -- But not this one. + , testCase "enumBytes F" $ enumBytes (take (256*256) $ repeat "") @?= 2 -- Not this one either. + , testCase "enumBytes G" $ enumBytes (take (256*256 + 1) $ repeat "") @?= 3 -- And definitely not this one. + , testCase "enumBytes H" $ enumBytes (take (256*256*256 + 1) $ repeat "") @?= 4 -- And so on. + , testCompiles "examples/immix/layout.flp" + , testCase "delta_bytes round small" $ delta_bytes (SizeLit (Just $ Lit $ 8*3-1) Bit) @?= 3 + , testCase "delta_bytes no rounding" $ delta_bytes (SizeLit (Just $ Lit $ 8*3 ) Bit) @?= 3 + , testCase "delta_bytes round large" $ delta_bytes (SizeLit (Just $ Lit $ 8*3+1) Bit) @?= 4 + ] + +main :: IO () +main = defaultMainWithOpts + [ testCase "Binary conversion" test_b2i + , testCase "Binary conversion" test_b2i' + , tokenizeSuite + , parseSuite + , graftSuite + , compileSuite + ] mempty +