├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .tidyrc.json ├── CONTRIBUTORS.md ├── LICENSE ├── README.md ├── bench ├── spago.yaml └── src │ ├── BenchFile.purs │ └── ParseFile.purs ├── package-lock.json ├── package.json ├── parse-package-set ├── package-set-install │ ├── spago.lock │ └── spago.yaml ├── spago.yaml └── src │ ├── Main.js │ └── Main.purs ├── spago.lock ├── spago.yaml ├── src └── PureScript │ ├── CST.purs │ └── CST │ ├── Errors.purs │ ├── Layout.purs │ ├── Lexer.purs │ ├── ModuleGraph.purs │ ├── Parser.purs │ ├── Parser │ └── Monad.purs │ ├── Print.purs │ ├── Range.purs │ ├── Range │ └── TokenList.purs │ ├── TokenStream.purs │ ├── Traversal.purs │ └── Types.purs └── test └── Main.purs /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: [main] 6 | pull_request: 7 | 8 | jobs: 9 | build: 10 | runs-on: ubuntu-latest 11 | 12 | steps: 13 | - uses: actions/checkout@v4 14 | - uses: actions/setup-node@v4 15 | with: 16 | node-version: 22 17 | cache: 'npm' 18 | 19 | - name: Cache PureScript dependencies 20 | uses: actions/cache@v4 21 | with: 22 | key: ${{ runner.os }}-spago-${{ hashFiles('spago.lock') }} 23 | path: | 24 | .spago 25 | output 26 | 27 | - name: Cache package set dependencies 28 | uses: actions/cache@v4 29 | with: 30 | key: ${{ runner.os }}-spago-${{ hashFiles('parse-package-set/package-set-install/spago.lock') }} 31 | path: | 32 | parse-package-set/package-set-install/.spago 33 | parse-package-set/package-set-install/output 34 | 35 | - name: Cache Spago downloads 36 | uses: actions/cache@v4 37 | with: 38 | key: ${{ runner.os }}-spago-nodejs-cache 39 | path: ~/.cache/spago-nodejs 40 | 41 | - name: Install npm dependencies 42 | run: npm install --include=dev 43 | 44 | - name: Install dependencies 45 | run: npm run install 46 | 47 | - name: Build project 48 | run: npm run build -- --pedantic-packages --strict 49 | 50 | - name: Run tests 51 | run: npm run test -- --offline --quiet 52 | 53 | - name: Check formatting 54 | run: npm run format:check 55 | 56 | - name: Parse package sets 57 | run: | 58 | npm run parse-package-set 2> parse-package-set-errors.log 59 | exit_code=$? 60 | if [ $exit_code -ne 0 ]; then 61 | echo "Parse package sets failed with exit code $exit_code" 62 | exit $exit_code 63 | fi 64 | 65 | - name: Upload parse package sets error log 66 | uses: actions/upload-artifact@v4 67 | if: failure() 68 | with: 69 | name: parse-package-set-errors 70 | path: parse-package-set-errors.log 71 | retention-days: 30 72 | 73 | - name: Run file benchmark 74 | run: npm run bench-file src/PureScript/CST/Parser.purs 75 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | bower_components 2 | node_modules 3 | output 4 | generated-docs 5 | 6 | .pulp-cache 7 | .psc-package 8 | .psc* 9 | .purs* 10 | .psa* 11 | .spago 12 | -------------------------------------------------------------------------------- /.tidyrc.json: -------------------------------------------------------------------------------- 1 | { 2 | "indent": 2, 3 | "operatorsFile": null, 4 | "ribbon": 1, 5 | "typeArrowPlacement": "first", 6 | "unicode": "never", 7 | "width": null 8 | } 9 | -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | ## Contributors 2 | 3 | This file lists the contributors to the `purescript-language-cst-parser` project. 4 | 5 | ### Terms 6 | 7 | Contributors listed here agree to license their contributions under the following terms: 8 | 9 | > My existing contributions and all future contributions until further notice are Copyright {Name}, and are licensed to the owners and users of the `purescript-language-cst-parser` project and the authors of the PureScript compiler project under the terms of the MIT license. 10 | 11 | By adding your name to the list below, you agree to license your contributions under these terms. 12 | 13 | | Username | Name | 14 | | :------- | :--- | 15 | | [@thomashoneyman](https://github.com/thomashoneyman) | Thomas Honeyman 16 | | [@garyb](https://github.com/garyb) | Gary Burgess 17 | | [@colinwahl](https://github.com/colinwahl) | Colin Wahl 18 | | [@kritzcreek](https://github.com/kritzcreek) | Christoph Hegemann 19 | | [@rintcius](https://github.com/rintcius) | Rintcius Blok 20 | | [@i-am-the-slime](https://github.com/i-am-the-slime) | Mark Eibes 21 | | [@monoidmusician](https://github.com/MonoidMusician) | Verity Scheel 22 | | [@turlando](https://github.com/turlando) | Tancredi Orlando 23 | | [@srghma](https://github.com/srghma) | Serhii Khoma 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2021 Nathan Faubion 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # PureScript Language CST Parser 2 | 3 | A parser for the PureScript concrete syntax tree. 4 | 5 | ## Usage 6 | 7 | The supported parsers are exported from `PureScript.CST`. The parsers support 8 | some error recovery, which is reflected in the `RecoveredParserResult` type. 9 | The CST types in `PureScript.CST.Types` are indexed by an error type, which 10 | is fixed to `RecoveredError` in the case of failures. Parses that succeed 11 | without failures have the error type fixed to `Void`. 12 | 13 | ```purescript 14 | import PureScript.CST (RecoveredParserResult(..), parseModule) 15 | 16 | example = case parseModule myModuleSource of 17 | ParseSucceeded cst -> 18 | -- `cst` is type `Module Void` to indicate no errors 19 | ParseSucceededWithErrors cst errors -> 20 | -- `cst is type `Module RecoveredError` and contains error nodes at points of failure. 21 | ParseFailed error -> 22 | -- An unrecoverable error was encountered. 23 | ``` 24 | 25 | ## Traversals 26 | 27 | `PureScript.CST.Traversal` contains traversals for analyzing and rewriting 28 | the CST. These folds take a language visitor record with functions for 29 | handling the primary types in the CST. Default records are provided that do 30 | nothing for the cases you don't care about. 31 | 32 | For example, if you wanted to quickly gather all the identifiers used in the 33 | expressions of a module along with locations, you might use `foldMapModule` 34 | and only provide a case for `onExpr`. 35 | 36 | ```purescript 37 | import Prelude 38 | import Data.Map (SemigroupMap(..)) 39 | import Data.Map as Map 40 | import Data.Set (Set) 41 | import Data.Set as Set 42 | import Data.Tuple (Tuple(..)) 43 | import PureScript.CST.Traversal (foldMapModule, defaultMonoidalVisitor) 44 | import PureScript.CST.Types as CST 45 | 46 | type QualifiedIdent = Tuple (Maybe CST.ModuleName) CST.Ident 47 | type UsageMap = SemigroupMap QualifiedIdent (Set CST.SourceRange) 48 | 49 | getExprIdents :: forall a. CST.Module a -> UsageMap 50 | getExprIdents = foldMapModule $ defaultMonoidalVisitor 51 | { onExpr = case _ of 52 | CST.ExprIdent (CST.QualifiedName ident) -> 53 | SemigroupMap 54 | $ Map.singleton (Tuple ident."module" ident.name) 55 | $ Set.singleton ident.token.range 56 | _ -> mempty 57 | } 58 | ``` 59 | 60 | ## Development 61 | 62 | The provided integration test attempts to parse a provided package set, and 63 | will report any errors it encounters as well as listing the fastest and 64 | slowest parse times along with the mean parse time for the set. 65 | 66 | ```sh 67 | npm run parse-package-set 68 | ``` 69 | 70 | You can also benchmark or parse a single file: 71 | 72 | ```sh 73 | npm run bench-file MyModule.purs 74 | npm run parse-file -- MyModule.purs --tokens 75 | ``` 76 | -------------------------------------------------------------------------------- /bench/spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | name: bench 3 | build: 4 | strict: true 5 | dependencies: 6 | - aff: ">=8.0.0 <9.0.0" 7 | - arrays: ">=7.3.0 <8.0.0" 8 | - console: ">=6.1.0 <7.0.0" 9 | - effect: ">=4.0.0 <5.0.0" 10 | - either: ">=6.1.0 <7.0.0" 11 | - foldable-traversable: ">=6.0.0 <7.0.0" 12 | - language-cst-parser: "*" 13 | - maybe: ">=6.0.0 <7.0.0" 14 | - minibench: ">=4.0.1 <5.0.0" 15 | - node-buffer: ">=9.0.0 <10.0.0" 16 | - node-fs: ">=9.2.0 <10.0.0" 17 | - node-process: ">=11.2.0 <12.0.0" 18 | - prelude: ">=6.0.2 <7.0.0" 19 | -------------------------------------------------------------------------------- /bench/src/BenchFile.purs: -------------------------------------------------------------------------------- 1 | module BenchFile where 2 | 3 | import Prelude 4 | 5 | import Data.Array as Array 6 | import Data.Maybe (Maybe(..)) 7 | import Effect (Effect) 8 | import Effect.Aff (launchAff_) 9 | import Effect.Class (liftEffect) 10 | import Effect.Class.Console as Console 11 | import Node.Buffer as Buffer 12 | import Node.Encoding (Encoding(..)) 13 | import Node.FS.Aff (readFile) 14 | import Node.Process as Process 15 | import Performance.Minibench (benchWith) 16 | import PureScript.CST (parseModule) 17 | 18 | main :: Effect Unit 19 | main = launchAff_ do 20 | args <- Array.drop 1 <$> liftEffect Process.argv 21 | case Array.head args of 22 | Just fileName -> do 23 | contents <- liftEffect <<< Buffer.toString UTF8 =<< readFile fileName 24 | Console.log $ "Benchmarking " <> fileName 25 | liftEffect $ benchWith 100 \_ -> parseModule contents 26 | Nothing -> 27 | Console.log "File path required" 28 | -------------------------------------------------------------------------------- /bench/src/ParseFile.purs: -------------------------------------------------------------------------------- 1 | module ParseFile where 2 | 3 | import Prelude 4 | 5 | import Data.Array (foldMap) 6 | import Data.Array as Array 7 | import Data.Either (Either(..)) 8 | import Data.Foldable (elem, for_) 9 | import Data.Maybe (Maybe(..)) 10 | import Effect (Effect) 11 | import Effect.Aff (launchAff_) 12 | import Effect.Class (liftEffect) 13 | import Effect.Class.Console as Console 14 | import Node.Buffer as Buffer 15 | import Node.Encoding (Encoding(..)) 16 | import Node.FS.Aff (readFile) 17 | import Node.Process as Process 18 | import PureScript.CST (RecoveredParserResult(..), parseModule) 19 | import PureScript.CST.Errors (ParseError, printParseError) 20 | import PureScript.CST.Lexer (lexModule) 21 | import PureScript.CST.Parser.Monad (PositionedError) 22 | import PureScript.CST.Print (TokenOption(..), printSourceTokenWithOption) 23 | import PureScript.CST.TokenStream (TokenStep(..), TokenStream, step) 24 | import PureScript.CST.Types (SourceToken) 25 | 26 | main :: Effect Unit 27 | main = launchAff_ do 28 | args <- Array.drop 1 <$> liftEffect Process.argv 29 | let printTokens = (elem "--tokens" || elem "-t") args 30 | case Array.head args of 31 | Just fileName -> do 32 | contents <- liftEffect <<< Buffer.toString UTF8 =<< readFile fileName 33 | 34 | if printTokens then do 35 | let 36 | tokens = 37 | map (foldMap (printSourceTokenWithOption ShowLayout)) 38 | $ tokenStreamToArray 39 | $ lexModule contents 40 | for_ tokens Console.log 41 | else 42 | mempty 43 | 44 | case parseModule contents of 45 | ParseSucceeded _ -> do 46 | Console.log "Parse succeeded." 47 | ParseSucceededWithErrors _ errs -> do 48 | Console.log "Parse succeeded with errors." 49 | for_ errs $ Console.error <<< printPositionedError 50 | ParseFailed err -> do 51 | Console.log "Parse failed." 52 | Console.error $ printPositionedError err 53 | Nothing -> 54 | Console.log "File path required" 55 | 56 | printPositionedError :: PositionedError -> String 57 | printPositionedError { error, position } = 58 | "[" <> show (position.line + 1) <> ":" <> show (position.column + 1) <> "] " <> printParseError error 59 | 60 | tokenStreamToArray :: TokenStream -> Either ParseError (Array SourceToken) 61 | tokenStreamToArray = go [] 62 | where 63 | go acc = step >>> case _ of 64 | TokenEOF _ _ -> 65 | Right acc 66 | TokenError _ err _ _ -> 67 | Left err 68 | TokenCons tok _ next _ -> 69 | go (Array.snoc acc tok) next 70 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "scripts": { 4 | "install": "spago install", 5 | "build": "spago build", 6 | "test": "spago test", 7 | "parse-package-set": "spago run --package parse-package-set", 8 | "bench-file": "spago build --package bench && node --expose-gc --input-type=\"module\" -e \"import { main } from './output/BenchFile/index.js';main()\"", 9 | "parse-file": "spago build --package bench && node --input-type=\"module\" -e \"import { main } from './output/ParseFile/index.js';main()\"", 10 | "format": "purs-tidy format-in-place src test bench/src parse-package-set/src", 11 | "format:check": "purs-tidy check src test bench/src parse-package-set/src" 12 | }, 13 | "devDependencies": { 14 | "purescript": "^0.15.15", 15 | "purescript-psa": "^0.9.0", 16 | "purs-tidy": "^0.11.0", 17 | "spago": "^0.93.44" 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /parse-package-set/package-set-install/spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | name: package-set-install 3 | dependencies: 4 | - abc-parser 5 | - ace 6 | - address-rfc2821 7 | - aff 8 | - aff-bus 9 | - aff-coroutines 10 | - aff-promise 11 | - aff-retry 12 | - affjax 13 | - affjax-node 14 | - affjax-web 15 | - ansi 16 | - apexcharts 17 | - applicative-phases 18 | - argonaut 19 | - argonaut-aeson-generic 20 | - argonaut-codecs 21 | - argonaut-core 22 | - argonaut-generic 23 | - argonaut-traversals 24 | - argparse-basic 25 | - array-builder 26 | - array-search 27 | - arraybuffer 28 | - arraybuffer-builder 29 | - arraybuffer-types 30 | - arrays 31 | - arrays-extra 32 | - arrays-zipper 33 | - ask 34 | - assert 35 | - assert-multiple 36 | - avar 37 | - b64 38 | - barbies 39 | - barlow-lens 40 | - benchlib 41 | - bifunctors 42 | - bigints 43 | - bolson 44 | - bookhound 45 | - bower-json 46 | - call-by-name 47 | - canvas 48 | - canvas-action 49 | - cartesian 50 | - catenable-lists 51 | - cbor-stream 52 | - chameleon 53 | - chameleon-halogen 54 | - chameleon-react-basic 55 | - chameleon-styled 56 | - chameleon-transformers 57 | - channel 58 | - checked-exceptions 59 | - choku 60 | - classless 61 | - classless-arbitrary 62 | - classless-decode-json 63 | - classless-encode-json 64 | - classnames 65 | - codec 66 | - codec-argonaut 67 | - codec-json 68 | - colors 69 | - concur-core 70 | - concur-react 71 | - concurrent-queues 72 | - console 73 | - const 74 | - contravariant 75 | - control 76 | - convertable-options 77 | - coroutines 78 | - css 79 | - css-class-name-extractor 80 | - css-frameworks 81 | - csv-stream 82 | - data-mvc 83 | - datetime 84 | - datetime-parsing 85 | - debounce 86 | - debug 87 | - decimals 88 | - default-values 89 | - deku 90 | - deno 91 | - dissect 92 | - distributive 93 | - dodo-printer 94 | - dom-filereader 95 | - dom-indexed 96 | - dom-simple 97 | - dotenv 98 | - droplet 99 | - dts 100 | - dual-numbers 101 | - dynamic-buffer 102 | - echarts-simple 103 | - effect 104 | - either 105 | - elmish 106 | - elmish-enzyme 107 | - elmish-hooks 108 | - elmish-html 109 | - elmish-testing-library 110 | - email-validate 111 | - encoding 112 | - enums 113 | - env-names 114 | - error 115 | - eta-conversion 116 | - exceptions 117 | - exists 118 | - exitcodes 119 | - expect-inferred 120 | - express 121 | - ezfetch 122 | - fahrtwind 123 | - fakerjs 124 | - fallback 125 | - fast-vect 126 | - fetch 127 | - fetch-argonaut 128 | - fetch-core 129 | - fetch-yoga-json 130 | - ffi-simple 131 | - fft 132 | - fft-js 133 | - filterable 134 | - fix-functor 135 | - fixed-points 136 | - fixed-precision 137 | - flame 138 | - float32 139 | - fmt 140 | - foldable-traversable 141 | - foldable-traversable-extra 142 | - foreign 143 | - foreign-object 144 | - foreign-readwrite 145 | - forgetmenot 146 | - fork 147 | - form-urlencoded 148 | - formatters 149 | - framer-motion 150 | - free 151 | - freeap 152 | - freer-free 153 | - freet 154 | - functions 155 | - functor1 156 | - functors 157 | - fuzzy 158 | - gen 159 | - generate-values 160 | - generic-router 161 | - geojson 162 | - geometria 163 | - gesso 164 | - gojs 165 | - golem-fetch 166 | - grain 167 | - grain-router 168 | - grain-virtualized 169 | - graphs 170 | - group 171 | - halogen 172 | - halogen-bootstrap5 173 | - halogen-canvas 174 | - halogen-css 175 | - halogen-declarative-canvas 176 | - halogen-echarts-simple 177 | - halogen-formless 178 | - halogen-helix 179 | - halogen-hooks 180 | - halogen-hooks-extra 181 | - halogen-infinite-scroll 182 | - halogen-store 183 | - halogen-storybook 184 | - halogen-subscriptions 185 | - halogen-svg-elems 186 | - halogen-typewriter 187 | - halogen-use-trigger-hooks 188 | - halogen-vdom 189 | - halogen-vdom-string-renderer 190 | - halogen-xterm 191 | - heckin 192 | - heterogeneous 193 | - homogeneous 194 | - http-methods 195 | - httpurple 196 | - huffman 197 | - humdrum 198 | - hyrule 199 | - identity 200 | - identy 201 | - indexed-db 202 | - indexed-monad 203 | - int64 204 | - integers 205 | - interpolate 206 | - intersection-observer 207 | - invariant 208 | - jarilo 209 | - jelly 210 | - jelly-router 211 | - jelly-signal 212 | - jest 213 | - js-abort-controller 214 | - js-bigints 215 | - js-date 216 | - js-fetch 217 | - js-fileio 218 | - js-intl 219 | - js-iterators 220 | - js-maps 221 | - js-promise 222 | - js-promise-aff 223 | - js-timers 224 | - js-uri 225 | - jsdom 226 | - json 227 | - json-codecs 228 | - justifill 229 | - jwt 230 | - labeled-data 231 | - language-cst-parser 232 | - lazy 233 | - lazy-joe 234 | - lcg 235 | - leibniz 236 | - leveldb 237 | - liminal 238 | - linalg 239 | - lists 240 | - literals 241 | - logging 242 | - logging-journald 243 | - lumi-components 244 | - machines 245 | - maps-eager 246 | - marionette 247 | - marionette-react-basic-hooks 248 | - marked 249 | - matrices 250 | - matryoshka 251 | - maybe 252 | - media-types 253 | - meowclient 254 | - midi 255 | - milkis 256 | - minibench 257 | - mmorph 258 | - monad-control 259 | - monad-logger 260 | - monad-loops 261 | - monad-unlift 262 | - monoid-extras 263 | - monoidal 264 | - morello 265 | - mote 266 | - motsunabe 267 | - mvc 268 | - mysql 269 | - n3 270 | - nano-id 271 | - nanoid 272 | - naturals 273 | - nested-functor 274 | - newtype 275 | - nextjs 276 | - nextui 277 | - node-buffer 278 | - node-child-process 279 | - node-event-emitter 280 | - node-execa 281 | - node-fs 282 | - node-glob-basic 283 | - node-http 284 | - node-http2 285 | - node-human-signals 286 | - node-net 287 | - node-os 288 | - node-path 289 | - node-process 290 | - node-readline 291 | - node-sqlite3 292 | - node-stream-pipes 293 | - node-streams 294 | - node-tls 295 | - node-url 296 | - node-workerbees 297 | - node-zlib 298 | - nonempty 299 | - now 300 | - npm-package-json 301 | - nullable 302 | - numberfield 303 | - numbers 304 | - oak 305 | - oak-debug 306 | - object-maps 307 | - ocarina 308 | - oooooooooorrrrrrrmm-lib 309 | - open-colors-scales-and-schemes 310 | - open-folds 311 | - open-foreign-generic 312 | - open-memoize 313 | - open-mkdirp-aff 314 | - open-pairing 315 | - open-smolder 316 | - options 317 | - optparse 318 | - ordered-collections 319 | - ordered-set 320 | - orders 321 | - owoify 322 | - pairs 323 | - parallel 324 | - parsing 325 | - parsing-dataview 326 | - partial 327 | - pathy 328 | - pha 329 | - phaser 330 | - phylio 331 | - pipes 332 | - pirates-charm 333 | - pmock 334 | - point-free 335 | - pointed-list 336 | - polymorphic-vectors 337 | - posix-types 338 | - postgresql 339 | - precise 340 | - precise-datetime 341 | - prelude 342 | - prettier-printer 343 | - printf 344 | - priority-queue 345 | - profunctor 346 | - profunctor-lenses 347 | - protobuf 348 | - psa-utils 349 | - psci-support 350 | - punycode 351 | - qualified-do 352 | - quantities 353 | - quickcheck 354 | - quickcheck-combinators 355 | - quickcheck-laws 356 | - quickcheck-utf8 357 | - random 358 | - rationals 359 | - rdf 360 | - react 361 | - react-aria 362 | - react-basic 363 | - react-basic-classic 364 | - react-basic-dnd 365 | - react-basic-dom 366 | - react-basic-dom-beta 367 | - react-basic-emotion 368 | - react-basic-hooks 369 | - react-basic-storybook 370 | - react-dom 371 | - react-halo 372 | - react-icons 373 | - react-markdown 374 | - react-testing-library 375 | - react-virtuoso 376 | - reactix 377 | - read 378 | - recharts 379 | - record 380 | - record-extra 381 | - record-extra-srghma 382 | - record-ptional-fields 383 | - record-studio 384 | - refs 385 | - remotedata 386 | - repr 387 | - resize-arrays 388 | - resize-observer 389 | - resource 390 | - resourcet 391 | - result 392 | - return 393 | - ring-modules 394 | - rito 395 | - roman 396 | - rough-notation 397 | - routing 398 | - routing-duplex 399 | - run 400 | - safe-coerce 401 | - safely 402 | - school-of-music 403 | - selection-foldable 404 | - selective-functors 405 | - semirings 406 | - shuffle 407 | - signal 408 | - simple-emitter 409 | - simple-i18n 410 | - simple-json 411 | - simple-json-generics 412 | - simple-ulid 413 | - sized-matrices 414 | - sized-vectors 415 | - slug 416 | - small-ffi 417 | - soundfonts 418 | - sparse-matrices 419 | - sparse-polynomials 420 | - spec 421 | - spec-discovery 422 | - spec-mocha 423 | - spec-node 424 | - spec-quickcheck 425 | - spec-reporter-xunit 426 | - splitmix 427 | - ssrs 428 | - st 429 | - statistics 430 | - strictlypositiveint 431 | - string-parsers 432 | - strings 433 | - strings-extra 434 | - stringutils 435 | - substitute 436 | - supply 437 | - svg-parser 438 | - systemd-journald 439 | - tagged 440 | - tailrec 441 | - tanstack-query 442 | - tecton 443 | - tecton-halogen 444 | - test-unit 445 | - thermite 446 | - thermite-dom 447 | - these 448 | - threading 449 | - tidy 450 | - tidy-codegen 451 | - tldr 452 | - toestand 453 | - transformation-matrix 454 | - transformers 455 | - tree-rose 456 | - trivial-unfold 457 | - ts-bridge 458 | - tuples 459 | - two-or-more 460 | - type-equality 461 | - typedenv 462 | - typelevel 463 | - typelevel-lists 464 | - typelevel-peano 465 | - typelevel-prelude 466 | - typelevel-regex 467 | - typelevel-rows 468 | - typisch 469 | - uint 470 | - ulid 471 | - uncurried-transformers 472 | - undefined 473 | - undefined-is-not-a-problem 474 | - unfoldable 475 | - unicode 476 | - unique 477 | - unlift 478 | - unordered-collections 479 | - unsafe-coerce 480 | - unsafe-reference 481 | - untagged-to-tagged 482 | - untagged-union 483 | - uri 484 | - url-immutable 485 | - url-regex-safe 486 | - uuid 487 | - uuidv4 488 | - validation 489 | - variant 490 | - variant-encodings 491 | - variant-gen 492 | - vectorfield 493 | - vectors 494 | - versions 495 | - visx 496 | - vitest 497 | - web-clipboard 498 | - web-cssom 499 | - web-cssom-view 500 | - web-dom 501 | - web-dom-parser 502 | - web-dom-xpath 503 | - web-encoding 504 | - web-events 505 | - web-fetch 506 | - web-file 507 | - web-geometry 508 | - web-html 509 | - web-pointerevents 510 | - web-proletarian 511 | - web-promise 512 | - web-resize-observer 513 | - web-router 514 | - web-socket 515 | - web-storage 516 | - web-streams 517 | - web-touchevents 518 | - web-uievents 519 | - web-url 520 | - web-workers 521 | - web-xhr 522 | - webextension-polyfill 523 | - webgpu 524 | - which 525 | - whine-core 526 | - xterm 527 | - yoga-fetch 528 | - yoga-json 529 | - yoga-om 530 | - yoga-postgres 531 | - yoga-react-dom 532 | - yoga-subtlecrypto 533 | - yoga-tree 534 | - z3 535 | - zipperarray 536 | workspace: 537 | packageSet: 538 | registry: 64.9.0 539 | extraPackages: {} 540 | -------------------------------------------------------------------------------- /parse-package-set/spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | name: parse-package-set 3 | build: 4 | strict: true 5 | dependencies: 6 | - aff: ">=8.0.0 <9.0.0" 7 | - argonaut-codecs: ">=9.1.0 <10.0.0" 8 | - argonaut-core: ">=7.0.0 <8.0.0" 9 | - arrays: ">=7.3.0 <8.0.0" 10 | - avar: ">=5.0.1 <6.0.0" 11 | - console: ">=6.1.0 <7.0.0" 12 | - datetime: ">=6.1.0 <7.0.0" 13 | - effect: ">=4.0.0 <5.0.0" 14 | - either: ">=6.1.0 <7.0.0" 15 | - exceptions: ">=6.1.0 <7.0.0" 16 | - filterable: ">=5.0.0 <6.0.0" 17 | - foldable-traversable: ">=6.0.0 <7.0.0" 18 | - foreign-object: ">=4.1.0 <5.0.0" 19 | - language-cst-parser: "*" 20 | - maybe: ">=6.0.0 <7.0.0" 21 | - newtype: ">=5.0.0 <6.0.0" 22 | - node-buffer: ">=9.0.0 <10.0.0" 23 | - node-child-process: ">=11.1.0 <12.0.0" 24 | - node-fs: ">=9.2.0 <10.0.0" 25 | - node-glob-basic: ">=2.0.0 <3.0.0" 26 | - node-path: ">=5.0.1 <6.0.0" 27 | - node-process: ">=11.2.0 <12.0.0" 28 | - node-streams: ">=9.0.1 <10.0.0" 29 | - numbers: ">=9.0.1 <10.0.0" 30 | - parallel: ">=7.0.0 <8.0.0" 31 | - prelude: ">=6.0.2 <7.0.0" 32 | - strings: ">=6.0.1 <7.0.0" 33 | -------------------------------------------------------------------------------- /parse-package-set/src/Main.js: -------------------------------------------------------------------------------- 1 | import { mkdtempSync } from "fs"; 2 | import { tmpdir } from "os"; 3 | import { join } from "path"; 4 | import { hrtime } from "process"; 5 | 6 | const tmpdirImpl = function (prefix) { 7 | return () => mkdtempSync(join(tmpdir(), prefix), "utf-8"); 8 | }; 9 | export { tmpdirImpl as tmpdir }; 10 | 11 | const hrtimeImpl = function () { 12 | const t = hrtime(); 13 | return { seconds: t[0], nanos: t[1] }; 14 | }; 15 | export { hrtimeImpl as hrtime }; 16 | 17 | export function hrtimeDiff(old) { 18 | return () => { 19 | const t = hrtime([old.seconds, old.nanos]); 20 | return { seconds: t[0], nanos: t[1] }; 21 | }; 22 | } 23 | -------------------------------------------------------------------------------- /parse-package-set/src/Main.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude 4 | 5 | import Control.Parallel (parTraverse) 6 | import Data.Argonaut.Core (Json) 7 | import Data.Argonaut.Decode (parseJson, decodeJson, printJsonDecodeError) 8 | import Data.Array (foldMap) 9 | import Data.Array as Array 10 | import Data.Array.NonEmpty as NEA 11 | import Data.Either (Either(..), either) 12 | import Data.Filterable (partitionMap) 13 | import Data.Foldable (for_) 14 | import Data.FoldableWithIndex (forWithIndex_) 15 | import Data.Maybe (Maybe(..)) 16 | import Data.Monoid.Additive (Additive(..)) 17 | import Data.Newtype (un) 18 | import Data.Number.Format as NF 19 | import Data.String as Str 20 | import Data.String.CodeUnits as String 21 | import Data.Time.Duration (Milliseconds(..)) 22 | import Effect (Effect) 23 | import Effect.AVar as EffectAVar 24 | import Effect.Aff (Aff, runAff_, throwError, error) 25 | import Effect.Aff.AVar as AVar 26 | import Effect.Class (liftEffect) 27 | import Effect.Console as Console 28 | import Effect.Exception (throw, throwException) 29 | import Foreign.Object (Object) 30 | import Foreign.Object as Object 31 | import Node.Buffer as Buffer 32 | import Node.ChildProcess (SpawnSyncOptions) 33 | import Node.ChildProcess as Exec 34 | import Node.ChildProcess.Types (Exit(..)) 35 | import Node.Encoding (Encoding(..)) 36 | import Node.FS.Aff (readTextFile) 37 | import Node.Glob.Basic as Glob 38 | import Node.Path (FilePath) 39 | import Node.Path as Path 40 | import Node.Process (stderr) 41 | import Node.Process as Process 42 | import Node.Stream as Stream 43 | import PureScript.CST (RecoveredParserResult(..), parseModule, printModule) 44 | import PureScript.CST.Errors (printParseError) 45 | import PureScript.CST.ModuleGraph (sortModules, ModuleSort(..)) 46 | import PureScript.CST.Parser.Monad (PositionedError) 47 | import PureScript.CST.Types (Module(..), ModuleHeader) 48 | 49 | foreign import tmpdir :: String -> Effect String 50 | 51 | foreign import hrtime :: Effect { seconds :: Number, nanos :: Number } 52 | 53 | foreign import hrtimeDiff :: { seconds :: Number, nanos :: Number } -> Effect { seconds :: Number, nanos :: Number } 54 | 55 | execSpawn :: String -> Array String -> (SpawnSyncOptions -> SpawnSyncOptions) -> Effect String 56 | execSpawn proc args options = do 57 | res <- Exec.spawnSync' proc args options 58 | case res.exitStatus of 59 | Normally 0 -> 60 | Buffer.toString UTF8 res.stdout 61 | _ -> do 62 | _ <- Stream.write stderr res.stderr 63 | throw $ "Child process failed: " <> proc <> " " <> Str.joinWith " " args 64 | 65 | main :: Effect Unit 66 | main = runAff_ (either throwException mempty) do 67 | dir <- liftEffect $ Process.cwd 68 | let installPath = Path.concat [ dir, "parse-package-set", "package-set-install" ] 69 | s <- liftEffect $ execSpawn "spago" [ "ls", "packages", "--json" ] (_ { cwd = Just installPath }) 70 | packages <- case decodeJson =<< parseJson s of 71 | Left err -> throwError $ error $ printJsonDecodeError err 72 | Right (object :: Object Json) -> pure $ Object.keys object 73 | _ <- liftEffect $ execSpawn "spago" ([ "install" ] <> packages) (_ { cwd = Just installPath }) 74 | 75 | pursFiles <- Array.fromFoldable <$> Glob.expandGlobs (Path.concat [ installPath, ".spago", "p" ]) [ "*/src/**/*.purs" ] 76 | moduleResults <- parseModulesFromFiles pursFiles 77 | 78 | let 79 | partition = moduleResults # partitionMap \{ path, errors, duration, printerMatches } -> 80 | if Array.null errors then 81 | Right { path, duration, printerMatches } 82 | else 83 | Left { path, errors, duration } 84 | 85 | liftEffect $ forWithIndex_ partition.left \ix failed -> do 86 | let 87 | message = Array.intercalate "\n" 88 | [ "---- [Error " <> show (ix + 1) <> " of " <> show (Array.length partition.left) <> ". Failed in " <> formatMs failed.duration <> " ] ----" 89 | , "" 90 | , Array.intercalate "\n" $ foldMap formatError failed.errors 91 | ] 92 | 93 | formatError error = 94 | [ " " <> failed.path <> ":" <> show (error.position.line + 1) <> ":" <> show (error.position.column + 1) 95 | , " " <> printParseError error.error <> " at line " <> show (error.position.line + 1) <> ", column " <> show (error.position.column + 1) 96 | , "" 97 | ] 98 | Console.error message 99 | 100 | let 101 | successMessage = Array.intercalate " " 102 | [ "Successfully parsed" 103 | , show (Array.length partition.right) 104 | , "of" 105 | , show (Array.length pursFiles) 106 | , "modules." 107 | ] 108 | 109 | liftEffect $ Console.log successMessage 110 | liftEffect $ Console.log $ displayDurationStats (getDurationStats partition.right) "Success Case" 111 | 112 | let 113 | printerSucceeded = Array.filter (_.printerMatches >>> eq (Just true)) partition.right 114 | 115 | printerSuccessMessage = Array.intercalate " " 116 | [ "Successfully printed" 117 | , show (Array.length printerSucceeded) 118 | , "of" 119 | , show (Array.length partition.right) 120 | , "successully parsed modules." 121 | ] 122 | 123 | liftEffect $ Console.log printerSuccessMessage 124 | 125 | let 126 | printerFailed = Array.filter (_.printerMatches >>> eq (Just false)) partition.right 127 | 128 | printerFailedMessage = Array.intercalate " " 129 | [ "Printer failed for" 130 | , show (Array.length printerFailed) 131 | , "of" 132 | , show (Array.length partition.right) 133 | , "successfully parsed modules." 134 | ] 135 | 136 | unless (Array.null printerFailed) $ liftEffect do 137 | Console.error printerFailedMessage 138 | forWithIndex_ printerFailed \ix failed -> do 139 | let 140 | message = Array.intercalate "\n" 141 | [ "---- [Printer Error " <> show (ix + 1) <> " of " <> show (Array.length printerFailed) <> "] ----" 142 | , "" 143 | , failed.path 144 | ] 145 | Console.error message 146 | 147 | let 148 | mods = Array.mapMaybe _.mbModule moduleResults 149 | 150 | liftEffect case sortModules identity mods of 151 | Sorted sorted -> Console.log $ Array.intercalate " " 152 | [ "Successfully sorted module graph for" 153 | , show (Array.length sorted) 154 | , "of" 155 | , show (Array.length partition.right) 156 | , " successfully parsed modules." 157 | ] 158 | CycleDetected _ -> Console.log $ Array.intercalate " " 159 | [ "Error: cycle detected in module graph" 160 | ] 161 | 162 | type ModuleResult = 163 | { path :: FilePath 164 | , errors :: Array PositionedError 165 | , duration :: Milliseconds 166 | , mbModule :: Maybe (ModuleHeader Void) 167 | , printerMatches :: Maybe Boolean 168 | } 169 | 170 | parseModulesFromFiles :: Array FilePath -> Aff (Array ModuleResult) 171 | parseModulesFromFiles pursFiles = do 172 | block <- AVar.empty 173 | 174 | for_ (Array.range 1 10) \_ -> do 175 | liftEffect $ EffectAVar.put unit block mempty 176 | 177 | flip parTraverse pursFiles \file -> do 178 | AVar.take block 179 | result <- parseModuleFromFile file 180 | _ <- liftEffect $ EffectAVar.put unit block mempty 181 | pure result 182 | 183 | parseModuleFromFile :: FilePath -> Aff ModuleResult 184 | parseModuleFromFile path = do 185 | contents <- readTextFile UTF8 path 186 | before <- liftEffect hrtime 187 | let parsed = parseModule contents 188 | duration <- liftEffect $ hrtimeDiff before 189 | let 190 | durationMillis = Milliseconds $ duration.seconds * 1000.0 + duration.nanos / 1000000.0 191 | 192 | errors = case parsed of 193 | ParseSucceeded _ -> [] 194 | ParseSucceededWithErrors _ errs -> NEA.toArray errs 195 | ParseFailed err -> [ err ] 196 | 197 | mbModule = case parsed of 198 | ParseSucceeded (Module mod) -> Just mod.header 199 | ParseSucceededWithErrors _ _ -> Nothing 200 | ParseFailed _ -> Nothing 201 | 202 | printerMatches = case parsed of 203 | ParseSucceeded mod -> 204 | pure $ contents == printModule mod 205 | ParseSucceededWithErrors mod _ -> 206 | pure $ contents == printModule mod 207 | ParseFailed _ -> Nothing 208 | 209 | pure 210 | { path 211 | , errors 212 | , mbModule 213 | , duration: durationMillis 214 | , printerMatches 215 | } 216 | 217 | type DurationStats r = 218 | { minDuration :: Array { path :: FilePath, duration :: Milliseconds | r } 219 | , maxDuration :: Array { path :: FilePath, duration :: Milliseconds | r } 220 | , mean :: Milliseconds 221 | , total :: Milliseconds 222 | } 223 | 224 | getDurationStats :: forall r. Array { path :: FilePath, duration :: Milliseconds | r } -> DurationStats r 225 | getDurationStats res = 226 | { minDuration: Array.take 20 sorted 227 | , maxDuration: Array.reverse (Array.takeEnd 20 sorted) 228 | , mean 229 | , total: Milliseconds sum.duration 230 | } 231 | where 232 | sorted = 233 | Array.sortBy (comparing _.duration) res 234 | 235 | sum = 236 | sorted 237 | # foldMap (\{ duration: Milliseconds duration } -> Additive { duration, total: 1.0 }) 238 | # un Additive 239 | 240 | mean = 241 | sum 242 | # \{ duration, total } -> Milliseconds (duration / total) 243 | 244 | displayDurationStats :: forall r. DurationStats r -> String -> String 245 | displayDurationStats { minDuration, maxDuration, mean, total } title = 246 | Array.intercalate "\n" 247 | [ "" 248 | , "---- [ " <> title <> " Timing Information ] ----" 249 | , "Fastest Parse Times:" 250 | , Array.intercalate "\n" $ displayLine <$> minDuration 251 | , "" 252 | , "Slowest Parse Times:" 253 | , Array.intercalate "\n" $ displayLine <$> maxDuration 254 | , "" 255 | , "Total Parse: " <> formatMs total 256 | , "Mean Parse: " <> formatMs mean 257 | ] 258 | 259 | where 260 | displayLine { path, duration } = 261 | String.takeRight 12 (" " <> formatMs duration) <> " " <> path 262 | 263 | formatMs :: Milliseconds -> String 264 | formatMs (Milliseconds ms) = NF.toStringWith (NF.fixed 3) ms <> "ms" 265 | -------------------------------------------------------------------------------- /spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | name: language-cst-parser 3 | description: A parser for the PureScript concrete syntax tree. 4 | publish: 5 | version: 0.14.1 6 | license: MIT 7 | location: 8 | githubOwner: natefaubion 9 | githubRepo: purescript-language-cst-parser 10 | dependencies: 11 | - arrays: ">=7.3.0 <8.0.0" 12 | - const: ">=6.0.0 <7.0.0" 13 | - control: ">=6.0.0 <7.0.0" 14 | - either: ">=6.1.0 <7.0.0" 15 | - enums: ">=6.0.1 <7.0.0" 16 | - foldable-traversable: ">=6.0.0 <7.0.0" 17 | - free: ">=7.1.0 <8.0.0" 18 | - functions: ">=6.0.0 <7.0.0" 19 | - functors: ">=5.0.0 <6.0.0" 20 | - identity: ">=6.0.0 <7.0.0" 21 | - integers: ">=6.0.0 <7.0.0" 22 | - lazy: ">=6.0.0 <7.0.0" 23 | - lists: ">=7.0.0 <8.0.0" 24 | - maybe: ">=6.0.0 <7.0.0" 25 | - newtype: ">=5.0.0 <6.0.0" 26 | - numbers: ">=9.0.1 <10.0.0" 27 | - ordered-collections: ">=3.2.0 <4.0.0" 28 | - partial: ">=4.0.0 <5.0.0" 29 | - prelude: ">=6.0.2 <7.0.0" 30 | - st: ">=6.2.0 <7.0.0" 31 | - strings: ">=6.0.1 <7.0.0" 32 | - transformers: ">=6.1.0 <7.0.0" 33 | - tuples: ">=7.0.0 <8.0.0" 34 | - typelevel-prelude: ">=7.0.0 <8.0.0" 35 | - unfoldable: ">=6.0.0 <7.0.0" 36 | - unsafe-coerce: ">=6.0.0 <7.0.0" 37 | test: 38 | main: Test.Main 39 | dependencies: 40 | - console 41 | - effect 42 | - node-process 43 | workspace: {} 44 | -------------------------------------------------------------------------------- /src/PureScript/CST.purs: -------------------------------------------------------------------------------- 1 | module PureScript.CST 2 | ( RecoveredParserResult(..) 3 | , PartialModule(..) 4 | , parseModule 5 | , parsePartialModule 6 | , parseImportDecl 7 | , parseDecl 8 | , parseExpr 9 | , parseType 10 | , parseBinder 11 | , printModule 12 | , toRecovered 13 | ) where 14 | 15 | import Prelude 16 | import Prim hiding (Type) 17 | 18 | import Data.Array.NonEmpty (NonEmptyArray) 19 | import Data.Array.NonEmpty as NonEmptyArray 20 | import Data.Either (Either(..)) 21 | import Data.Foldable (foldMap) 22 | import Data.Lazy as Z 23 | import Data.Maybe (Maybe(..)) 24 | import Data.Newtype (unwrap) 25 | import Data.Tuple (Tuple(..)) 26 | import PureScript.CST.Lexer (lex, lexModule) 27 | import PureScript.CST.Parser (Recovered, parseModuleBody, parseModuleHeader) 28 | import PureScript.CST.Parser as Parser 29 | import PureScript.CST.Parser.Monad (Parser, ParserResult(..), PositionedError, fromParserResult, initialParserState, runParser, runParser') 30 | import PureScript.CST.Print as Print 31 | import PureScript.CST.Range (class TokensOf, tokensOf) 32 | import PureScript.CST.Range.TokenList as TokenList 33 | import PureScript.CST.TokenStream (TokenStream) 34 | import PureScript.CST.Types (Binder, Declaration, Expr, ImportDecl, Module(..), ModuleHeader, Type) 35 | import Unsafe.Coerce (unsafeCoerce) 36 | 37 | data RecoveredParserResult f 38 | = ParseSucceeded (f Void) 39 | | ParseSucceededWithErrors (Recovered f) (NonEmptyArray PositionedError) 40 | | ParseFailed PositionedError 41 | 42 | toRecoveredParserResult 43 | :: forall f 44 | . Either PositionedError (Tuple (Recovered f) (Array PositionedError)) 45 | -> RecoveredParserResult f 46 | toRecoveredParserResult = case _ of 47 | Right (Tuple res errors) 48 | | Just nea <- NonEmptyArray.fromArray errors -> 49 | ParseSucceededWithErrors res nea 50 | | otherwise -> 51 | ParseSucceeded ((unsafeCoerce :: Recovered f -> f Void) res) 52 | Left err -> 53 | ParseFailed err 54 | 55 | toRecovered :: forall f. f Void -> Recovered f 56 | toRecovered = unsafeCoerce 57 | 58 | runRecoveredParser :: forall a. Parser (Recovered a) -> TokenStream -> RecoveredParserResult a 59 | runRecoveredParser p = toRecoveredParserResult <<< flip runParser p 60 | 61 | parseModule :: String -> RecoveredParserResult Module 62 | parseModule = runRecoveredParser Parser.parseModule <<< lexModule 63 | 64 | parseImportDecl :: String -> RecoveredParserResult ImportDecl 65 | parseImportDecl = runRecoveredParser Parser.parseImportDecl <<< lex 66 | 67 | parseDecl :: String -> RecoveredParserResult Declaration 68 | parseDecl = runRecoveredParser Parser.parseDecl <<< lex 69 | 70 | parseExpr :: String -> RecoveredParserResult Expr 71 | parseExpr = runRecoveredParser Parser.parseExpr <<< lex 72 | 73 | parseType :: String -> RecoveredParserResult Type 74 | parseType = runRecoveredParser Parser.parseType <<< lex 75 | 76 | parseBinder :: String -> RecoveredParserResult Binder 77 | parseBinder = runRecoveredParser Parser.parseBinder <<< lex 78 | 79 | newtype PartialModule e = PartialModule 80 | { header :: ModuleHeader e 81 | , full :: Z.Lazy (RecoveredParserResult Module) 82 | } 83 | 84 | parsePartialModule :: String -> RecoveredParserResult PartialModule 85 | parsePartialModule src = 86 | toRecoveredParserResult $ case runParser' (initialParserState (lexModule src)) parseModuleHeader of 87 | ParseSucc header state -> do 88 | let 89 | res = PartialModule 90 | { header 91 | , full: Z.defer \_ -> 92 | toRecoveredParserResult $ fromParserResult $ runParser' state do 93 | body <- parseModuleBody 94 | pure $ Module { header, body } 95 | } 96 | Right $ Tuple res state.errors 97 | ParseFail error _ -> 98 | Left error 99 | 100 | printModule :: forall e. TokensOf e => Module e -> String 101 | printModule mod = 102 | foldMap Print.printSourceToken (TokenList.toArray (tokensOf mod)) 103 | <> foldMap (Print.printComment Print.printLineFeed) (unwrap (unwrap mod).body).trailingComments 104 | -------------------------------------------------------------------------------- /src/PureScript/CST/Errors.purs: -------------------------------------------------------------------------------- 1 | module PureScript.CST.Errors 2 | ( RecoveredError(..) 3 | , ParseError(..) 4 | , printParseError 5 | , printTokenError 6 | ) where 7 | 8 | import Prelude 9 | 10 | import PureScript.CST.Print (printQualified) 11 | import PureScript.CST.Types (SourcePos, SourceStyle(..), Token(..), SourceToken) 12 | 13 | newtype RecoveredError = RecoveredError 14 | { error :: ParseError 15 | , position :: SourcePos 16 | , tokens :: Array SourceToken 17 | } 18 | 19 | data ParseError 20 | = UnexpectedEof 21 | | ExpectedEof Token 22 | | UnexpectedToken Token 23 | | ExpectedToken Token Token 24 | | ExpectedClass String Token 25 | | LexExpected String String 26 | | LexInvalidCharEscape String 27 | | LexCharEscapeOutOfRange String 28 | | LexHexOutOfRange String 29 | | LexIntOutOfRange String 30 | | LexNumberOutOfRange String 31 | 32 | printParseError :: ParseError -> String 33 | printParseError = case _ of 34 | UnexpectedEof -> 35 | "Unexpected end of file" 36 | ExpectedEof tok -> 37 | "Expected end of file, saw " <> printTokenError tok 38 | UnexpectedToken tok -> 39 | "Unexpected " <> printTokenError tok 40 | ExpectedToken tok saw -> 41 | "Expected " <> printTokenError tok <> ", saw " <> printTokenError saw 42 | ExpectedClass cls saw -> 43 | "Expected " <> cls <> ", saw " <> printTokenError saw 44 | LexExpected str saw -> 45 | "Expected " <> str <> ", saw " <> saw 46 | LexInvalidCharEscape str -> 47 | "Invalid character escape \\" <> str 48 | LexCharEscapeOutOfRange str -> 49 | "Character escape out of range \\" <> str 50 | LexHexOutOfRange str -> 51 | "Hex integer out of range 0x" <> str 52 | LexIntOutOfRange str -> 53 | "Int out of range " <> str 54 | LexNumberOutOfRange str -> 55 | "Number out of range " <> str 56 | 57 | printTokenError :: Token -> String 58 | printTokenError = case _ of 59 | TokLeftParen -> 60 | "'('" 61 | TokRightParen -> 62 | "')'" 63 | TokLeftBrace -> 64 | "'{'" 65 | TokRightBrace -> 66 | "'}'" 67 | TokLeftSquare -> 68 | "'['" 69 | TokRightSquare -> 70 | "']'" 71 | TokLeftArrow style -> 72 | case style of 73 | ASCII -> "'<-'" 74 | Unicode -> "'←'" 75 | TokRightArrow style -> 76 | case style of 77 | ASCII -> "'->'" 78 | Unicode -> "'→'" 79 | TokRightFatArrow style -> 80 | case style of 81 | ASCII -> "'=>'" 82 | Unicode -> "'⇒'" 83 | TokDoubleColon style -> 84 | case style of 85 | ASCII -> "'::'" 86 | Unicode -> "'∷'" 87 | TokForall style -> 88 | case style of 89 | ASCII -> "forall" 90 | Unicode -> "'∀'" 91 | TokEquals -> 92 | "'='" 93 | TokPipe -> 94 | "'|'" 95 | TokTick -> 96 | "`" 97 | TokDot -> 98 | "." 99 | TokComma -> 100 | "','" 101 | TokUnderscore -> 102 | "'_'" 103 | TokBackslash -> 104 | "'\\'" 105 | TokAt -> 106 | "'@'" 107 | TokLowerName moduleName name -> 108 | "identifier " <> printQualified moduleName name 109 | TokUpperName moduleName name -> 110 | "proper identifier " <> printQualified moduleName name 111 | TokOperator moduleName name -> 112 | "operator " <> printQualified moduleName name 113 | TokSymbolName moduleName name -> 114 | "symbol " <> printQualified moduleName name 115 | TokSymbolArrow style -> 116 | case style of 117 | ASCII -> "(->)" 118 | Unicode -> "(→)" 119 | TokHole name -> 120 | "hole ?" <> name 121 | TokChar raw _ -> 122 | "char literal '" <> raw <> "'" 123 | TokString _ _ -> 124 | "string literal" 125 | TokRawString _ -> 126 | "raw string literal" 127 | TokInt raw _ -> 128 | "int literal " <> raw 129 | TokNumber raw _ -> 130 | "number literal " <> raw 131 | TokLayoutStart _ -> 132 | "start of indented block" 133 | TokLayoutSep _ -> 134 | "new indented block item" 135 | TokLayoutEnd _ -> 136 | "end of indented block" 137 | -------------------------------------------------------------------------------- /src/PureScript/CST/Layout.purs: -------------------------------------------------------------------------------- 1 | module PureScript.CST.Layout 2 | ( LayoutStack 3 | , LayoutDelim(..) 4 | , currentIndent 5 | , isIndented 6 | , insertLayout 7 | , lytToken 8 | ) where 9 | 10 | import Prelude 11 | 12 | import Data.Array as Array 13 | import Data.Foldable (find) 14 | import Data.List (List(..), (:)) 15 | import Data.Maybe (Maybe(..)) 16 | import Data.Tuple (Tuple(..), snd, uncurry) 17 | import PureScript.CST.Types (SourcePos, SourceToken, Token(..)) 18 | 19 | type LayoutStack = List (Tuple SourcePos LayoutDelim) 20 | 21 | data LayoutDelim 22 | = LytRoot 23 | | LytTopDecl 24 | | LytTopDeclHead 25 | | LytDeclGuard 26 | | LytCase 27 | | LytCaseBinders 28 | | LytCaseGuard 29 | | LytLambdaBinders 30 | | LytParen 31 | | LytBrace 32 | | LytSquare 33 | | LytIf 34 | | LytThen 35 | | LytProperty 36 | | LytForall 37 | | LytTick 38 | | LytLet 39 | | LytLetStmt 40 | | LytWhere 41 | | LytOf 42 | | LytDo 43 | | LytAdo 44 | 45 | derive instance eqLayoutDelim :: Eq LayoutDelim 46 | derive instance ordLayoutDelim :: Ord LayoutDelim 47 | 48 | currentIndent :: LayoutStack -> Maybe SourcePos 49 | currentIndent = go 50 | where 51 | go = case _ of 52 | Tuple pos lyt : stk 53 | | isIndented lyt -> Just pos 54 | | otherwise -> go stk 55 | _ -> 56 | Nothing 57 | 58 | isIndented :: LayoutDelim -> Boolean 59 | isIndented = case _ of 60 | LytLet -> true 61 | LytLetStmt -> true 62 | LytWhere -> true 63 | LytOf -> true 64 | LytDo -> true 65 | LytAdo -> true 66 | _ -> false 67 | 68 | isTopDecl :: SourcePos -> LayoutStack -> Boolean 69 | isTopDecl tokPos = case _ of 70 | Tuple lytPos LytWhere : Tuple _ LytRoot : Nil 71 | | tokPos.column == lytPos.column -> true 72 | _ -> false 73 | 74 | lytToken :: SourcePos -> Token -> SourceToken 75 | lytToken pos value = 76 | { range: { start: pos, end: pos } 77 | , leadingComments: [] 78 | , trailingComments: [] 79 | , value 80 | } 81 | 82 | insertLayout :: SourceToken -> SourcePos -> LayoutStack -> Tuple LayoutStack (Array (Tuple SourceToken LayoutStack)) 83 | insertLayout src@{ range, value: tok } nextPos stack = 84 | insert (Tuple stack []) 85 | where 86 | tokPos = range.start 87 | 88 | insert state@(Tuple stk acc) = case tok of 89 | -- `data` declarations need masking (LytTopDecl) because the usage of `|` 90 | -- should not introduce a LytDeclGard context. 91 | TokLowerName Nothing "data" -> 92 | case state # insertDefault of 93 | state'@(Tuple stk' _) | isTopDecl tokPos stk' -> 94 | state' # pushStack tokPos LytTopDecl 95 | state' -> 96 | state' # popStack (_ == LytProperty) 97 | 98 | -- `class` declaration heads need masking (LytTopDeclHead) because the 99 | -- usage of commas in functional dependencies. 100 | TokLowerName Nothing "class" -> 101 | case state # insertDefault of 102 | state'@(Tuple stk' _) | isTopDecl tokPos stk' -> 103 | state' # pushStack tokPos LytTopDeclHead 104 | state' -> 105 | state' # popStack (_ == LytProperty) 106 | 107 | TokLowerName Nothing "where" -> 108 | case stk of 109 | Tuple _ LytTopDeclHead : stk' -> 110 | Tuple stk' acc # insertToken src # insertStart LytWhere 111 | Tuple _ LytProperty : stk' -> 112 | Tuple stk' acc # insertToken src 113 | _ -> 114 | state # collapse whereP # insertToken src # insertStart LytWhere 115 | where 116 | -- `where` always closes do blocks: 117 | -- example = do do do do foo where foo = ... 118 | -- 119 | -- `where` closes layout contexts even when indented at the same level: 120 | -- example = case 121 | -- Foo -> ... 122 | -- Bar -> ... 123 | -- where foo = ... 124 | whereP _ LytDo = true 125 | whereP lytPos lyt = offsideEndP lytPos lyt 126 | 127 | TokLowerName Nothing "in" -> 128 | case collapse inP state of 129 | -- `let/in` is not allowed in `ado` syntax. `in` is treated as a 130 | -- delimiter and must always close the `ado`. 131 | -- example = ado 132 | -- foo <- ... 133 | -- let bar = ... 134 | -- in ... 135 | Tuple ((Tuple pos1 LytLetStmt) : (Tuple pos2 LytAdo) : stk') acc' -> 136 | Tuple stk' acc' # insertEnd pos1.column # insertEnd pos2.column # insertToken src 137 | Tuple (Tuple pos1 lyt : stk') acc' | isIndented lyt -> 138 | Tuple stk' acc' # insertEnd pos1.column # insertToken src 139 | _ -> 140 | state # insertDefault # popStack (_ == LytProperty) 141 | where 142 | inP _ LytLet = false 143 | inP _ LytAdo = false 144 | inP _ lyt = isIndented lyt 145 | 146 | TokLowerName Nothing "let" -> 147 | state # insertKwProperty next 148 | where 149 | next state'@(Tuple stk' _) = case stk' of 150 | Tuple p LytDo : _ | p.column == tokPos.column -> 151 | state' # insertStart LytLetStmt 152 | Tuple p LytAdo : _ | p.column == tokPos.column -> 153 | state' # insertStart LytLetStmt 154 | _ -> 155 | state' # insertStart LytLet 156 | 157 | TokLowerName _ "do" -> 158 | state # insertKwProperty (insertStart LytDo) 159 | 160 | TokLowerName _ "ado" -> 161 | state # insertKwProperty (insertStart LytAdo) 162 | 163 | -- `case` heads need masking due to commas. 164 | TokLowerName Nothing "case" -> 165 | state # insertKwProperty (pushStack tokPos LytCase) 166 | 167 | TokLowerName Nothing "of" -> 168 | case collapse indentedP state of 169 | -- When `of` is matched with a `case`, we are in a case block, and we 170 | -- need to mask additional contexts (LytCaseBinders, LytCaseGuards) 171 | -- due to commas. 172 | Tuple (Tuple _ LytCase : stk') acc' -> 173 | Tuple stk' acc' # insertToken src # insertStart LytOf # pushStack nextPos LytCaseBinders 174 | state' -> 175 | state' # insertDefault # popStack (_ == LytProperty) 176 | 177 | -- `if/then/else` is considered a delimiter context. This allows us to 178 | -- write chained expressions in `do` blocks without stair-stepping: 179 | -- example = do 180 | -- foo 181 | -- if ... then 182 | -- ... 183 | -- else if ... then 184 | -- ... 185 | -- else 186 | -- ... 187 | TokLowerName Nothing "if" -> 188 | state # insertKwProperty (pushStack tokPos LytIf) 189 | 190 | TokLowerName Nothing "then" -> 191 | case state # collapse indentedP of 192 | Tuple (Tuple _ LytIf : stk') acc' -> 193 | Tuple stk' acc' # insertToken src # pushStack tokPos LytThen 194 | _ -> 195 | state # insertDefault # popStack (_ == LytProperty) 196 | 197 | TokLowerName Nothing "else" -> 198 | case state # collapse indentedP of 199 | Tuple (Tuple _ LytThen : stk') acc' -> 200 | Tuple stk' acc' # insertToken src 201 | _ -> 202 | -- We don't want to insert a layout separator for top-level `else` in 203 | -- instance chains. 204 | case state # collapse offsideP of 205 | state'@(Tuple stk' _) | isTopDecl tokPos stk' -> 206 | state' # insertToken src 207 | state' -> 208 | state' # insertSep # insertToken src # popStack (_ == LytProperty) 209 | 210 | -- `forall` binders need masking because the usage of `.` should not 211 | -- introduce a LytProperty context. 212 | TokForall _ -> 213 | state # insertKwProperty (pushStack tokPos LytForall) 214 | 215 | -- Lambdas need masking because the usage of `->` should not close a 216 | -- LytDeclGuard or LytCaseGuard context. 217 | TokBackslash -> 218 | state # insertDefault # pushStack tokPos LytLambdaBinders 219 | 220 | TokRightArrow _ -> 221 | state # collapse arrowP # popStack guardP # insertToken src 222 | where 223 | arrowP _ LytDo = true 224 | arrowP _ LytOf = false 225 | arrowP lytPos lyt = offsideEndP lytPos lyt 226 | 227 | guardP LytCaseBinders = true 228 | guardP LytCaseGuard = true 229 | guardP LytLambdaBinders = true 230 | guardP _ = false 231 | 232 | TokEquals -> 233 | case state # collapse equalsP of 234 | Tuple (Tuple _ LytDeclGuard : stk') acc' -> 235 | Tuple stk' acc' # insertToken src 236 | _ -> 237 | state # insertDefault 238 | where 239 | equalsP _ LytWhere = true 240 | equalsP _ LytLet = true 241 | equalsP _ LytLetStmt = true 242 | equalsP _ _ = false 243 | 244 | -- Guards need masking because of commas. 245 | TokPipe -> do 246 | case collapse offsideEndP state of 247 | state'@(Tuple (Tuple _ LytOf : _) _) -> 248 | state' # pushStack tokPos LytCaseGuard # insertToken src 249 | state'@(Tuple (Tuple _ LytLet : _) _) -> 250 | state' # pushStack tokPos LytDeclGuard # insertToken src 251 | state'@(Tuple (Tuple _ LytLetStmt : _) _) -> 252 | state' # pushStack tokPos LytDeclGuard # insertToken src 253 | state'@(Tuple (Tuple _ LytWhere : _) _) -> 254 | state' # pushStack tokPos LytDeclGuard # insertToken src 255 | _ -> 256 | state # insertDefault 257 | 258 | -- Ticks can either start or end an infix expression. We preemptively 259 | -- collapse all indentation contexts in search of a starting delimiter, 260 | -- and backtrack if we don't find one. 261 | TokTick -> do 262 | case state # collapse indentedP of 263 | Tuple (Tuple _ LytTick : stk') acc' -> 264 | Tuple stk' acc' # insertToken src 265 | _ -> 266 | state # collapse offsideEndP # insertSep # insertToken src # pushStack tokPos LytTick 267 | 268 | -- In general, commas should close all indented contexts. 269 | -- example = [ do foo 270 | -- bar, baz ] 271 | TokComma -> do 272 | case state # collapse indentedP of 273 | -- If we see a LytBrace, then we are in a record type or literal. 274 | -- Record labels need masking so we can use unquoted keywords as labels 275 | -- without accidentally littering layout delimiters. 276 | state'@(Tuple (Tuple _ LytBrace : _) _) -> 277 | state' # insertToken src # pushStack tokPos LytProperty 278 | state' -> 279 | state' # insertToken src 280 | 281 | -- TokDot tokens usually entail property access, which need masking so we 282 | -- can use unquoted keywords as labels. 283 | TokDot -> do 284 | case state # insertDefault of 285 | Tuple (Tuple _ LytForall : stk') acc' -> 286 | Tuple stk' acc' 287 | state' -> 288 | state' # pushStack tokPos LytProperty 289 | 290 | TokLeftParen -> 291 | state # insertDefault # pushStack tokPos LytParen 292 | 293 | TokLeftBrace -> 294 | state # insertDefault # pushStack tokPos LytBrace # pushStack tokPos LytProperty 295 | 296 | TokLeftSquare -> 297 | state # insertDefault # pushStack tokPos LytSquare 298 | 299 | TokRightParen -> 300 | state # collapse indentedP # popStack (_ == LytParen) # insertToken src 301 | 302 | TokRightBrace -> 303 | state # collapse indentedP # popStack (_ == LytProperty) # popStack (_ == LytBrace) # insertToken src 304 | 305 | TokRightSquare -> 306 | state # collapse indentedP # popStack (_ == LytSquare) # insertToken src 307 | 308 | TokString _ _ -> 309 | state # insertDefault # popStack (_ == LytProperty) 310 | 311 | TokLowerName Nothing _ -> 312 | state # insertDefault # popStack (_ == LytProperty) 313 | 314 | TokOperator _ _ -> 315 | state # collapse offsideEndP # insertSep # insertToken src 316 | 317 | _ -> 318 | state # insertDefault 319 | 320 | insertDefault state = 321 | state # collapse offsideP # insertSep # insertToken src 322 | 323 | insertStart lyt state@(Tuple stk _) = 324 | -- We only insert a new layout start when it's going to increase indentation. 325 | -- This prevents things like the following from parsing: 326 | -- instance foo :: Foo where 327 | -- foo = 42 328 | case find (isIndented <<< snd) stk of 329 | Just (Tuple pos _) | nextPos.column <= pos.column -> state 330 | _ -> state # pushStack nextPos lyt # insertToken (lytToken nextPos (TokLayoutStart nextPos.column)) 331 | 332 | insertSep state@(Tuple stk acc) = case stk of 333 | -- LytTopDecl is closed by a separator. 334 | Tuple lytPos LytTopDecl : stk' | sepP lytPos -> 335 | Tuple stk' acc # insertToken sepTok 336 | -- LytTopDeclHead can be closed by a separator if there is no `where`. 337 | Tuple lytPos LytTopDeclHead : stk' | sepP lytPos -> 338 | Tuple stk' acc # insertToken sepTok 339 | Tuple lytPos lyt : _ | indentSepP lytPos lyt -> 340 | case lyt of 341 | -- If a separator is inserted in a case block, we need to push an 342 | -- additional LytCaseBinders context for comma masking. 343 | LytOf -> state # insertToken sepTok # pushStack tokPos LytCaseBinders 344 | _ -> state # insertToken sepTok 345 | _ -> 346 | state 347 | where 348 | sepTok = lytToken tokPos (TokLayoutSep tokPos.column) 349 | 350 | insertKwProperty k state = 351 | case state # insertDefault of 352 | Tuple (Tuple _ LytProperty : stk') acc' -> 353 | Tuple stk' acc' 354 | state' -> 355 | k state' 356 | 357 | insertEnd indent = 358 | insertToken (lytToken tokPos (TokLayoutEnd indent)) 359 | 360 | insertToken token (Tuple stk acc) = 361 | Tuple stk (acc `Array.snoc` (Tuple token stk)) 362 | 363 | pushStack lytPos lyt (Tuple stk acc) = 364 | Tuple (Tuple lytPos lyt : stk) acc 365 | 366 | popStack p (Tuple (Tuple _ lyt : stk') acc) 367 | | p lyt = Tuple stk' acc 368 | popStack _ state = state 369 | 370 | collapse p = uncurry go 371 | where 372 | go (Tuple lytPos lyt : stk') acc 373 | | p lytPos lyt = 374 | go stk' 375 | if isIndented lyt then acc `Array.snoc` (Tuple (lytToken tokPos (TokLayoutEnd lytPos.column)) stk') 376 | else acc 377 | go stk acc = 378 | Tuple stk acc 379 | 380 | indentedP = 381 | const isIndented 382 | 383 | offsideP lytPos lyt = 384 | isIndented lyt && tokPos.column < lytPos.column 385 | 386 | offsideEndP lytPos lyt = 387 | isIndented lyt && tokPos.column <= lytPos.column 388 | 389 | indentSepP lytPos lyt = 390 | isIndented lyt && sepP lytPos 391 | 392 | sepP lytPos = 393 | tokPos.column == lytPos.column && tokPos.line /= lytPos.line 394 | -------------------------------------------------------------------------------- /src/PureScript/CST/Lexer.purs: -------------------------------------------------------------------------------- 1 | module PureScript.CST.Lexer 2 | ( lex 3 | , lexModule 4 | , lexWithState 5 | , lexToken 6 | ) where 7 | 8 | import Prelude 9 | 10 | import Control.Alt (class Alt, alt) 11 | import Control.Monad.ST as ST 12 | import Control.Monad.ST.Ref as STRef 13 | import Data.Array as Array 14 | import Data.Array.NonEmpty as NonEmptyArray 15 | import Data.Array.ST as STArray 16 | import Data.Char as Char 17 | import Data.Either (Either(..)) 18 | import Data.Enum (toEnum) 19 | import Data.Foldable (fold, foldl, foldMap) 20 | import Data.Int (hexadecimal) 21 | import Data.Int as Int 22 | import Data.Lazy as Lazy 23 | import Data.List (List(..), (:)) 24 | import Data.Maybe (Maybe(..), isNothing, maybe) 25 | import Data.Newtype (unwrap) 26 | import Data.Number as Number 27 | import Data.String (Pattern(..), Replacement(..)) 28 | import Data.String as String 29 | import Data.String.CodePoints (CodePoint) 30 | import Data.String.CodePoints as SCP 31 | import Data.String.CodeUnits as SCU 32 | import Data.String.Regex as Regex 33 | import Data.String.Regex.Flags (unicode) 34 | import Data.String.Regex.Unsafe (unsafeRegex) 35 | import Data.Tuple (Tuple(..), snd) 36 | import Partial.Unsafe (unsafeCrashWith) 37 | import PureScript.CST.Errors (ParseError(..)) 38 | import PureScript.CST.Layout (LayoutDelim(..), LayoutStack, insertLayout) 39 | import PureScript.CST.TokenStream (TokenStep(..), TokenStream(..), consTokens, step, unwindLayout) 40 | import PureScript.CST.Types (Comment(..), IntValue(..), LineFeed(..), ModuleName(..), SourcePos, SourceStyle(..), Token(..)) 41 | 42 | infixr 3 alt as <|> 43 | 44 | class IsChar a where 45 | fromChar :: Char -> a 46 | fromCharCode :: Int -> Maybe a 47 | 48 | instance IsChar Char where 49 | fromChar = identity 50 | fromCharCode = Char.fromCharCode 51 | 52 | instance IsChar CodePoint where 53 | fromChar = SCP.codePointFromChar 54 | fromCharCode = toEnum 55 | 56 | data LexResult e a 57 | = LexFail e String 58 | | LexSucc a String 59 | 60 | type LexError = Unit -> ParseError 61 | 62 | newtype Lex e a = Lex (String -> LexResult e a) 63 | 64 | instance functorLex :: Functor (Lex e) where 65 | map f (Lex k) = Lex \str -> 66 | case k str of 67 | LexFail a b -> LexFail a b 68 | LexSucc a b -> LexSucc (f a) b 69 | 70 | instance applyLex :: Apply (Lex e) where 71 | apply (Lex k1) (Lex k2) = Lex \str -> 72 | case k1 str of 73 | LexFail a b -> LexFail a b 74 | LexSucc f str' -> 75 | case k2 str' of 76 | LexFail a b -> LexFail a b 77 | LexSucc x str'' -> 78 | LexSucc (f x) str'' 79 | 80 | instance applicativeLex :: Applicative (Lex e) where 81 | pure = Lex <<< LexSucc 82 | 83 | instance bindLex :: Bind (Lex e) where 84 | bind (Lex k1) k = Lex \str -> 85 | case k1 str of 86 | LexFail a b -> LexFail a b 87 | LexSucc a str' -> do 88 | let (Lex k2) = k a 89 | k2 str' 90 | 91 | instance altLex :: Alt (Lex e) where 92 | alt (Lex k1) (Lex k2) = Lex \str -> 93 | case k1 str of 94 | LexFail a str' 95 | | SCU.length str == SCU.length str' -> 96 | k2 str 97 | | otherwise -> 98 | LexFail a str' 99 | LexSucc a b -> 100 | LexSucc a b 101 | 102 | try :: forall e a. Lex e a -> Lex e a 103 | try (Lex k) = Lex \str -> 104 | case k str of 105 | LexFail a _ -> LexFail a str 106 | LexSucc a b -> LexSucc a b 107 | 108 | mkUnexpected :: String -> String 109 | mkUnexpected str = do 110 | let start = String.take 6 str 111 | let len = String.length start 112 | if len == 0 then 113 | "end of file" 114 | else if len < 6 then 115 | start 116 | else 117 | start <> "..." 118 | 119 | regex :: forall e. (String -> e) -> String -> Lex (Unit -> e) String 120 | regex mkErr regexStr = Lex \str -> 121 | case Regex.match matchRegex str of 122 | Just groups 123 | | Just match <- NonEmptyArray.head groups -> 124 | LexSucc match (SCU.drop (SCU.length match) str) 125 | _ -> 126 | LexFail (\_ -> mkErr (mkUnexpected str)) str 127 | where 128 | matchRegex = unsafeRegex ("^(?:" <> regexStr <> ")") unicode 129 | 130 | string :: forall e. (String -> e) -> String -> Lex (Unit -> e) String 131 | string mkErr match = Lex \str -> 132 | if SCU.take (SCU.length match) str == match then 133 | LexSucc match (SCU.drop (SCU.length match) str) 134 | else 135 | LexFail (\_ -> mkErr (mkUnexpected str)) str 136 | 137 | char :: forall e. (String -> e) -> Char -> Lex (Unit -> e) Char 138 | char mkErr match = Lex \str -> 139 | if SCU.singleton match == SCU.take 1 str then 140 | LexSucc match (SCU.drop 1 str) 141 | else 142 | LexFail (\_ -> mkErr (mkUnexpected str)) str 143 | 144 | char' :: forall e a. (String -> e) -> a -> Char -> Lex (Unit -> e) a 145 | char' mkErr res match = Lex \str -> 146 | if SCU.singleton match == SCU.take 1 str then 147 | LexSucc res (SCU.drop 1 str) 148 | else 149 | LexFail (\_ -> mkErr (mkUnexpected str)) str 150 | 151 | optional :: forall e a. Lex e a -> Lex e (Maybe a) 152 | optional (Lex k) = Lex \str -> 153 | case k str of 154 | LexFail err str' 155 | | SCU.length str == SCU.length str' -> 156 | LexSucc Nothing str 157 | | otherwise -> 158 | LexFail err str' 159 | LexSucc a b -> 160 | LexSucc (Just a) b 161 | 162 | satisfy :: forall e. (String -> e) -> (Char -> Boolean) -> Lex (Unit -> e) Char 163 | satisfy mkErr p = Lex \str -> 164 | case SCU.charAt 0 str of 165 | Just ch | p ch -> 166 | LexSucc ch (SCU.drop 1 str) 167 | _ -> 168 | LexFail (\_ -> mkErr (mkUnexpected str)) str 169 | 170 | many :: forall e a. Lex e a -> Lex e (Array a) 171 | many (Lex k) = Lex \str -> ST.run do 172 | valuesRef <- STArray.new 173 | strRef <- STRef.new str 174 | contRef <- STRef.new true 175 | resRef <- STRef.new (LexSucc [] str) 176 | ST.while (STRef.read contRef) do 177 | str' <- STRef.read strRef 178 | case k str' of 179 | LexFail error str'' 180 | | SCU.length str' == SCU.length str'' -> do 181 | values <- STArray.unsafeFreeze valuesRef 182 | _ <- STRef.write (LexSucc values str'') resRef 183 | _ <- STRef.write false contRef 184 | pure unit 185 | | otherwise -> do 186 | _ <- STRef.write (LexFail error str'') resRef 187 | _ <- STRef.write false contRef 188 | pure unit 189 | LexSucc a str'' -> do 190 | _ <- STArray.push a valuesRef 191 | _ <- STRef.write str'' strRef 192 | pure unit 193 | STRef.read resRef 194 | 195 | fail :: forall a. ParseError -> Lex LexError a 196 | fail = Lex <<< LexFail <<< const 197 | 198 | -- | Lexes according to root layout rules and standard language comments. 199 | lex :: String -> TokenStream 200 | lex = lexWithState (Tuple { line: 0, column: 0 } LytRoot : Nil) { line: 0, column: 0 } 201 | 202 | -- | Lexes according to root layout rules as well as supporting leading shebang comments. 203 | lexModule :: String -> TokenStream 204 | lexModule = lexWithState' leadingModuleComments (Tuple { line: 0, column: 0 } LytRoot : Nil) { line: 0, column: 0 } 205 | 206 | lexWithState :: LayoutStack -> SourcePos -> String -> TokenStream 207 | lexWithState = lexWithState' leadingComments 208 | 209 | lexWithState' :: Lex LexError (Array (Comment LineFeed)) -> LayoutStack -> SourcePos -> String -> TokenStream 210 | lexWithState' lexLeadingComments = init 211 | where 212 | init :: LayoutStack -> SourcePos -> String -> TokenStream 213 | init initStack initPos str = TokenStream $ Lazy.defer \_ -> do 214 | let (Lex k) = lexLeadingComments 215 | case k str of 216 | LexFail _ _ -> 217 | unsafeCrashWith "Leading comments can't fail." 218 | LexSucc leading suffix -> do 219 | let nextPos = foldl bumpComment initPos leading 220 | step $ go initStack nextPos leading suffix 221 | 222 | go :: LayoutStack -> SourcePos -> Array (Comment LineFeed) -> String -> TokenStream 223 | go stack startPos leading str = TokenStream $ Lazy.defer \_ -> 224 | if str == "" then 225 | step $ unwindLayout startPos (TokenStream $ Lazy.defer \_ -> TokenEOF startPos leading) stack 226 | else do 227 | let (Lex k) = token' 228 | case k str of 229 | LexFail error remaining -> do 230 | let errPos = bumpText startPos 0 (SCU.take (SCU.length str - SCU.length remaining) str) 231 | TokenError errPos (error unit) Nothing stack 232 | LexSucc result suffix -> do 233 | let 234 | endPos = bumpToken startPos result.token 235 | nextStart = foldl bumpComment (foldl bumpComment endPos result.trailing) result.nextLeading 236 | posToken = 237 | { range: { start: startPos, end: endPos } 238 | , leadingComments: leading 239 | , trailingComments: result.trailing 240 | , value: result.token 241 | } 242 | Tuple nextStack toks = insertLayout posToken nextStart stack 243 | step 244 | $ snd 245 | $ consTokens toks 246 | $ Tuple nextStart 247 | $ go nextStack nextStart result.nextLeading suffix 248 | 249 | token' :: Lex LexError { token :: Token, trailing :: Array (Comment Void), nextLeading :: Array (Comment LineFeed) } 250 | token' = 251 | { token: _, trailing: _, nextLeading: _ } 252 | <$> token 253 | <*> trailingComments 254 | <*> leadingComments 255 | 256 | lexToken :: String -> Either LexError Token 257 | lexToken = k >>> case _ of 258 | LexSucc tok "" -> Right tok 259 | LexSucc tok _ -> Left (\_ -> ExpectedEof tok) 260 | LexFail err _ -> Left err 261 | where 262 | (Lex k) = token 263 | 264 | bumpToken :: SourcePos -> Token -> SourcePos 265 | bumpToken pos@{ line, column } = case _ of 266 | TokLeftParen -> 267 | { line, column: column + 1 } 268 | TokRightParen -> 269 | { line, column: column + 1 } 270 | TokLeftBrace -> 271 | { line, column: column + 1 } 272 | TokRightBrace -> 273 | { line, column: column + 1 } 274 | TokLeftSquare -> 275 | { line, column: column + 1 } 276 | TokRightSquare -> 277 | { line, column: column + 1 } 278 | TokLeftArrow ASCII -> 279 | { line, column: column + 2 } 280 | TokLeftArrow Unicode -> 281 | { line, column: column + 1 } 282 | TokRightArrow ASCII -> 283 | { line, column: column + 2 } 284 | TokRightArrow Unicode -> 285 | { line, column: column + 1 } 286 | TokRightFatArrow ASCII -> 287 | { line, column: column + 2 } 288 | TokRightFatArrow Unicode -> 289 | { line, column: column + 1 } 290 | TokDoubleColon ASCII -> 291 | { line, column: column + 2 } 292 | TokDoubleColon Unicode -> 293 | { line, column: column + 1 } 294 | TokForall ASCII -> 295 | { line, column: column + 6 } 296 | TokForall Unicode -> 297 | { line, column: column + 1 } 298 | TokEquals -> 299 | { line, column: column + 1 } 300 | TokPipe -> 301 | { line, column: column + 1 } 302 | TokTick -> 303 | { line, column: column + 1 } 304 | TokDot -> 305 | { line, column: column + 1 } 306 | TokComma -> 307 | { line, column: column + 1 } 308 | TokUnderscore -> 309 | { line, column: column + 1 } 310 | TokBackslash -> 311 | { line, column: column + 1 } 312 | TokAt -> 313 | { line, column: column + 1 } 314 | TokLowerName qual name -> 315 | { line, column: column + qualLength qual + String.length name } 316 | TokUpperName qual name -> 317 | { line, column: column + qualLength qual + String.length name } 318 | TokOperator qual sym -> 319 | { line, column: column + qualLength qual + String.length sym } 320 | TokSymbolName qual sym -> 321 | { line, column: column + qualLength qual + String.length sym + 2 } 322 | TokSymbolArrow Unicode -> 323 | { line, column: column + 3 } 324 | TokSymbolArrow ASCII -> 325 | { line, column: column + 4 } 326 | TokHole hole -> 327 | { line, column: column + String.length hole + 1 } 328 | TokChar raw _ -> 329 | { line, column: column + String.length raw + 2 } 330 | TokInt raw _ -> 331 | { line, column: column + String.length raw } 332 | TokNumber raw _ -> 333 | { line, column: column + String.length raw } 334 | TokString raw _ -> 335 | bumpText pos 1 raw 336 | TokRawString raw -> 337 | bumpText pos 3 raw 338 | TokLayoutStart _ -> 339 | pos 340 | TokLayoutSep _ -> 341 | pos 342 | TokLayoutEnd _ -> 343 | pos 344 | 345 | bumpText :: SourcePos -> Int -> String -> SourcePos 346 | bumpText { line, column } colOffset str = go 0 0 347 | where 348 | go n ix = case SCU.indexOf' (Pattern "\n") ix str of 349 | Just ix' -> 350 | go (n + 1) (ix' + 1) 351 | Nothing 352 | | n == 0 -> 353 | { line, column: column + String.length str + (colOffset * 2) } 354 | | otherwise -> 355 | { line: line + n 356 | , column: String.length (SCU.drop ix str) + colOffset 357 | } 358 | 359 | bumpComment :: forall a. SourcePos -> Comment a -> SourcePos 360 | bumpComment pos@{ line, column } = case _ of 361 | Comment str -> 362 | bumpText pos 0 str 363 | Space n -> 364 | { line, column: column + n } 365 | Line _ n -> 366 | { line: line + n, column: 0 } 367 | 368 | qualLength :: Maybe ModuleName -> Int 369 | qualLength = maybe 0 (add 1 <<< String.length <<< unwrap) 370 | 371 | leadingModuleComments :: Lex LexError (Array (Comment LineFeed)) 372 | leadingModuleComments = append <$> (leadingShebangs <|> pure []) <*> leadingComments 373 | 374 | leadingShebangs :: Lex LexError (Array (Comment LineFeed)) 375 | leadingShebangs = ado 376 | head <- shebangComment 377 | tail <- many (try (Tuple <$> oneLineComment <*> shebangComment)) 378 | in Array.cons (Comment head) (foldMap (\(Tuple a b) -> [ a, Comment b ]) tail) 379 | 380 | leadingComments :: Lex LexError (Array (Comment LineFeed)) 381 | leadingComments = many do 382 | Comment <$> comment 383 | <|> Space <$> spaceComment 384 | <|> lineComment 385 | 386 | trailingComments :: Lex LexError (Array (Comment Void)) 387 | trailingComments = many do 388 | Comment <$> comment 389 | <|> Space <$> spaceComment 390 | 391 | comment :: Lex LexError String 392 | comment = 393 | regex (LexExpected "block comment") """\{-(-(?!\})|[^-]+)*(-\}|$)""" 394 | <|> regex (LexExpected "line comment") """--[^\r\n]*""" 395 | 396 | shebangComment :: Lex LexError String 397 | shebangComment = regex (LexExpected "shebang") """#![^\r\n]*""" 398 | 399 | spaceComment :: Lex LexError Int 400 | spaceComment = SCU.length <$> regex (LexExpected "spaces") " +" 401 | 402 | lineComment :: Lex LexError (Comment LineFeed) 403 | lineComment = 404 | (Line LF <<< String.length) <$> regex (LexExpected "newline") "\n+" 405 | <|> (Line CRLF <<< (_ / 2) <<< String.length) <$> regex (LexExpected "newline") "(?:\r\n)+" 406 | 407 | oneLineComment :: Lex LexError (Comment LineFeed) 408 | oneLineComment = do 409 | line <- lineComment 410 | case line of 411 | Line _ 1 -> pure line 412 | _ -> fail $ LexExpected "one newline" "multiple newlines" 413 | 414 | token :: Lex LexError Token 415 | token = 416 | parseHole 417 | <|> parseModuleName 418 | <|> parseCharLiteral 419 | <|> parseStringLiteral 420 | <|> parseNumericLiteral 421 | <|> tokenLeftParen 422 | <|> tokenRightParen 423 | <|> tokenLeftBrace 424 | <|> tokenRightBrace 425 | <|> tokenLeftSquare 426 | <|> tokenRightSquare 427 | <|> tokenTick 428 | <|> tokenComma 429 | where 430 | parseModuleName = ado 431 | prefix <- parseModuleNamePrefix 432 | name <- parseName 433 | in name (toModuleName prefix) 434 | 435 | parseName :: Lex _ (Maybe ModuleName -> Token) 436 | parseName = 437 | parseLower 438 | <|> parseUpper 439 | <|> parseOperator 440 | <|> parseSymbol 441 | 442 | parseLower = ado 443 | ident <- parseIdent 444 | in 445 | case _ of 446 | Nothing -> 447 | case ident of 448 | "forall" -> 449 | TokForall ASCII 450 | "_" -> 451 | TokUnderscore 452 | _ -> 453 | TokLowerName Nothing ident 454 | moduleName -> 455 | TokLowerName moduleName ident 456 | 457 | parseUpper :: Lex _ (Maybe ModuleName -> Token) 458 | parseUpper = 459 | flip TokUpperName <$> parseProper 460 | 461 | parseOperator :: Lex _ (Maybe ModuleName -> Token) 462 | parseOperator = ado 463 | symbol <- parseSymbolIdent 464 | in 465 | case _ of 466 | Nothing -> 467 | case symbol of 468 | "<-" -> 469 | TokLeftArrow ASCII 470 | "←" -> 471 | TokLeftArrow Unicode 472 | "->" -> 473 | TokRightArrow ASCII 474 | "→" -> 475 | TokRightArrow Unicode 476 | "=>" -> 477 | TokRightFatArrow ASCII 478 | "⇒" -> 479 | TokRightFatArrow Unicode 480 | "::" -> 481 | TokDoubleColon ASCII 482 | "∷" -> 483 | TokDoubleColon Unicode 484 | "∀" -> 485 | TokForall Unicode 486 | "=" -> 487 | TokEquals 488 | "." -> 489 | TokDot 490 | "\\" -> 491 | TokBackslash 492 | "|" -> 493 | TokPipe 494 | "@" -> 495 | TokAt 496 | "`" -> 497 | TokTick 498 | _ -> 499 | TokOperator Nothing symbol 500 | moduleName -> 501 | TokOperator moduleName symbol 502 | 503 | parseSymbol :: Lex _ (Maybe ModuleName -> Token) 504 | parseSymbol = ado 505 | symbol <- try (tokenLeftParen *> parseSymbolIdent <* tokenRightParen) 506 | in 507 | case _ of 508 | Nothing -> 509 | case symbol of 510 | "->" -> 511 | TokSymbolArrow ASCII 512 | "→" -> 513 | TokSymbolArrow Unicode 514 | _ -> 515 | TokSymbolName Nothing symbol 516 | moduleName -> 517 | TokSymbolName moduleName symbol 518 | 519 | parseHole = ado 520 | ident <- try $ charQuestionMark *> (parseIdent <|> parseProper) 521 | in TokHole ident 522 | 523 | parseModuleNamePrefix = 524 | regex (LexExpected "module name") "(?:(?:\\p{Lu}[\\p{L}0-9_']*)\\.)*" 525 | 526 | parseProper = 527 | regex (LexExpected "proper name") "\\p{Lu}[\\p{L}0-9_']*" 528 | 529 | parseIdent = 530 | regex (LexExpected "ident") "[\\p{Ll}_][\\p{L}0-9_']*" 531 | 532 | parseSymbolIdent = 533 | regex (LexExpected "symbol") """(?:[:!#$%&*+./<=>?@\\^|~-]|(?!\p{P})\p{S})+""" 534 | 535 | parseCharLiteral = ado 536 | res <- charSingleQuote *> parseChar <* charSingleQuote 537 | in TokChar res.raw res.char 538 | 539 | parseChar = do 540 | ch <- charAny 541 | case ch of 542 | '\\' -> 543 | parseEscape 544 | '\'' -> 545 | fail $ LexExpected "character" "empty character literal" 546 | _ -> 547 | pure { raw: SCU.singleton ch, char: ch } 548 | 549 | parseEscape 550 | :: forall a 551 | . IsChar a 552 | => Lex (Unit -> ParseError) { raw :: String, char :: a } 553 | parseEscape = do 554 | ch <- charAny 555 | case ch of 556 | 't' -> 557 | pure { raw: "\\t", char: fromChar '\t' } 558 | 'r' -> 559 | pure { raw: "\\r", char: fromChar '\r' } 560 | 'n' -> 561 | pure { raw: "\\n", char: fromChar '\n' } 562 | '"' -> 563 | pure { raw: "\\\"", char: fromChar '"' } 564 | '\'' -> 565 | pure { raw: "\\'", char: fromChar '\'' } 566 | '\\' -> 567 | pure { raw: "\\\\", char: fromChar '\\' } 568 | 'x' -> 569 | parseHexEscape 570 | _ -> 571 | fail $ LexInvalidCharEscape $ SCU.singleton ch 572 | 573 | parseHexEscape 574 | :: forall a 575 | . IsChar a 576 | => Lex (Unit -> ParseError) { raw :: String, char :: a } 577 | parseHexEscape = do 578 | esc <- hexEscapeRegex 579 | case fromCharCode =<< Int.fromStringAs hexadecimal esc of 580 | Just ch -> 581 | pure { raw: "\\x" <> esc, char: ch } 582 | Nothing -> 583 | fail $ LexCharEscapeOutOfRange esc 584 | 585 | hexEscapeRegex = 586 | regex (LexExpected "hex") "[a-fA-F0-9]{1,6}" 587 | 588 | parseStringLiteral = 589 | parseRawString <|> parseString 590 | 591 | parseRawString = ado 592 | str <- rawStringCharsRegex 593 | in TokRawString $ SCU.dropRight 3 $ SCU.drop 3 str 594 | 595 | parseString = ado 596 | parts <- charQuote *> many parseStringPart <* charQuote 597 | let { raw, string } = fold parts 598 | in TokString raw string 599 | 600 | parseStringPart = 601 | parseStringChars 602 | <|> parseStringSpaceEscape 603 | <|> parseStringEscape 604 | 605 | parseStringEscape = ado 606 | res <- charBackslash *> parseEscape 607 | in { raw: res.raw, string: SCP.singleton res.char } 608 | 609 | parseStringChars = ado 610 | raw <- stringCharsRegex 611 | in { raw, string: raw } 612 | 613 | parseStringSpaceEscape = ado 614 | raw <- stringSpaceEscapeRegex 615 | in { raw, string: "" } 616 | 617 | stringSpaceEscapeRegex = 618 | regex (LexExpected "whitespace escape") """\\[ \r\n]+\\""" 619 | 620 | stringCharsRegex = 621 | regex (LexExpected "string characters") """[^"\\]+""" 622 | 623 | rawStringCharsRegex = 624 | regex (LexExpected "raw string characters") "\"\"\"\"{0,2}([^\"]+\"{1,2})*[^\"]*\"\"\"" 625 | 626 | parseNumericLiteral = 627 | parseHexInt <|> parseNumber 628 | 629 | parseHexInt = do 630 | raw <- hexIntPrefix *> hexIntRegex 631 | case Int.fromStringAs hexadecimal raw of 632 | Just int -> 633 | pure $ TokInt ("0x" <> raw) (SmallInt int) 634 | Nothing -> 635 | pure $ TokInt ("0x" <> raw) (BigHex raw) 636 | 637 | parseNumber = do 638 | intPart <- intPartRegex 639 | fractionPart <- parseNumberFractionPart 640 | exponentPart <- parseNumberExponentPart 641 | if isNothing fractionPart && isNothing exponentPart then do 642 | let intVal = stripUnderscores intPart 643 | case Int.fromString intVal of 644 | Just int -> 645 | pure $ TokInt intPart (SmallInt int) 646 | Nothing -> 647 | pure $ TokInt intPart (BigInt intVal) 648 | else do 649 | let 650 | raw = 651 | intPart 652 | <> foldMap (\fr -> "." <> fr) fractionPart 653 | <> foldMap (\ex -> "e" <> fold ex.sign <> ex.exponent) exponentPart 654 | case Number.fromString (stripUnderscores raw) of 655 | Just number -> 656 | pure $ TokNumber raw number 657 | Nothing -> 658 | fail $ LexNumberOutOfRange raw 659 | 660 | parseNumberFractionPart = 661 | optional (try (charDot *> fractionPartRegex)) 662 | 663 | parseNumberExponentPart = 664 | optional (charExponent *> parseExponentPart) 665 | 666 | parseExponentPart = ado 667 | sign <- optional parseExponentSign 668 | exponent <- intPartRegex 669 | in { sign, exponent } 670 | 671 | parseExponentSign = 672 | string (LexExpected "negative") "-" 673 | <|> string (LexExpected "positive") "+" 674 | 675 | intPartRegex = 676 | regex (LexExpected "int part") """(0|[1-9][0-9_]*)""" 677 | 678 | fractionPartRegex = 679 | regex (LexExpected "fraction part") """[0-9_]+""" 680 | 681 | hexIntRegex = 682 | regex (LexExpected "hex int") """[a-fA-F0-9]+""" 683 | 684 | hexIntPrefix = 685 | string (LexExpected "hex int prefix") "0x" 686 | 687 | stripUnderscores = 688 | String.replaceAll (Pattern "_") (Replacement "") 689 | 690 | charDot = 691 | char (LexExpected "dot") '.' 692 | 693 | tokenLeftParen = 694 | char' (LexExpected "left paren") TokLeftParen '(' 695 | 696 | tokenRightParen = 697 | char' (LexExpected "right paren") TokRightParen ')' 698 | 699 | tokenLeftBrace = 700 | char' (LexExpected "left brace") TokLeftBrace '{' 701 | 702 | tokenRightBrace = 703 | char' (LexExpected "right brace") TokRightBrace '}' 704 | 705 | tokenLeftSquare = 706 | char' (LexExpected "left square") TokLeftSquare '[' 707 | 708 | tokenRightSquare = 709 | char' (LexExpected "right square") TokRightSquare ']' 710 | 711 | tokenTick = 712 | char' (LexExpected "backtick") TokTick '`' 713 | 714 | tokenComma = 715 | char' (LexExpected "comma") TokComma ',' 716 | 717 | charQuestionMark = 718 | char (LexExpected "question mark") '?' 719 | 720 | charSingleQuote = 721 | char (LexExpected "single quote") '\'' 722 | 723 | charQuote = 724 | char (LexExpected "quote") '"' 725 | 726 | charBackslash = 727 | char (LexExpected "backslash") '\\' 728 | 729 | charExponent = 730 | char (LexExpected "exponent") 'e' 731 | 732 | charAny = 733 | satisfy (LexExpected "char") (const true) 734 | 735 | toModuleName :: String -> Maybe ModuleName 736 | toModuleName = case _ of 737 | "" -> Nothing 738 | mn -> Just $ ModuleName $ SCU.dropRight 1 mn 739 | -------------------------------------------------------------------------------- /src/PureScript/CST/ModuleGraph.purs: -------------------------------------------------------------------------------- 1 | module PureScript.CST.ModuleGraph 2 | ( moduleGraph 3 | , sortModules 4 | , ModuleSort(..) 5 | ) where 6 | 7 | import Prelude 8 | 9 | import Data.Array as Array 10 | import Data.Either (Either(..)) 11 | import Data.Foldable (all, foldl) 12 | import Data.List (List(..)) 13 | import Data.List as List 14 | import Data.Map (Map) 15 | import Data.Map as Map 16 | import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe) 17 | import Data.Set (Set) 18 | import Data.Set as Set 19 | import Data.Tuple (Tuple(..)) 20 | import PureScript.CST.Types (ImportDecl(..), ModuleHeader(..), ModuleName, Name(..)) 21 | 22 | type Graph a = Map a (Set a) 23 | 24 | moduleGraph :: forall e a. (a -> ModuleHeader e) -> Array a -> Graph ModuleName 25 | moduleGraph k = Map.fromFoldable <<< map (go <<< k) 26 | where 27 | go (ModuleHeader { name: Name { name }, imports }) = 28 | Tuple name (Set.fromFoldable (map getImportName imports)) 29 | 30 | getImportName (ImportDecl { "module": Name { name } }) = name 31 | 32 | data ModuleSort a 33 | = Sorted (Array a) 34 | | CycleDetected (Array a) 35 | 36 | sortModules :: forall e a. (a -> ModuleHeader e) -> Array a -> ModuleSort a 37 | sortModules k moduleHeaders = do 38 | let 39 | getModuleName :: ModuleHeader e -> ModuleName 40 | getModuleName (ModuleHeader { name: Name { name } }) = name 41 | 42 | knownModuleHeaders :: Map ModuleName a 43 | knownModuleHeaders = 44 | moduleHeaders 45 | # map (\a -> Tuple (getModuleName (k a)) a) 46 | # Map.fromFoldable 47 | 48 | graph = moduleGraph k moduleHeaders 49 | lookupModuleHeaders = Array.mapMaybe (flip Map.lookup knownModuleHeaders) <<< List.toUnfoldable 50 | 51 | case topoSort graph of 52 | Left cycle -> CycleDetected (lookupModuleHeaders cycle) 53 | Right sorted -> Sorted (lookupModuleHeaders sorted) 54 | 55 | type TopoSortArgs a = 56 | { roots :: Set a 57 | , sorted :: List a 58 | , usages :: Map a Int 59 | } 60 | 61 | topoSort :: forall a. Ord a => Graph a -> Either (List a) (List a) 62 | topoSort graph = do 63 | _.sorted <$> go { roots: startingModules, sorted: Nil, usages: importCounts } 64 | where 65 | go :: TopoSortArgs a -> Either (List a) (TopoSortArgs a) 66 | go { roots, sorted, usages } = case Set.findMin roots of 67 | Nothing -> 68 | if all (eq 0) usages then 69 | Right { roots, sorted, usages } 70 | else do 71 | let 72 | nonLeaf = 73 | usages 74 | # Map.filterWithKey (\a count -> count > 0 && not (maybe true Set.isEmpty (Map.lookup a graph))) 75 | # Map.keys 76 | 77 | detectCycles = foldl (\b a -> if isJust b then b else depthFirst { path: Nil, visited: Set.empty, curr: a }) Nothing nonLeaf 78 | 79 | case detectCycles of 80 | Just cycle -> Left cycle 81 | Nothing -> Left Nil 82 | 83 | Just curr -> do 84 | let 85 | reachable = fromMaybe Set.empty (Map.lookup curr graph) 86 | usages' = foldl decrementImport usages reachable 87 | go 88 | { roots: foldl (appendRoots usages') (Set.delete curr roots) reachable 89 | , sorted: Cons curr sorted 90 | , usages: usages' 91 | } 92 | 93 | appendRoots :: Map a Int -> Set a -> a -> Set a 94 | appendRoots usages roots curr = maybe roots (flip Set.insert roots) do 95 | count <- Map.lookup curr usages 96 | isRoot (Tuple curr count) 97 | 98 | decrementImport :: Map a Int -> a -> Map a Int 99 | decrementImport usages k = Map.insertWith add k (-1) usages 100 | 101 | startingModules :: Set a 102 | startingModules = Map.keys $ Map.filterWithKey (\k v -> isJust (isRoot (Tuple k v))) importCounts 103 | 104 | importCounts :: Map a Int 105 | importCounts = Map.fromFoldableWith add do 106 | Tuple a bs <- Map.toUnfoldable graph 107 | [ Tuple a 0 ] <> map (flip Tuple 1) (Set.toUnfoldable bs) 108 | 109 | isRoot :: Tuple a Int -> Maybe a 110 | isRoot (Tuple a count) = if count == 0 then Just a else Nothing 111 | 112 | depthFirst :: { path :: List a, visited :: Set a, curr :: a } -> Maybe (List a) 113 | depthFirst { path, visited, curr } = 114 | if Set.member curr visited then 115 | Just (Cons curr path) 116 | else if maybe true Set.isEmpty (Map.lookup curr graph) then 117 | Nothing 118 | else do 119 | reachable <- Map.lookup curr graph 120 | foldl (\b a -> if isJust b then b else depthFirst { path: Cons curr path, visited: Set.insert curr visited, curr: a }) Nothing reachable 121 | -------------------------------------------------------------------------------- /src/PureScript/CST/Parser/Monad.purs: -------------------------------------------------------------------------------- 1 | module PureScript.CST.Parser.Monad 2 | ( Parser(..) 3 | , ParserState 4 | , ParserResult(..) 5 | , PositionedError 6 | , initialParserState 7 | , fromParserResult 8 | , runParser 9 | , runParser' 10 | , take 11 | , fail 12 | , try 13 | , lookAhead 14 | , many 15 | , optional 16 | , eof 17 | , recover 18 | ) where 19 | 20 | import Prelude 21 | 22 | import Control.Alt (class Alt, (<|>)) 23 | import Control.Lazy (class Lazy) 24 | import Data.Array as Array 25 | import Data.Either (Either(..)) 26 | import Data.Function.Uncurried (Fn2, Fn4, mkFn2, mkFn4, runFn2, runFn4) 27 | import Data.Lazy as Lazy 28 | import Data.List as List 29 | import Data.Maybe (Maybe(..)) 30 | import Data.Tuple (Tuple(..)) 31 | import PureScript.CST.Errors (ParseError(..)) 32 | import PureScript.CST.TokenStream (TokenStep(..), TokenStream) 33 | import PureScript.CST.TokenStream as TokenStream 34 | import PureScript.CST.Types (Comment, LineFeed, SourcePos, SourceToken) 35 | 36 | type PositionedError = 37 | { position :: SourcePos 38 | , error :: ParseError 39 | } 40 | 41 | type ParserState = 42 | { consumed :: Boolean 43 | , errors :: Array PositionedError 44 | , stream :: TokenStream 45 | } 46 | 47 | initialParserState :: TokenStream -> ParserState 48 | initialParserState stream = 49 | { consumed: false 50 | , errors: [] 51 | , stream 52 | } 53 | 54 | appendConsumed :: ParserState -> ParserState -> ParserState 55 | appendConsumed { consumed } state = case consumed, state.consumed of 56 | true, false -> state { consumed = true } 57 | _, _ -> state 58 | 59 | newtype Parser a = Parser 60 | ( forall r 61 | . Fn4 62 | ParserState 63 | ((Unit -> r) -> r) 64 | (Fn2 ParserState PositionedError r) 65 | (Fn2 ParserState a r) 66 | r 67 | ) 68 | 69 | instance Functor Parser where 70 | map f (Parser p) = Parser 71 | ( mkFn4 \state1 more resume done -> 72 | runFn4 p state1 more resume 73 | ( mkFn2 \state2 a -> 74 | runFn2 done state2 (f a) 75 | ) 76 | ) 77 | 78 | instance Apply Parser where 79 | apply (Parser p1) (Parser p2) = Parser 80 | ( mkFn4 \state1 more resume done -> 81 | runFn4 p1 state1 more resume 82 | ( mkFn2 \state2 f -> 83 | more \_ -> 84 | runFn4 p2 state2 more resume 85 | ( mkFn2 \state3 a -> 86 | runFn2 done (state2 `appendConsumed` state3) (f a) 87 | ) 88 | ) 89 | ) 90 | 91 | instance Applicative Parser where 92 | pure a = Parser 93 | ( mkFn4 \state1 _ _ done -> 94 | runFn2 done state1 a 95 | ) 96 | 97 | instance Bind Parser where 98 | bind (Parser p1) k = Parser 99 | ( mkFn4 \state1 more resume done -> 100 | runFn4 p1 state1 more resume 101 | ( mkFn2 \state2 a -> 102 | more \_ -> do 103 | let (Parser p2) = k a 104 | runFn4 p2 (state1 `appendConsumed` state2) more resume done 105 | ) 106 | ) 107 | 108 | instance Monad Parser 109 | 110 | instance Alt Parser where 111 | alt (Parser k1) (Parser k2) = Parser 112 | ( mkFn4 \state1 more resume done -> do 113 | let 114 | state2 = 115 | if state1.consumed then state1 { consumed = false } 116 | else state1 117 | runFn4 k1 state2 more 118 | ( mkFn2 \state3 error -> 119 | if state3.consumed then 120 | runFn2 resume state3 error 121 | else 122 | runFn4 k2 state1 more resume done 123 | ) 124 | done 125 | ) 126 | 127 | instance Lazy (Parser a) where 128 | defer k = Parser 129 | ( mkFn4 \state more resume done -> do 130 | let (Parser k) = Lazy.force parser 131 | runFn4 k state more resume done 132 | ) 133 | where 134 | parser = Lazy.defer k 135 | 136 | fail :: forall a. PositionedError -> Parser a 137 | fail error = Parser (mkFn4 \state _ resume _ -> runFn2 resume state error) 138 | 139 | try :: forall a. Parser a -> Parser a 140 | try (Parser p) = Parser 141 | ( mkFn4 \state1 more resume done -> 142 | runFn4 p state1 more 143 | ( mkFn2 \state2 error -> 144 | runFn2 resume (state2 { consumed = state1.consumed }) error 145 | ) 146 | done 147 | ) 148 | 149 | recover :: forall a. (PositionedError -> TokenStream -> Maybe (Tuple a TokenStream)) -> Parser a -> Parser a 150 | recover k (Parser p) = Parser 151 | ( mkFn4 \state1 more resume done -> do 152 | runFn4 p (state1 { consumed = false }) more 153 | ( mkFn2 \state2 error -> 154 | case k error state1.stream of 155 | Nothing -> 156 | runFn2 resume (state2 { consumed = state1.consumed }) error 157 | Just (Tuple a stream) -> 158 | runFn2 done 159 | { consumed: true 160 | , errors: Array.snoc state2.errors error 161 | , stream 162 | } 163 | a 164 | ) 165 | done 166 | ) 167 | 168 | take :: forall a. (SourceToken -> Either ParseError a) -> Parser a 169 | take k = Parser 170 | ( mkFn4 \state _ resume done -> 171 | case TokenStream.step state.stream of 172 | TokenError position error _ _ -> 173 | runFn2 resume state { error, position } 174 | TokenEOF position _ -> 175 | runFn2 resume state { error: UnexpectedEof, position } 176 | TokenCons tok _ nextStream _ -> 177 | case k tok of 178 | Left error -> 179 | runFn2 resume state { error, position: tok.range.start } 180 | Right a -> 181 | runFn2 done 182 | ( state 183 | { consumed = true 184 | , stream = nextStream 185 | } 186 | ) 187 | a 188 | ) 189 | 190 | eof :: Parser (Tuple SourcePos (Array (Comment LineFeed))) 191 | eof = Parser 192 | ( mkFn4 \state _ resume done -> 193 | case TokenStream.step state.stream of 194 | TokenError position error _ _ -> 195 | runFn2 resume state { error, position } 196 | TokenEOF position comments -> 197 | runFn2 done (state { consumed = true }) (Tuple position comments) 198 | TokenCons tok _ _ _ -> 199 | runFn2 resume state 200 | { error: ExpectedEof tok.value 201 | , position: tok.range.start 202 | } 203 | ) 204 | 205 | lookAhead :: forall a. Parser a -> Parser a 206 | lookAhead (Parser p) = Parser 207 | ( mkFn4 \state1 more resume done -> 208 | runFn4 p state1 more 209 | (mkFn2 \_ error -> runFn2 resume state1 error) 210 | (mkFn2 \_ value -> runFn2 done state1 value) 211 | ) 212 | 213 | many :: forall a. Parser a -> Parser (Array a) 214 | many (Parser p) = Parser 215 | ( mkFn4 \state1 more resume done -> do 216 | let 217 | go = mkFn2 \acc state2 -> do 218 | let 219 | state2' = 220 | if state2.consumed then state2 { consumed = false } 221 | else state2 222 | runFn4 p state2' more 223 | ( mkFn2 \state3 error -> 224 | if state3.consumed then 225 | runFn2 resume state3 error 226 | else 227 | runFn2 done state2 (Array.reverse (List.toUnfoldable acc)) 228 | ) 229 | ( mkFn2 \state3 value -> 230 | runFn2 go (List.Cons value acc) (state2 `appendConsumed` state3) 231 | ) 232 | runFn2 go List.Nil state1 233 | ) 234 | 235 | optional :: forall a. Parser a -> Parser (Maybe a) 236 | optional p = Just <$> p <|> pure Nothing 237 | 238 | data Trampoline a = More (Unit -> Trampoline a) | Done a 239 | 240 | runParser' :: forall a. ParserState -> Parser a -> ParserResult a 241 | runParser' state1 (Parser p) = 242 | run $ runFn4 p state1 More 243 | (mkFn2 \state2 error -> Done (ParseFail error state2)) 244 | (mkFn2 \state2 value -> Done (ParseSucc value state2)) 245 | where 246 | run = case _ of 247 | More k -> run (k unit) 248 | Done a -> a 249 | 250 | runParser :: forall a. TokenStream -> Parser a -> Either PositionedError (Tuple a (Array PositionedError)) 251 | runParser stream = fromParserResult <<< runParser' (initialParserState stream) 252 | 253 | data ParserResult a 254 | = ParseFail PositionedError ParserState 255 | | ParseSucc a ParserState 256 | 257 | fromParserResult :: forall a. ParserResult a -> Either PositionedError (Tuple a (Array PositionedError)) 258 | fromParserResult = case _ of 259 | ParseFail error _ -> 260 | Left error 261 | ParseSucc res { errors } -> 262 | Right (Tuple res errors) 263 | -------------------------------------------------------------------------------- /src/PureScript/CST/Print.purs: -------------------------------------------------------------------------------- 1 | module PureScript.CST.Print 2 | ( printToken 3 | , printSourceToken 4 | , TokenOption(..) 5 | , printTokenWithOption 6 | , printSourceTokenWithOption 7 | , printComment 8 | , printLineFeed 9 | , printQualified 10 | ) where 11 | 12 | import Prelude 13 | 14 | import Data.Foldable (foldMap) 15 | import Data.Maybe (Maybe(..)) 16 | import Data.Monoid (power) 17 | import Data.Newtype (unwrap) 18 | import PureScript.CST.Types (Comment(..), LineFeed(..), ModuleName, SourceStyle(..), Token(..), SourceToken) 19 | 20 | data TokenOption 21 | = ShowLayout 22 | | HideLayout 23 | 24 | printSourceToken :: SourceToken -> String 25 | printSourceToken = printSourceTokenWithOption HideLayout 26 | 27 | printSourceTokenWithOption :: TokenOption -> SourceToken -> String 28 | printSourceTokenWithOption option tok = 29 | foldMap (printComment printLineFeed) tok.leadingComments 30 | <> printTokenWithOption option tok.value 31 | <> foldMap (printComment absurd) tok.trailingComments 32 | 33 | printToken :: Token -> String 34 | printToken = printTokenWithOption HideLayout 35 | 36 | printTokenWithOption :: TokenOption -> Token -> String 37 | printTokenWithOption option = case _ of 38 | TokLeftParen -> 39 | "(" 40 | TokRightParen -> 41 | ")" 42 | TokLeftBrace -> 43 | "{" 44 | TokRightBrace -> 45 | "}" 46 | TokLeftSquare -> 47 | "[" 48 | TokRightSquare -> 49 | "]" 50 | TokLeftArrow style -> 51 | case style of 52 | ASCII -> "<-" 53 | Unicode -> "←" 54 | TokRightArrow style -> 55 | case style of 56 | ASCII -> "->" 57 | Unicode -> "→" 58 | TokRightFatArrow style -> 59 | case style of 60 | ASCII -> "=>" 61 | Unicode -> "⇒" 62 | TokDoubleColon style -> 63 | case style of 64 | ASCII -> "::" 65 | Unicode -> "∷" 66 | TokForall style -> 67 | case style of 68 | ASCII -> "forall" 69 | Unicode -> "∀" 70 | TokEquals -> 71 | "=" 72 | TokPipe -> 73 | "|" 74 | TokTick -> 75 | "`" 76 | TokDot -> 77 | "." 78 | TokComma -> 79 | "," 80 | TokUnderscore -> 81 | "_" 82 | TokBackslash -> 83 | "\\" 84 | TokAt -> 85 | "@" 86 | TokLowerName moduleName name -> 87 | printQualified moduleName name 88 | TokUpperName moduleName name -> 89 | printQualified moduleName name 90 | TokOperator moduleName name -> 91 | printQualified moduleName name 92 | TokSymbolName moduleName name -> 93 | printQualified moduleName ("(" <> name <> ")") 94 | TokSymbolArrow style -> 95 | case style of 96 | ASCII -> "(->)" 97 | Unicode -> "(→)" 98 | TokHole name -> 99 | "?" <> name 100 | TokChar raw _ -> 101 | "'" <> raw <> "'" 102 | TokString raw _ -> 103 | "\"" <> raw <> "\"" 104 | TokRawString raw -> 105 | "\"\"\"" <> raw <> "\"\"\"" 106 | TokInt raw _ -> 107 | raw 108 | TokNumber raw _ -> 109 | raw 110 | TokLayoutStart _ -> 111 | case option of 112 | ShowLayout -> "{" 113 | HideLayout -> "" 114 | TokLayoutSep _ -> 115 | case option of 116 | ShowLayout -> ";" 117 | HideLayout -> "" 118 | TokLayoutEnd _ -> 119 | case option of 120 | ShowLayout -> "}" 121 | HideLayout -> "" 122 | 123 | printQualified :: Maybe ModuleName -> String -> String 124 | printQualified moduleName name = case moduleName of 125 | Nothing -> name 126 | Just mn -> unwrap mn <> "." <> name 127 | 128 | printComment :: forall l. (l -> String) -> Comment l -> String 129 | printComment k = case _ of 130 | Comment str -> str 131 | Space n -> power " " n 132 | Line l n -> power (k l) n 133 | 134 | printLineFeed :: LineFeed -> String 135 | printLineFeed = case _ of 136 | LF -> "\n" 137 | CRLF -> "\r\n" 138 | -------------------------------------------------------------------------------- /src/PureScript/CST/Range.purs: -------------------------------------------------------------------------------- 1 | module PureScript.CST.Range 2 | ( class RangeOf 3 | , rangeOf 4 | , class TokensOf 5 | , tokensOf 6 | ) where 7 | 8 | import Prelude 9 | import Prim hiding (Row, Type) 10 | 11 | import Control.Lazy (defer) 12 | import Data.Array as Array 13 | import Data.Array.NonEmpty (NonEmptyArray) 14 | import Data.Array.NonEmpty as NonEmptyArray 15 | import Data.Foldable (foldMap) 16 | import Data.Maybe (Maybe(..), maybe) 17 | import Data.Tuple (Tuple(..), fst, snd) 18 | import PureScript.CST.Errors (RecoveredError(..)) 19 | import PureScript.CST.Range.TokenList (TokenList, cons, singleton) 20 | import PureScript.CST.Range.TokenList as TokenList 21 | import PureScript.CST.Types (AppSpine(..), Binder(..), ClassFundep(..), DataCtor(..), DataMembers(..), Declaration(..), DoStatement(..), Export(..), Expr(..), FixityOp(..), Foreign(..), Guarded(..), GuardedExpr(..), Import(..), ImportDecl(..), Instance(..), InstanceBinding(..), Labeled(..), LetBinding(..), Module(..), ModuleBody(..), ModuleHeader(..), Name(..), OneOrDelimited(..), PatternGuard(..), Prefixed(..), QualifiedName(..), RecordLabeled(..), RecordUpdate(..), Row(..), Separated(..), SourceRange, Type(..), TypeVarBinding(..), Where(..), Wrapped(..)) 22 | 23 | class RangeOf a where 24 | rangeOf :: a -> SourceRange 25 | 26 | class TokensOf a where 27 | tokensOf :: a -> TokenList 28 | 29 | instance tokensOfTuple :: (TokensOf a, TokensOf b) => TokensOf (Tuple a b) where 30 | tokensOf (Tuple a b) = tokensOf a <> tokensOf b 31 | 32 | instance tokensOfMaybe :: TokensOf a => TokensOf (Maybe a) where 33 | tokensOf = foldMap tokensOf 34 | 35 | instance tokensOfArray :: TokensOf a => TokensOf (Array a) where 36 | tokensOf = foldMap (\a -> defer \_ -> tokensOf a) 37 | 38 | instance tokensOfNonEmptyArray :: TokensOf a => TokensOf (NonEmptyArray a) where 39 | tokensOf = foldMap (\a -> defer \_ -> tokensOf a) 40 | 41 | instance rangeOfVoid :: RangeOf Void where 42 | rangeOf = absurd 43 | 44 | instance tokensOfVoid :: TokensOf Void where 45 | tokensOf = absurd 46 | 47 | instance rangeOfRecoveredError :: RangeOf RecoveredError where 48 | rangeOf (RecoveredError { position, tokens }) = 49 | case NonEmptyArray.fromArray tokens of 50 | Just toks -> 51 | { start: (NonEmptyArray.head toks).range.start 52 | , end: (NonEmptyArray.last toks).range.end 53 | } 54 | Nothing -> 55 | { start: position 56 | , end: position 57 | } 58 | 59 | instance tokensOfRecoveredError :: TokensOf RecoveredError where 60 | tokensOf (RecoveredError { tokens }) = TokenList.fromArray tokens 61 | 62 | instance rangeOfModule :: RangeOf (Module e) where 63 | rangeOf (Module { header: ModuleHeader header, body: ModuleBody body }) = 64 | { start: header.keyword.range.start 65 | , end: body.end 66 | } 67 | 68 | instance tokensOfModule :: TokensOf e => TokensOf (Module e) where 69 | tokensOf (Module { header: ModuleHeader header, body: ModuleBody body }) = 70 | cons header.keyword 71 | $ tokensOf header.name 72 | <> defer (\_ -> foldMap tokensOf header.exports) 73 | <> singleton header.where 74 | <> defer (\_ -> foldMap tokensOf header.imports) 75 | <> defer (\_ -> foldMap tokensOf body.decls) 76 | 77 | instance rangeOfName :: RangeOf (Name a) where 78 | rangeOf (Name { token }) = token.range 79 | 80 | instance tokensOfName :: TokensOf (Name a) where 81 | tokensOf (Name { token }) = singleton token 82 | 83 | instance rangeOfQualifiedName :: RangeOf (QualifiedName a) where 84 | rangeOf (QualifiedName { token }) = token.range 85 | 86 | instance tokensOfQualifiedName :: TokensOf (QualifiedName a) where 87 | tokensOf (QualifiedName { token }) = singleton token 88 | 89 | instance rangeOfWrapped :: RangeOf (Wrapped a) where 90 | rangeOf (Wrapped { open, close }) = 91 | { start: open.range.start 92 | , end: close.range.end 93 | } 94 | 95 | instance tokensOfWrapped :: TokensOf a => TokensOf (Wrapped a) where 96 | tokensOf (Wrapped { open, value, close }) = 97 | TokenList.wrap open (defer \_ -> tokensOf value) close 98 | 99 | instance rangeOfSeparated :: RangeOf a => RangeOf (Separated a) where 100 | rangeOf (Separated { head, tail }) = 101 | case Array.last tail of 102 | Just (Tuple _ last) -> 103 | { start: (rangeOf head).start 104 | , end: (rangeOf last).end 105 | } 106 | Nothing -> 107 | rangeOf head 108 | 109 | instance tokensOfSeparated :: TokensOf a => TokensOf (Separated a) where 110 | tokensOf (Separated { head, tail }) = 111 | tokensOf head 112 | <> defer \_ -> foldMap (\(Tuple a b) -> cons a $ defer (\_ -> tokensOf b)) tail 113 | 114 | instance rangeOfLabeled :: (RangeOf a, RangeOf b) => RangeOf (Labeled a b) where 115 | rangeOf (Labeled { label, value }) = 116 | { start: (rangeOf label).start 117 | , end: (rangeOf value).end 118 | } 119 | 120 | instance tokensOfLabeled :: (TokensOf a, TokensOf b) => TokensOf (Labeled a b) where 121 | tokensOf (Labeled { label, separator, value }) = 122 | tokensOf label <> singleton separator <> tokensOf value 123 | 124 | instance rangeOfPrefixed :: RangeOf a => RangeOf (Prefixed a) where 125 | rangeOf (Prefixed { prefix, value }) = 126 | case prefix of 127 | Just tok -> 128 | { start: tok.range.start 129 | , end: (rangeOf value).end 130 | } 131 | Nothing -> 132 | rangeOf value 133 | 134 | instance tokensOfPrefixed :: TokensOf a => TokensOf (Prefixed a) where 135 | tokensOf (Prefixed { prefix, value }) = 136 | case prefix of 137 | Just tok -> 138 | cons tok $ defer \_ -> tokensOf value 139 | Nothing -> 140 | tokensOf value 141 | 142 | instance rangeOfOneOrDelimited :: RangeOf a => RangeOf (OneOrDelimited a) where 143 | rangeOf = case _ of 144 | One a -> rangeOf a 145 | Many as -> rangeOf as 146 | 147 | instance tokensOfOneOrDelimited :: TokensOf a => TokensOf (OneOrDelimited a) where 148 | tokensOf = case _ of 149 | One a -> tokensOf a 150 | Many as -> tokensOf as 151 | 152 | instance rangeOfType :: RangeOf e => RangeOf (Type e) where 153 | rangeOf = case _ of 154 | TypeVar n -> 155 | rangeOf n 156 | TypeConstructor n -> 157 | rangeOf n 158 | TypeWildcard t -> 159 | t.range 160 | TypeHole n -> 161 | rangeOf n 162 | TypeString t _ -> 163 | t.range 164 | TypeInt neg t _ -> 165 | case neg of 166 | Nothing -> 167 | t.range 168 | Just n -> 169 | { start: n.range.start 170 | , end: t.range.end 171 | } 172 | TypeRow w -> 173 | rangeOf w 174 | TypeRecord w -> 175 | rangeOf w 176 | TypeForall t _ _ ty -> 177 | { start: t.range.start 178 | , end: (rangeOf ty).end 179 | } 180 | TypeKinded ty1 _ ty2 -> 181 | { start: (rangeOf ty1).start 182 | , end: (rangeOf ty2).end 183 | } 184 | TypeApp ty tys -> 185 | { start: (rangeOf ty).start 186 | , end: (rangeOf (NonEmptyArray.last tys)).end 187 | } 188 | TypeOp ty ops -> 189 | { start: (rangeOf ty).start 190 | , end: (rangeOf (snd (NonEmptyArray.last ops))).end 191 | } 192 | TypeOpName n -> 193 | rangeOf n 194 | TypeArrow ty1 _ ty2 -> 195 | { start: (rangeOf ty1).start 196 | , end: (rangeOf ty2).end 197 | } 198 | TypeArrowName t -> 199 | t.range 200 | TypeConstrained ty1 _ ty2 -> 201 | { start: (rangeOf ty1).start 202 | , end: (rangeOf ty2).end 203 | } 204 | TypeParens w -> 205 | rangeOf w 206 | TypeError e -> 207 | rangeOf e 208 | 209 | instance tokensOfType :: TokensOf e => TokensOf (Type e) where 210 | tokensOf = case _ of 211 | TypeVar n -> 212 | tokensOf n 213 | TypeConstructor n -> 214 | tokensOf n 215 | TypeWildcard t -> 216 | singleton t 217 | TypeHole n -> 218 | tokensOf n 219 | TypeString t _ -> 220 | singleton t 221 | TypeInt neg t _ -> 222 | foldMap singleton neg <> singleton t 223 | TypeRow w -> 224 | tokensOf w 225 | TypeRecord w -> 226 | tokensOf w 227 | TypeForall t vars dot ty -> 228 | cons t $ defer \_ -> 229 | tokensOf vars 230 | <> singleton dot 231 | <> tokensOf ty 232 | TypeKinded ty1 t ty2 -> 233 | tokensOf ty1 234 | <> defer \_ -> singleton t <> tokensOf ty2 235 | TypeApp ty tys -> 236 | tokensOf ty 237 | <> defer \_ -> tokensOf tys 238 | TypeOp ty ops -> 239 | tokensOf ty 240 | <> defer \_ -> foldMap (\(Tuple op arg) -> tokensOf op <> tokensOf arg) ops 241 | TypeOpName n -> 242 | tokensOf n 243 | TypeArrow ty1 t ty2 -> 244 | tokensOf ty1 245 | <> defer \_ -> singleton t <> tokensOf ty2 246 | TypeArrowName t -> 247 | singleton t 248 | TypeConstrained ty1 t ty2 -> 249 | tokensOf ty1 250 | <> defer \_ -> singleton t <> tokensOf ty2 251 | TypeParens w -> 252 | tokensOf w 253 | TypeError e -> 254 | tokensOf e 255 | 256 | instance tokensOfRow :: TokensOf e => TokensOf (Row e) where 257 | tokensOf (Row { labels, tail }) = 258 | foldMap tokensOf labels 259 | <> foldMap (\(Tuple t ty) -> cons t $ tokensOf ty) tail 260 | 261 | instance rangeOfTypeVarBinding :: RangeOf a => RangeOf (TypeVarBinding a e) where 262 | rangeOf = case _ of 263 | TypeVarKinded w -> 264 | rangeOf w 265 | TypeVarName n -> 266 | rangeOf n 267 | 268 | instance tokensOfTypeVarBinding :: (TokensOf a, TokensOf e) => TokensOf (TypeVarBinding a e) where 269 | tokensOf = case _ of 270 | TypeVarKinded w -> 271 | tokensOf w 272 | TypeVarName n -> 273 | tokensOf n 274 | 275 | instance rangeOfExport :: RangeOf e => RangeOf (Export e) where 276 | rangeOf = case _ of 277 | ExportValue n -> 278 | rangeOf n 279 | ExportOp n -> 280 | rangeOf n 281 | ExportType n dms -> 282 | case dms of 283 | Nothing -> 284 | rangeOf n 285 | Just dms' -> 286 | { start: (rangeOf n).start 287 | , end: (rangeOf dms').end 288 | } 289 | ExportTypeOp t n -> 290 | { start: t.range.start 291 | , end: (rangeOf n).end 292 | } 293 | ExportClass t n -> 294 | { start: t.range.start 295 | , end: (rangeOf n).end 296 | } 297 | ExportModule t n -> 298 | { start: t.range.start 299 | , end: (rangeOf n).end 300 | } 301 | ExportError e -> 302 | rangeOf e 303 | 304 | instance tokensOfExport :: TokensOf e => TokensOf (Export e) where 305 | tokensOf = case _ of 306 | ExportValue n -> 307 | tokensOf n 308 | ExportOp n -> 309 | tokensOf n 310 | ExportType n dms -> 311 | tokensOf n <> foldMap tokensOf dms 312 | ExportTypeOp t n -> 313 | cons t $ tokensOf n 314 | ExportClass t n -> 315 | cons t $ tokensOf n 316 | ExportModule t n -> 317 | cons t $ tokensOf n 318 | ExportError e -> 319 | tokensOf e 320 | 321 | instance rangeOfDataMembers :: RangeOf DataMembers where 322 | rangeOf = case _ of 323 | DataAll t -> 324 | t.range 325 | DataEnumerated w -> 326 | rangeOf w 327 | 328 | instance tokensOfDataMembers :: TokensOf DataMembers where 329 | tokensOf = case _ of 330 | DataAll t -> 331 | singleton t 332 | DataEnumerated w -> 333 | tokensOf w 334 | 335 | instance rangeOfImportDecl :: RangeOf (ImportDecl e) where 336 | rangeOf (ImportDecl { keyword, "module": mod, names, qualified }) = do 337 | let 338 | { end } = case qualified of 339 | Nothing -> 340 | case names of 341 | Nothing -> 342 | rangeOf mod 343 | Just (Tuple _ imports) -> 344 | rangeOf imports 345 | Just (Tuple _ n) -> 346 | rangeOf n 347 | { start: keyword.range.start 348 | , end 349 | } 350 | 351 | instance tokensOfImportDecl :: TokensOf e => TokensOf (ImportDecl e) where 352 | tokensOf (ImportDecl { keyword, "module": mod, names, qualified }) = 353 | cons keyword $ defer \_ -> 354 | tokensOf mod 355 | <> foldMap (\(Tuple hiding imports) -> foldMap singleton hiding <> defer (\_ -> tokensOf imports)) names 356 | <> foldMap (\(Tuple as mn) -> singleton as <> tokensOf mn) qualified 357 | 358 | instance rangeOfImport :: RangeOf e => RangeOf (Import e) where 359 | rangeOf = case _ of 360 | ImportValue n -> 361 | rangeOf n 362 | ImportOp n -> 363 | rangeOf n 364 | ImportType n dms -> 365 | case dms of 366 | Nothing -> 367 | rangeOf n 368 | Just dms' -> 369 | { start: (rangeOf n).start 370 | , end: (rangeOf dms').end 371 | } 372 | ImportTypeOp t n -> 373 | { start: t.range.start 374 | , end: (rangeOf n).end 375 | } 376 | ImportClass t n -> 377 | { start: t.range.start 378 | , end: (rangeOf n).end 379 | } 380 | ImportError e -> 381 | rangeOf e 382 | 383 | instance tokensOfImport :: TokensOf e => TokensOf (Import e) where 384 | tokensOf = case _ of 385 | ImportValue n -> 386 | tokensOf n 387 | ImportOp n -> 388 | tokensOf n 389 | ImportType n dms -> 390 | tokensOf n <> foldMap tokensOf dms 391 | ImportTypeOp t n -> 392 | cons t $ tokensOf n 393 | ImportClass t n -> 394 | cons t $ tokensOf n 395 | ImportError e -> 396 | tokensOf e 397 | 398 | instance rangeOfDataCtor :: RangeOf e => RangeOf (DataCtor e) where 399 | rangeOf (DataCtor { name, fields }) = do 400 | let 401 | { end } = case Array.last fields of 402 | Nothing -> 403 | rangeOf name 404 | Just ty -> 405 | rangeOf ty 406 | { start: (rangeOf name).start 407 | , end 408 | } 409 | 410 | instance tokensOfDataCtor :: TokensOf e => TokensOf (DataCtor e) where 411 | tokensOf (DataCtor { name, fields }) = 412 | tokensOf name <> tokensOf fields 413 | 414 | instance rangeOfDecl :: RangeOf e => RangeOf (Declaration e) where 415 | rangeOf = case _ of 416 | DeclData { keyword, name, vars } ctors -> do 417 | let 418 | { end } = case ctors of 419 | Nothing -> 420 | case Array.last vars of 421 | Nothing -> 422 | rangeOf name 423 | Just var -> 424 | rangeOf var 425 | Just (Tuple _ (Separated { head, tail })) -> 426 | rangeOf $ maybe head snd $ Array.last tail 427 | { start: keyword.range.start 428 | , end 429 | } 430 | DeclType { keyword } _ ty -> 431 | { start: keyword.range.start 432 | , end: (rangeOf ty).end 433 | } 434 | DeclNewtype { keyword } _ _ ty -> 435 | { start: keyword.range.start 436 | , end: (rangeOf ty).end 437 | } 438 | DeclClass { keyword, name, vars, fundeps } members -> do 439 | let 440 | { end } = case members of 441 | Nothing -> 442 | case fundeps of 443 | Nothing -> 444 | case Array.last vars of 445 | Nothing -> 446 | rangeOf name 447 | Just var -> 448 | rangeOf var 449 | Just (Tuple _ fundeps) -> 450 | rangeOf fundeps 451 | Just (Tuple _ ms) -> 452 | rangeOf (NonEmptyArray.last ms) 453 | { start: keyword.range.start 454 | , end 455 | } 456 | DeclInstanceChain insts -> 457 | rangeOf insts 458 | DeclDerive keyword _ { className, types } -> do 459 | let 460 | { end } = case Array.last types of 461 | Nothing -> 462 | rangeOf className 463 | Just ty -> 464 | rangeOf ty 465 | { start: keyword.range.start 466 | , end 467 | } 468 | DeclKindSignature keyword lbl -> 469 | { start: keyword.range.start 470 | , end: (rangeOf lbl).end 471 | } 472 | DeclSignature sig -> 473 | rangeOf sig 474 | DeclValue { name, guarded } -> 475 | { start: (rangeOf name).start 476 | , end: (rangeOf guarded).end 477 | } 478 | DeclFixity { keyword: Tuple keyword _, operator } -> 479 | { start: keyword.range.start 480 | , end: (rangeOf operator).end 481 | } 482 | DeclForeign keyword _ frn -> 483 | { start: keyword.range.start 484 | , end: (rangeOf frn).end 485 | } 486 | DeclRole keyword _ _ roles -> 487 | { start: keyword.range.start 488 | , end: (fst (NonEmptyArray.last roles)).range.end 489 | } 490 | DeclError e -> 491 | rangeOf e 492 | 493 | instance tokensOfDecl :: TokensOf e => TokensOf (Declaration e) where 494 | tokensOf = case _ of 495 | DeclData { keyword, name, vars } ctors -> 496 | cons keyword $ defer \_ -> 497 | tokensOf name 498 | <> tokensOf vars 499 | <> foldMap (\(Tuple t cs) -> cons t $ tokensOf cs) ctors 500 | DeclType { keyword, name, vars } tok ty -> 501 | cons keyword $ defer \_ -> 502 | tokensOf name 503 | <> tokensOf vars 504 | <> singleton tok 505 | <> tokensOf ty 506 | DeclNewtype { keyword, name, vars } tok n ty -> 507 | cons keyword $ defer \_ -> 508 | tokensOf name 509 | <> tokensOf vars 510 | <> singleton tok 511 | <> tokensOf n 512 | <> tokensOf ty 513 | DeclClass { keyword, super, name, vars, fundeps } members -> 514 | cons keyword $ defer \_ -> 515 | foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) super 516 | <> tokensOf name 517 | <> tokensOf vars 518 | <> foldMap (\(Tuple t fs) -> cons t $ tokensOf fs) fundeps 519 | <> foldMap (\(Tuple t ls) -> cons t $ tokensOf ls) members 520 | DeclInstanceChain insts -> 521 | tokensOf insts 522 | DeclDerive keyword tok inst -> 523 | cons keyword $ defer \_ -> 524 | foldMap singleton tok 525 | <> singleton inst.keyword 526 | <> foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) inst.name 527 | <> foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) inst.constraints 528 | <> tokensOf inst.className 529 | <> tokensOf inst.types 530 | DeclKindSignature keyword lbl -> 531 | cons keyword $ defer \_ -> 532 | tokensOf lbl 533 | DeclSignature sig -> 534 | tokensOf sig 535 | DeclValue { name, binders, guarded } -> 536 | tokensOf name <> defer \_ -> 537 | tokensOf binders <> tokensOf guarded 538 | DeclFixity { keyword: Tuple keyword _, prec: Tuple prec _, operator } -> 539 | cons keyword $ defer \_ -> 540 | cons prec $ tokensOf operator 541 | DeclForeign keyword imp frn -> 542 | cons keyword $ defer \_ -> 543 | cons imp $ tokensOf frn 544 | DeclRole keyword rl n roles -> 545 | cons keyword $ defer \_ -> 546 | singleton rl 547 | <> tokensOf n 548 | <> foldMap (\(Tuple t _) -> singleton t) roles 549 | DeclError e -> 550 | tokensOf e 551 | 552 | instance rangeOfClassFundep :: RangeOf ClassFundep where 553 | rangeOf = case _ of 554 | FundepDetermined t ns -> 555 | { start: t.range.start 556 | , end: (rangeOf (NonEmptyArray.last ns)).end 557 | } 558 | FundepDetermines ns1 _ ns2 -> 559 | { start: (rangeOf (NonEmptyArray.head ns1)).start 560 | , end: (rangeOf (NonEmptyArray.last ns2)).end 561 | } 562 | 563 | instance tokensOfClassFundep :: TokensOf ClassFundep where 564 | tokensOf = case _ of 565 | FundepDetermined t ns -> 566 | cons t $ tokensOf ns 567 | FundepDetermines ns1 t ns2 -> 568 | tokensOf ns1 <> singleton t <> tokensOf ns2 569 | 570 | instance rangeOfInstance :: RangeOf e => RangeOf (Instance e) where 571 | rangeOf (Instance { head: { keyword, className, types }, body }) = do 572 | let 573 | { end } = case body of 574 | Nothing -> 575 | case Array.last types of 576 | Nothing -> 577 | rangeOf className 578 | Just ty -> 579 | rangeOf ty 580 | Just (Tuple _ bs) -> 581 | rangeOf (NonEmptyArray.last bs) 582 | { start: keyword.range.start 583 | , end 584 | } 585 | 586 | instance tokensOfInstance :: TokensOf e => TokensOf (Instance e) where 587 | tokensOf (Instance { head, body }) = 588 | cons head.keyword $ defer \_ -> 589 | foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) head.name 590 | <> foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) head.constraints 591 | <> tokensOf head.className 592 | <> tokensOf head.types 593 | <> foldMap (\(Tuple t bs) -> cons t $ tokensOf bs) body 594 | 595 | instance rangeOfGuarded :: RangeOf e => RangeOf (Guarded e) where 596 | rangeOf = case _ of 597 | Unconditional t wh -> 598 | { start: t.range.start 599 | , end: (rangeOf wh).end 600 | } 601 | Guarded gs -> 602 | { start: (rangeOf (NonEmptyArray.head gs)).start 603 | , end: (rangeOf (NonEmptyArray.last gs)).end 604 | } 605 | 606 | instance tokensOfGuarded :: TokensOf e => TokensOf (Guarded e) where 607 | tokensOf = case _ of 608 | Unconditional t wh -> 609 | cons t $ tokensOf wh 610 | Guarded gs -> 611 | tokensOf gs 612 | 613 | instance rangeOfGuardedExpr :: RangeOf e => RangeOf (GuardedExpr e) where 614 | rangeOf (GuardedExpr ge) = 615 | { start: ge.bar.range.start 616 | , end: (rangeOf ge.where).end 617 | } 618 | 619 | instance tokensOfGuardedExpr :: TokensOf e => TokensOf (GuardedExpr e) where 620 | tokensOf (GuardedExpr ge) = 621 | cons ge.bar $ defer \_ -> 622 | tokensOf ge.patterns 623 | <> singleton ge.separator 624 | <> tokensOf ge.where 625 | 626 | instance tokensOfPatternGuard :: TokensOf e => TokensOf (PatternGuard e) where 627 | tokensOf (PatternGuard { binder, expr }) = 628 | foldMap (\(Tuple b t) -> tokensOf b <> singleton t) binder 629 | <> tokensOf expr 630 | 631 | instance rangeOfFixityOp :: RangeOf FixityOp where 632 | rangeOf = case _ of 633 | FixityValue n1 _ n2 -> 634 | { start: (rangeOf n1).start 635 | , end: (rangeOf n2).end 636 | } 637 | FixityType t _ _ n -> 638 | { start: t.range.start 639 | , end: (rangeOf n).end 640 | } 641 | 642 | instance tokensOfFixityOp :: TokensOf FixityOp where 643 | tokensOf = case _ of 644 | FixityValue n1 t n2 -> 645 | tokensOf n1 <> singleton t <> tokensOf n2 646 | FixityType t1 n1 t2 n2 -> 647 | cons t1 $ tokensOf n1 <> singleton t2 <> tokensOf n2 648 | 649 | instance rangeOfForeign :: RangeOf e => RangeOf (Foreign e) where 650 | rangeOf = case _ of 651 | ForeignValue lbl -> 652 | rangeOf lbl 653 | ForeignData t lbl -> 654 | { start: t.range.start 655 | , end: (rangeOf lbl).end 656 | } 657 | ForeignKind t n -> 658 | { start: t.range.start 659 | , end: (rangeOf n).end 660 | } 661 | 662 | instance tokensOfForeign :: TokensOf e => TokensOf (Foreign e) where 663 | tokensOf = case _ of 664 | ForeignValue lbl -> 665 | tokensOf lbl 666 | ForeignData t lbl -> 667 | cons t $ tokensOf lbl 668 | ForeignKind t n -> 669 | cons t $ tokensOf n 670 | 671 | instance rangeOfInstanceBinding :: RangeOf e => RangeOf (InstanceBinding e) where 672 | rangeOf = case _ of 673 | InstanceBindingSignature lbl -> 674 | rangeOf lbl 675 | InstanceBindingName { name, guarded } -> 676 | { start: (rangeOf name).start 677 | , end: (rangeOf guarded).end 678 | } 679 | 680 | instance tokensOfInstanceBinding :: TokensOf e => TokensOf (InstanceBinding e) where 681 | tokensOf = case _ of 682 | InstanceBindingSignature lbl -> 683 | tokensOf lbl 684 | InstanceBindingName { name, binders, guarded } -> 685 | tokensOf name 686 | <> tokensOf binders 687 | <> tokensOf guarded 688 | 689 | instance rangeOfExpr :: RangeOf e => RangeOf (Expr e) where 690 | rangeOf = case _ of 691 | ExprHole n -> 692 | rangeOf n 693 | ExprSection t -> 694 | t.range 695 | ExprIdent n -> 696 | rangeOf n 697 | ExprConstructor n -> 698 | rangeOf n 699 | ExprBoolean t _ -> 700 | t.range 701 | ExprChar t _ -> 702 | t.range 703 | ExprString t _ -> 704 | t.range 705 | ExprInt t _ -> 706 | t.range 707 | ExprNumber t _ -> 708 | t.range 709 | ExprArray exprs -> 710 | rangeOf exprs 711 | ExprRecord exprs -> 712 | rangeOf exprs 713 | ExprParens w -> 714 | rangeOf w 715 | ExprTyped expr _ ty -> 716 | { start: (rangeOf expr).start 717 | , end: (rangeOf ty).end 718 | } 719 | ExprInfix expr ops -> 720 | { start: (rangeOf expr).start 721 | , end: (rangeOf (snd (NonEmptyArray.last ops))).end 722 | } 723 | ExprOp expr ops -> 724 | { start: (rangeOf expr).start 725 | , end: (rangeOf (snd (NonEmptyArray.last ops))).end 726 | } 727 | ExprOpName n -> 728 | rangeOf n 729 | ExprNegate t expr -> 730 | { start: t.range.start 731 | , end: (rangeOf expr).end 732 | } 733 | ExprRecordAccessor { expr, path } -> 734 | { start: (rangeOf expr).start 735 | , end: (rangeOf path).end 736 | } 737 | ExprRecordUpdate expr upds -> 738 | { start: (rangeOf expr).start 739 | , end: (rangeOf upds).end 740 | } 741 | ExprApp expr exprs -> 742 | { start: (rangeOf expr).start 743 | , end: (rangeOf (NonEmptyArray.last exprs)).end 744 | } 745 | ExprLambda { symbol, body } -> 746 | { start: symbol.range.start 747 | , end: (rangeOf body).end 748 | } 749 | ExprIf ifte -> 750 | { start: ifte.keyword.range.start 751 | , end: (rangeOf ifte.false).end 752 | } 753 | ExprCase { keyword, branches } -> 754 | { start: keyword.range.start 755 | , end: (rangeOf (snd (NonEmptyArray.last branches))).end 756 | } 757 | ExprLet { keyword, body } -> 758 | { start: keyword.range.start 759 | , end: (rangeOf body).end 760 | } 761 | ExprDo { keyword, statements } -> 762 | { start: keyword.range.start 763 | , end: (rangeOf (NonEmptyArray.last statements)).end 764 | } 765 | ExprAdo { keyword, result } -> 766 | { start: keyword.range.start 767 | , end: (rangeOf result).end 768 | } 769 | ExprError e -> 770 | rangeOf e 771 | 772 | instance tokensOfExpr :: TokensOf e => TokensOf (Expr e) where 773 | tokensOf = case _ of 774 | ExprHole n -> 775 | tokensOf n 776 | ExprSection t -> 777 | singleton t 778 | ExprIdent n -> 779 | tokensOf n 780 | ExprConstructor n -> 781 | tokensOf n 782 | ExprBoolean t _ -> 783 | singleton t 784 | ExprChar t _ -> 785 | singleton t 786 | ExprString t _ -> 787 | singleton t 788 | ExprInt t _ -> 789 | singleton t 790 | ExprNumber t _ -> 791 | singleton t 792 | ExprArray exprs -> 793 | tokensOf exprs 794 | ExprRecord exprs -> 795 | tokensOf exprs 796 | ExprParens w -> 797 | tokensOf w 798 | ExprTyped expr t ty -> 799 | tokensOf expr <> defer \_ -> cons t $ tokensOf ty 800 | ExprInfix expr ops -> 801 | tokensOf expr <> defer \_ -> tokensOf ops 802 | ExprOp expr ops -> 803 | tokensOf expr <> defer \_ -> tokensOf ops 804 | ExprOpName n -> 805 | tokensOf n 806 | ExprNegate t expr -> 807 | cons t $ tokensOf expr 808 | ExprRecordAccessor { expr, dot, path } -> 809 | tokensOf expr <> defer \_ -> cons dot $ tokensOf path 810 | ExprRecordUpdate expr upds -> 811 | tokensOf expr <> defer \_ -> tokensOf upds 812 | ExprApp expr exprs -> 813 | tokensOf expr <> defer \_ -> tokensOf exprs 814 | ExprLambda { symbol, binders, arrow, body } -> 815 | cons symbol $ defer \_ -> 816 | tokensOf binders 817 | <> singleton arrow 818 | <> tokensOf body 819 | ExprIf ifte -> 820 | cons ifte.keyword $ defer \_ -> 821 | tokensOf ifte.cond 822 | <> singleton ifte.then 823 | <> tokensOf ifte.true 824 | <> singleton ifte.else 825 | <> tokensOf ifte.false 826 | ExprCase cs -> 827 | cons cs.keyword $ defer \_ -> 828 | tokensOf cs.head 829 | <> singleton cs.of 830 | <> tokensOf cs.branches 831 | ExprLet lt -> 832 | cons lt.keyword $ defer \_ -> 833 | tokensOf lt.bindings 834 | <> singleton lt.in 835 | <> tokensOf lt.body 836 | ExprDo { keyword, statements } -> 837 | cons keyword $ defer \_ -> tokensOf statements 838 | ExprAdo block -> 839 | cons block.keyword $ defer \_ -> 840 | tokensOf block.statements 841 | <> singleton block.in 842 | <> tokensOf block.result 843 | ExprError e -> 844 | tokensOf e 845 | 846 | instance rangeOfAppSpine :: (RangeOf e, RangeOf (f e)) => RangeOf (AppSpine f e) where 847 | rangeOf = case _ of 848 | AppType t a -> 849 | { start: t.range.start 850 | , end: (rangeOf a).end 851 | } 852 | AppTerm a -> 853 | rangeOf a 854 | 855 | instance tokensOfAppSpine :: (TokensOf e, TokensOf (f e)) => TokensOf (AppSpine f e) where 856 | tokensOf = case _ of 857 | AppType t a -> 858 | cons t $ defer \_ -> tokensOf a 859 | AppTerm a -> 860 | tokensOf a 861 | 862 | instance tokensOfRecordUpdate :: TokensOf e => TokensOf (RecordUpdate e) where 863 | tokensOf = case _ of 864 | RecordUpdateLeaf n t e -> 865 | tokensOf n <> singleton t <> tokensOf e 866 | RecordUpdateBranch n us -> 867 | tokensOf n <> tokensOf us 868 | 869 | instance rangeOfDoStatement :: RangeOf e => RangeOf (DoStatement e) where 870 | rangeOf = case _ of 871 | DoLet t bindings -> 872 | { start: t.range.start 873 | , end: (rangeOf (NonEmptyArray.last bindings)).end 874 | } 875 | DoDiscard expr -> 876 | rangeOf expr 877 | DoBind b _ expr -> 878 | { start: (rangeOf b).start 879 | , end: (rangeOf expr).end 880 | } 881 | DoError e -> 882 | rangeOf e 883 | 884 | instance tokensOfDoStatement :: TokensOf e => TokensOf (DoStatement e) where 885 | tokensOf = case _ of 886 | DoLet t bindings -> 887 | cons t $ defer \_ -> tokensOf bindings 888 | DoDiscard expr -> 889 | tokensOf expr 890 | DoBind b t expr -> 891 | tokensOf b <> defer \_ -> cons t $ tokensOf expr 892 | DoError e -> 893 | tokensOf e 894 | 895 | instance rangeOfLetBinding :: RangeOf e => RangeOf (LetBinding e) where 896 | rangeOf = case _ of 897 | LetBindingSignature lbl -> 898 | rangeOf lbl 899 | LetBindingName { name, guarded } -> 900 | { start: (rangeOf name).start 901 | , end: (rangeOf guarded).end 902 | } 903 | LetBindingPattern b _ wh -> 904 | { start: (rangeOf b).start 905 | , end: (rangeOf wh).end 906 | } 907 | LetBindingError e -> 908 | rangeOf e 909 | 910 | instance tokensOfLetBinding :: TokensOf e => TokensOf (LetBinding e) where 911 | tokensOf = case _ of 912 | LetBindingSignature lbl -> 913 | tokensOf lbl 914 | LetBindingName { name, binders, guarded } -> 915 | tokensOf name <> defer \_ -> tokensOf binders <> tokensOf guarded 916 | LetBindingPattern b t wh -> 917 | tokensOf b <> defer \_ -> cons t $ tokensOf wh 918 | LetBindingError e -> 919 | tokensOf e 920 | 921 | instance rangeOfBinder :: RangeOf e => RangeOf (Binder e) where 922 | rangeOf = case _ of 923 | BinderWildcard t -> 924 | t.range 925 | BinderVar n -> 926 | rangeOf n 927 | BinderNamed n _ b -> 928 | { start: (rangeOf n).start 929 | , end: (rangeOf b).end 930 | } 931 | BinderConstructor n bs -> 932 | case Array.last bs of 933 | Nothing -> 934 | rangeOf n 935 | Just b -> 936 | { start: (rangeOf n).start 937 | , end: (rangeOf b).end 938 | } 939 | BinderBoolean t _ -> 940 | t.range 941 | BinderChar t _ -> 942 | t.range 943 | BinderString t _ -> 944 | t.range 945 | BinderInt neg t _ -> 946 | case neg of 947 | Nothing -> 948 | t.range 949 | Just n -> 950 | { start: n.range.start 951 | , end: t.range.end 952 | } 953 | BinderNumber neg t _ -> 954 | case neg of 955 | Nothing -> 956 | t.range 957 | Just n -> 958 | { start: n.range.start 959 | , end: t.range.end 960 | } 961 | BinderArray bs -> 962 | rangeOf bs 963 | BinderRecord bs -> 964 | rangeOf bs 965 | BinderParens b -> 966 | rangeOf b 967 | BinderTyped b _ ty -> 968 | { start: (rangeOf b).start 969 | , end: (rangeOf ty).end 970 | } 971 | BinderOp b ops -> 972 | { start: (rangeOf b).start 973 | , end: (rangeOf (snd (NonEmptyArray.last ops))).end 974 | } 975 | BinderError e -> 976 | rangeOf e 977 | 978 | instance tokensOfBinder :: TokensOf e => TokensOf (Binder e) where 979 | tokensOf = case _ of 980 | BinderWildcard t -> 981 | singleton t 982 | BinderVar n -> 983 | tokensOf n 984 | BinderNamed n t b -> 985 | tokensOf n <> defer \_ -> cons t $ tokensOf b 986 | BinderConstructor n bs -> 987 | tokensOf n <> defer \_ -> tokensOf bs 988 | BinderBoolean t _ -> 989 | singleton t 990 | BinderChar t _ -> 991 | singleton t 992 | BinderString t _ -> 993 | singleton t 994 | BinderInt neg t _ -> 995 | foldMap singleton neg <> singleton t 996 | BinderNumber neg t _ -> 997 | foldMap singleton neg <> singleton t 998 | BinderArray bs -> 999 | tokensOf bs 1000 | BinderRecord bs -> 1001 | tokensOf bs 1002 | BinderParens b -> 1003 | tokensOf b 1004 | BinderTyped b t ty -> 1005 | tokensOf b <> defer \_ -> cons t $ tokensOf ty 1006 | BinderOp b ops -> 1007 | tokensOf b <> defer \_ -> tokensOf ops 1008 | BinderError e -> 1009 | tokensOf e 1010 | 1011 | instance tokensOfRecordLabeled :: TokensOf a => TokensOf (RecordLabeled a) where 1012 | tokensOf = case _ of 1013 | RecordPun n -> 1014 | tokensOf n 1015 | RecordField n t a -> 1016 | tokensOf n <> defer \_ -> cons t $ tokensOf a 1017 | 1018 | instance rangeOfWhere :: RangeOf e => RangeOf (Where e) where 1019 | rangeOf (Where { expr, bindings }) = case bindings of 1020 | Nothing -> 1021 | rangeOf expr 1022 | Just (Tuple _ lb) -> 1023 | { start: (rangeOf expr).start 1024 | , end: (rangeOf (NonEmptyArray.last lb)).end 1025 | } 1026 | 1027 | instance tokensOfWhere :: TokensOf e => TokensOf (Where e) where 1028 | tokensOf (Where { expr, bindings }) = 1029 | tokensOf expr <> defer \_ -> 1030 | foldMap (\(Tuple t bs) -> cons t $ tokensOf bs) bindings 1031 | -------------------------------------------------------------------------------- /src/PureScript/CST/Range/TokenList.purs: -------------------------------------------------------------------------------- 1 | module PureScript.CST.Range.TokenList 2 | ( TokenList 3 | , singleton 4 | , cons 5 | , wrap 6 | , head 7 | , UnconsToken(..) 8 | , uncons 9 | , uncons' 10 | , toUnfoldable 11 | , toArray 12 | , fromArray 13 | ) where 14 | 15 | import Prelude 16 | 17 | import Control.Lazy (class Lazy) 18 | import Control.Monad.ST as ST 19 | import Control.Monad.ST.Ref as STRef 20 | import Data.Array (unsafeIndex) 21 | import Data.Array as Array 22 | import Data.Array.ST as STArray 23 | import Data.Maybe (Maybe(..)) 24 | import Data.Tuple (Tuple(..)) 25 | import Data.Unfoldable (class Unfoldable, unfoldr) 26 | import Partial.Unsafe (unsafePartial) 27 | import PureScript.CST.Types (SourceToken) 28 | 29 | data TokenList 30 | = TokenEmpty 31 | | TokenCons SourceToken TokenList 32 | | TokenWrap SourceToken TokenList SourceToken 33 | | TokenAppend TokenList TokenList 34 | | TokenDefer (Unit -> TokenList) 35 | | TokenArray Int Int (Array SourceToken) 36 | 37 | instance lazyTokenList :: Lazy TokenList where 38 | defer = TokenDefer 39 | 40 | instance semigroupTokenList :: Semigroup TokenList where 41 | append = case _, _ of 42 | a, TokenEmpty -> a 43 | TokenEmpty, b -> b 44 | a, b -> TokenAppend a b 45 | 46 | instance monoidTokenList :: Monoid TokenList where 47 | mempty = TokenEmpty 48 | 49 | fromArray :: Array SourceToken -> TokenList 50 | fromArray arr = if len == 0 then TokenEmpty else TokenArray 0 (len - 1) arr 51 | where 52 | len = Array.length arr 53 | 54 | singleton :: SourceToken -> TokenList 55 | singleton a = TokenCons a TokenEmpty 56 | 57 | cons :: SourceToken -> TokenList -> TokenList 58 | cons = TokenCons 59 | 60 | wrap :: SourceToken -> TokenList -> SourceToken -> TokenList 61 | wrap = TokenWrap 62 | 63 | head :: TokenList -> Maybe SourceToken 64 | head = case _ of 65 | TokenEmpty -> Nothing 66 | TokenCons a _ -> Just a 67 | TokenDefer k -> head (k unit) 68 | TokenWrap a _ _ -> Just a 69 | TokenAppend l _ -> head l 70 | TokenArray ix _ arr -> Just (unsafePartial (unsafeIndex arr ix)) 71 | 72 | data UnconsToken 73 | = UnconsDone 74 | | UnconsMore SourceToken TokenList 75 | 76 | uncons :: TokenList -> UnconsToken 77 | uncons = uncons' UnconsDone UnconsMore 78 | 79 | uncons' :: forall r. r -> (SourceToken -> TokenList -> r) -> TokenList -> r 80 | uncons' done more = case _ of 81 | TokenEmpty -> done 82 | TokenCons a b -> more a b 83 | TokenWrap a b c -> more a (b <> singleton c) 84 | TokenAppend a b -> uncons2 done more a b 85 | TokenDefer k -> uncons' done more (k unit) 86 | TokenArray ix1 ix2 arr -> do 87 | let 88 | next 89 | | ix1 == ix2 = TokenEmpty 90 | | otherwise = TokenArray (ix1 + 1) ix2 arr 91 | more (unsafePartial (unsafeIndex arr ix1)) next 92 | 93 | uncons2 :: forall r. r -> (SourceToken -> TokenList -> r) -> TokenList -> TokenList -> r 94 | uncons2 done more l r = case l of 95 | TokenEmpty -> uncons' done more r 96 | TokenCons a b -> more a (b <> r) 97 | TokenWrap a b c -> more a (b <> TokenCons c r) 98 | TokenAppend a b -> uncons2 done more a (b <> r) 99 | TokenDefer k -> uncons2 done more (k unit) r 100 | TokenArray ix1 ix2 arr -> do 101 | let 102 | next 103 | | ix1 == ix2 = r 104 | | otherwise = TokenArray (ix1 + 1) ix2 arr <> r 105 | more (unsafePartial (unsafeIndex arr ix1)) next 106 | 107 | toUnfoldable :: forall f. Unfoldable f => TokenList -> f SourceToken 108 | toUnfoldable = unfoldr (uncons' Nothing (\a b -> Just (Tuple a b))) 109 | 110 | toArray :: TokenList -> Array SourceToken 111 | toArray init = ST.run do 112 | arr <- STArray.new 113 | cur <- STRef.new init 114 | continue <- STRef.new true 115 | ST.while (STRef.read continue) do 116 | tree <- STRef.read cur 117 | case uncons tree of 118 | UnconsDone -> do 119 | _ <- STRef.write false continue 120 | pure unit 121 | UnconsMore a next -> do 122 | _ <- STRef.write next cur 123 | _ <- STArray.push a arr 124 | pure unit 125 | STArray.unsafeFreeze arr 126 | -------------------------------------------------------------------------------- /src/PureScript/CST/TokenStream.purs: -------------------------------------------------------------------------------- 1 | module PureScript.CST.TokenStream 2 | ( TokenStream(..) 3 | , TokenStep(..) 4 | , step 5 | , consTokens 6 | , layoutStack 7 | , unwindLayout 8 | , currentIndentColumn 9 | ) where 10 | 11 | import Prelude 12 | 13 | import Data.Foldable (class Foldable, foldr) 14 | import Data.Lazy (Lazy) 15 | import Data.Lazy as Lazy 16 | import Data.List (List(..), (:)) 17 | import Data.Maybe (Maybe, maybe) 18 | import Data.Newtype (class Newtype, unwrap) 19 | import Data.Tuple (Tuple(..)) 20 | import PureScript.CST.Errors (ParseError) 21 | import PureScript.CST.Layout (LayoutDelim(..), LayoutStack, currentIndent, isIndented, lytToken) 22 | import PureScript.CST.Types (Comment, LineFeed, SourcePos, SourceToken, Token(..)) 23 | 24 | newtype TokenStream = TokenStream (Lazy TokenStep) 25 | 26 | derive instance newtypeTokenStream :: Newtype TokenStream _ 27 | 28 | data TokenStep 29 | = TokenEOF SourcePos (Array (Comment LineFeed)) 30 | | TokenError SourcePos ParseError (Maybe TokenStream) LayoutStack 31 | | TokenCons SourceToken SourcePos TokenStream LayoutStack 32 | 33 | step :: TokenStream -> TokenStep 34 | step = Lazy.force <<< unwrap 35 | 36 | consTokens 37 | :: forall f 38 | . Foldable f 39 | => f (Tuple SourceToken LayoutStack) 40 | -> Tuple SourcePos TokenStream 41 | -> Tuple SourcePos TokenStream 42 | consTokens = flip (foldr go) 43 | where 44 | go (Tuple tok stk) (Tuple pos next) = 45 | Tuple tok.range.start $ TokenStream $ Lazy.defer \_ -> 46 | TokenCons tok pos next stk 47 | 48 | layoutStack :: TokenStream -> LayoutStack 49 | layoutStack stream = case step stream of 50 | TokenEOF _ _ -> Nil 51 | TokenError _ _ _ stk -> stk 52 | TokenCons _ _ _ stk -> stk 53 | 54 | unwindLayout :: SourcePos -> TokenStream -> LayoutStack -> TokenStream 55 | unwindLayout pos eof = go 56 | where 57 | go stk = TokenStream $ Lazy.defer \_ -> case stk of 58 | Nil -> step eof 59 | Tuple pos' lyt : tl -> 60 | case lyt of 61 | LytRoot -> 62 | step eof 63 | _ 64 | | isIndented lyt -> 65 | TokenCons (lytToken pos (TokLayoutEnd pos'.column)) pos (go tl) tl 66 | | otherwise -> 67 | step (go tl) 68 | 69 | -- In the token stream, the layout stack represents the state after the token. 70 | -- When determining the current indent level, this creates an edge case relating 71 | -- to TokLayoutEnd. The layout stack will return the next indent, but for the 72 | -- purposes of recovery, we want TokLayoutEnd column to be included as the current 73 | -- indent, necessitating special handling. 74 | currentIndentColumn :: TokenStream -> Int 75 | currentIndentColumn stream = case step stream of 76 | TokenError _ _ _ stk -> 77 | stkColumn stk 78 | TokenEOF _ _ -> 79 | 0 80 | TokenCons { value: TokLayoutEnd col } _ _ _ -> 81 | col 82 | TokenCons _ _ _ stk -> 83 | stkColumn stk 84 | where 85 | stkColumn = maybe 0 _.column <<< currentIndent 86 | -------------------------------------------------------------------------------- /src/PureScript/CST/Traversal.purs: -------------------------------------------------------------------------------- 1 | module PureScript.CST.Traversal 2 | ( Rewrite 3 | , defaultVisitorM 4 | , rewriteModuleBottomUpM 5 | , rewriteBinderBottomUpM 6 | , rewriteExprBottomUpM 7 | , rewriteDeclBottomUpM 8 | , rewriteTypeBottomUpM 9 | , rewriteModuleTopDownM 10 | , rewriteBinderTopDownM 11 | , rewriteExprTopDownM 12 | , rewriteDeclTopDownM 13 | , rewriteTypeTopDownM 14 | , RewriteWithContext 15 | , defaultVisitorWithContextM 16 | , rewriteModuleWithContextM 17 | , rewriteBinderWithContextM 18 | , rewriteExprWithContextM 19 | , rewriteDeclWithContextM 20 | , rewriteTypeWithContextM 21 | , MonoidalRewrite 22 | , defaultMonoidalVisitor 23 | , foldMapModule 24 | , foldMapBinder 25 | , foldMapDecl 26 | , foldMapExpr 27 | , foldMapType 28 | , PureRewrite 29 | , defaultVisitor 30 | , rewriteModuleBottomUp 31 | , rewriteBinderBottomUp 32 | , rewriteExprBottomUp 33 | , rewriteDeclBottomUp 34 | , rewriteTypeBottomUp 35 | , rewriteModuleTopDown 36 | , rewriteBinderTopDown 37 | , rewriteExprTopDown 38 | , rewriteDeclTopDown 39 | , rewriteTypeTopDown 40 | , PureRewriteWithContext 41 | , defaultVisitorWithContext 42 | , rewriteModuleWithContext 43 | , rewriteBinderWithContext 44 | , rewriteExprWithContext 45 | , rewriteDeclWithContext 46 | , rewriteTypeWithContext 47 | , traverseModule 48 | , traverseModuleBody 49 | , traverseDecl 50 | , traverseForeign 51 | , traverseInstance 52 | , traverseInstanceHead 53 | , traverseInstanceBinding 54 | , traverseClassHead 55 | , traverseOneOrDelimited 56 | , traverseDataHead 57 | , traverseDataCtor 58 | , traverseType 59 | , traverseRow 60 | , traverseTypeVarBinding 61 | , traverseExpr 62 | , traverseExprAppSpine 63 | , traverseDelimited 64 | , traverseDelimitedNonEmpty 65 | , traverseSeparated 66 | , traverseWrapped 67 | , traverseRecordLabeled 68 | , traverseLabeled 69 | , traverseRecordAccessor 70 | , traverseRecordUpdate 71 | , traverseLambda 72 | , traverseIfThenElse 73 | , traverseCaseOf 74 | , traverseGuarded 75 | , traverseGuardedExpr 76 | , traversePatternGuard 77 | , traverseWhere 78 | , traverseLetBinding 79 | , traverseValueBindingFields 80 | , traverseLetIn 81 | , traverseDoStatement 82 | , traverseDoBlock 83 | , traverseAdoBlock 84 | , traverseBinder 85 | , bottomUpTraversal 86 | , rewriteBottomUpM 87 | , topDownTraversal 88 | , rewriteTopDownM 89 | , topDownTraversalWithContextM 90 | , rewriteWithContextM 91 | , topDownMonoidalTraversal 92 | , monoidalRewrite 93 | , bottomUpPureTraversal 94 | , rewriteBottomUp 95 | , topDownPureTraversal 96 | , rewriteTopDown 97 | , topDownTraversalWithContext 98 | , rewriteWithContext 99 | ) where 100 | 101 | import Prelude 102 | import Prim hiding (Row, Type) 103 | 104 | import Control.Monad.Free (Free, runFree) 105 | import Control.Monad.Reader.Trans (ReaderT(..), runReaderT) 106 | import Data.Bitraversable (bitraverse, ltraverse) 107 | import Data.Const (Const(..)) 108 | import Data.Functor.Compose (Compose(..)) 109 | import Data.Identity (Identity(..)) 110 | import Data.Newtype (un) 111 | import Data.Traversable (traverse) 112 | import Data.Tuple (Tuple(..), curry, uncurry) 113 | import Prim as P 114 | import PureScript.CST.Types (AdoBlock, AppSpine(..), Binder(..), CaseOf, ClassHead, DataCtor(..), DataHead, Declaration(..), Delimited, DelimitedNonEmpty, DoBlock, DoStatement(..), Expr(..), Foreign(..), Guarded(..), GuardedExpr(..), IfThenElse, Instance(..), InstanceBinding(..), InstanceHead, Labeled(..), Lambda, LetBinding(..), LetIn, Module(..), ModuleBody(..), OneOrDelimited(..), PatternGuard(..), RecordAccessor, RecordLabeled(..), RecordUpdate(..), Row(..), Separated(..), Type(..), TypeVarBinding(..), ValueBindingFields, Where(..), Wrapped(..)) 115 | import Type.Row (type (+)) 116 | 117 | type Rewrite e f (g :: P.Type -> P.Type) = g e -> f (g e) 118 | type RewriteWithContext c e f (g :: P.Type -> P.Type) = c -> g e -> f (Tuple c (g e)) 119 | type MonoidalRewrite e m (g :: P.Type -> P.Type) = g e -> m 120 | type PureRewrite e (g :: P.Type -> P.Type) = g e -> g e 121 | type PureRewriteWithContext c e (g :: P.Type -> P.Type) = c -> g e -> Tuple c (g e) 122 | 123 | type OnBinder (t :: (P.Type -> P.Type) -> P.Type) r = (onBinder :: t Binder | r) 124 | type OnDecl (t :: (P.Type -> P.Type) -> P.Type) r = (onDecl :: t Declaration | r) 125 | type OnExpr (t :: (P.Type -> P.Type) -> P.Type) r = (onExpr :: t Expr | r) 126 | type OnType (t :: (P.Type -> P.Type) -> P.Type) r = (onType :: t Type | r) 127 | 128 | type OnPureScript t = 129 | ( OnBinder t 130 | + OnDecl t 131 | + OnExpr t 132 | + OnType t 133 | + () 134 | ) 135 | 136 | defaultVisitorM :: forall e f. Applicative f => { | OnPureScript (Rewrite e f) } 137 | defaultVisitorM = 138 | { onBinder: pure 139 | , onDecl: pure 140 | , onExpr: pure 141 | , onType: pure 142 | } 143 | 144 | defaultVisitorWithContextM :: forall c e m. Monad m => { | OnPureScript (RewriteWithContext c e m) } 145 | defaultVisitorWithContextM = 146 | { onBinder: curry pure 147 | , onDecl: curry pure 148 | , onExpr: curry pure 149 | , onType: curry pure 150 | } 151 | 152 | defaultMonoidalVisitor :: forall e m. Monoid m => { | OnPureScript (MonoidalRewrite e m) } 153 | defaultMonoidalVisitor = 154 | { onBinder: mempty 155 | , onDecl: mempty 156 | , onExpr: mempty 157 | , onType: mempty 158 | } 159 | 160 | defaultVisitor :: forall e. { | OnPureScript (PureRewrite e) } 161 | defaultVisitor = 162 | { onBinder: identity 163 | , onDecl: identity 164 | , onExpr: identity 165 | , onType: identity 166 | } 167 | 168 | defaultVisitorWithContext :: forall c e. { | OnPureScript (PureRewriteWithContext c e) } 169 | defaultVisitorWithContext = 170 | { onBinder: curry identity 171 | , onDecl: curry identity 172 | , onExpr: curry identity 173 | , onType: curry identity 174 | } 175 | 176 | traverseModule 177 | :: forall e f r 178 | . Applicative f 179 | => { | OnBinder (Rewrite e f) + OnDecl (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 180 | -> Rewrite e f Module 181 | traverseModule k (Module mod) = 182 | (\body -> Module mod { header = mod.header, body = body }) 183 | <$> traverseModuleBody k mod.body 184 | 185 | traverseModuleBody 186 | :: forall e f r 187 | . Applicative f 188 | => { | OnBinder (Rewrite e f) + OnDecl (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 189 | -> Rewrite e f ModuleBody 190 | traverseModuleBody k (ModuleBody b) = 191 | (\decls -> ModuleBody b { decls = decls }) 192 | <$> traverse k.onDecl b.decls 193 | 194 | traverseDecl 195 | :: forall e f r 196 | . Applicative f 197 | => { | OnBinder (Rewrite e f) + OnDecl (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 198 | -> Rewrite e f Declaration 199 | traverseDecl k = case _ of 200 | DeclData binding ctors -> DeclData <$> traverseDataHead k binding <*> traverse (traverse (traverseSeparated (traverseDataCtor k))) ctors 201 | DeclType head tok typ -> DeclType <$> traverseDataHead k head <@> tok <*> k.onType typ 202 | DeclNewtype head tok name typ -> DeclNewtype <$> traverseDataHead k head <@> tok <@> name <*> k.onType typ 203 | DeclClass head sig -> DeclClass <$> traverseClassHead k head <*> traverse (traverse (traverse (traverseLabeled k.onType))) sig 204 | DeclInstanceChain instances -> DeclInstanceChain <$> traverseSeparated (traverseInstance k) instances 205 | DeclDerive tok mbTok head -> DeclDerive tok mbTok <$> traverseInstanceHead k head 206 | DeclKindSignature tok typ -> DeclKindSignature tok <$> traverseLabeled k.onType typ 207 | DeclSignature typ -> DeclSignature <$> traverseLabeled k.onType typ 208 | DeclValue fields -> DeclValue <$> traverseValueBindingFields k fields 209 | DeclForeign tok1 tok2 f -> DeclForeign tok1 tok2 <$> traverseForeign k f 210 | decl -> pure decl 211 | 212 | traverseForeign 213 | :: forall e f r 214 | . Applicative f 215 | => { | OnType (Rewrite e f) + r } 216 | -> Rewrite e f Foreign 217 | traverseForeign k = case _ of 218 | ForeignValue typ -> ForeignValue <$> traverseLabeled k.onType typ 219 | ForeignData tok typ -> ForeignData tok <$> traverseLabeled k.onType typ 220 | other@(ForeignKind _ _) -> pure other 221 | 222 | traverseInstance 223 | :: forall e f r 224 | . Applicative f 225 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 226 | -> Rewrite e f Instance 227 | traverseInstance k (Instance i) = 228 | (\head body -> Instance i { head = head, body = body }) 229 | <$> traverseInstanceHead k i.head 230 | <*> traverse (traverse (traverse (traverseInstanceBinding k))) i.body 231 | 232 | traverseInstanceHead 233 | :: forall e f r 234 | . Applicative f 235 | => { | OnType (Rewrite e f) + r } 236 | -> Rewrite e f InstanceHead 237 | traverseInstanceHead k head = 238 | head { constraints = _, types = _ } 239 | <$> traverse (ltraverse (traverseOneOrDelimited k.onType)) head.constraints 240 | <*> traverse k.onType head.types 241 | 242 | traverseInstanceBinding 243 | :: forall e f r 244 | . Applicative f 245 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 246 | -> Rewrite e f InstanceBinding 247 | traverseInstanceBinding k = case _ of 248 | InstanceBindingSignature typ -> InstanceBindingSignature <$> traverseLabeled k.onType typ 249 | InstanceBindingName fields -> InstanceBindingName <$> traverseValueBindingFields k fields 250 | 251 | traverseClassHead 252 | :: forall e f r 253 | . Applicative f 254 | => { | OnType (Rewrite e f) + r } 255 | -> Rewrite e f ClassHead 256 | traverseClassHead k head = 257 | head { super = _, vars = _ } 258 | <$> traverse (ltraverse (traverseOneOrDelimited k.onType)) head.super 259 | <*> traverse (traverseTypeVarBinding k) head.vars 260 | 261 | traverseOneOrDelimited 262 | :: forall a f 263 | . Applicative f 264 | => (a -> f a) 265 | -> Rewrite a f OneOrDelimited 266 | traverseOneOrDelimited k = case _ of 267 | One a -> One <$> k a 268 | Many all -> Many <$> traverseDelimitedNonEmpty k all 269 | 270 | traverseDataHead 271 | :: forall e f r 272 | . Applicative f 273 | => { | OnType (Rewrite e f) + r } 274 | -> Rewrite e f DataHead 275 | traverseDataHead k head = 276 | head { vars = _ } 277 | <$> traverse (traverseTypeVarBinding k) head.vars 278 | 279 | traverseDataCtor 280 | :: forall e f r 281 | . Applicative f 282 | => { | OnType (Rewrite e f) + r } 283 | -> Rewrite e f DataCtor 284 | traverseDataCtor k (DataCtor ctor) = 285 | (\fields -> DataCtor ctor { fields = fields }) 286 | <$> traverse k.onType ctor.fields 287 | 288 | traverseType 289 | :: forall e f r 290 | . Applicative f 291 | => { | OnType (Rewrite e f) + r } 292 | -> Rewrite e f Type 293 | traverseType k = case _ of 294 | TypeRow row -> TypeRow <$> traverseWrapped (traverseRow k) row 295 | TypeRecord row -> TypeRecord <$> traverseWrapped (traverseRow k) row 296 | TypeForall tok1 bindings tok2 typ -> TypeForall tok1 <$> traverse (traverseTypeVarBinding k) bindings <@> tok2 <*> k.onType typ 297 | TypeKinded typ1 tok typ2 -> TypeKinded <$> k.onType typ1 <@> tok <*> k.onType typ2 298 | TypeApp typ args -> TypeApp <$> k.onType typ <*> traverse k.onType args 299 | TypeOp typ ops -> TypeOp <$> k.onType typ <*> traverse (traverse k.onType) ops 300 | TypeArrow typ1 tok typ2 -> TypeArrow <$> k.onType typ1 <@> tok <*> k.onType typ2 301 | TypeConstrained typ1 tok typ2 -> TypeConstrained <$> k.onType typ1 <@> tok <*> k.onType typ2 302 | TypeParens wrapped -> TypeParens <$> traverseWrapped k.onType wrapped 303 | typ -> pure typ 304 | 305 | traverseRow 306 | :: forall e f r 307 | . Applicative f 308 | => { | OnType (Rewrite e f) + r } 309 | -> Rewrite e f Row 310 | traverseRow k (Row r) = 311 | (\labels tail -> Row r { labels = labels, tail = tail }) 312 | <$> traverse (traverseSeparated (traverseLabeled k.onType)) r.labels 313 | <*> traverse (traverse k.onType) r.tail 314 | 315 | traverseTypeVarBinding 316 | :: forall e f r a 317 | . Applicative f 318 | => { | OnType (Rewrite e f) + r } 319 | -> Rewrite e f (TypeVarBinding a) 320 | traverseTypeVarBinding k = case _ of 321 | TypeVarKinded labeled -> TypeVarKinded <$> traverseWrapped (traverseLabeled k.onType) labeled 322 | TypeVarName name -> pure (TypeVarName name) 323 | 324 | traverseExpr 325 | :: forall e f r 326 | . Applicative f 327 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 328 | -> Rewrite e f Expr 329 | traverseExpr k = case _ of 330 | ExprArray expr -> ExprArray <$> (traverseDelimited k.onExpr expr) 331 | ExprRecord expr -> ExprRecord <$> traverseDelimited (traverseRecordLabeled k.onExpr) expr 332 | ExprParens expr -> ExprParens <$> traverseWrapped k.onExpr expr 333 | ExprTyped expr tok ty -> ExprTyped <$> k.onExpr expr <@> tok <*> k.onType ty 334 | ExprInfix expr ops -> ExprInfix <$> k.onExpr expr <*> traverse (bitraverse (traverseWrapped k.onExpr) k.onExpr) ops 335 | ExprOp expr ops -> ExprOp <$> k.onExpr expr <*> traverse (traverse k.onExpr) ops 336 | ExprNegate tok expr -> ExprNegate tok <$> k.onExpr expr 337 | ExprRecordAccessor recordAccessor -> ExprRecordAccessor <$> traverseRecordAccessor k recordAccessor 338 | ExprRecordUpdate expr recordUpdates -> ExprRecordUpdate <$> k.onExpr expr <*> traverseWrapped (traverseSeparated (traverseRecordUpdate k)) recordUpdates 339 | ExprApp expr args -> ExprApp <$> k.onExpr expr <*> traverse (traverseExprAppSpine k) args 340 | ExprLambda lambda -> ExprLambda <$> traverseLambda k lambda 341 | ExprIf ifThenElse -> ExprIf <$> traverseIfThenElse k ifThenElse 342 | ExprCase caseOf -> ExprCase <$> traverseCaseOf k caseOf 343 | ExprLet letIn -> ExprLet <$> traverseLetIn k letIn 344 | ExprDo doBlock -> ExprDo <$> traverseDoBlock k doBlock 345 | ExprAdo adoBlock -> ExprAdo <$> traverseAdoBlock k adoBlock 346 | expr -> pure expr 347 | 348 | traverseExprAppSpine 349 | :: forall e f r 350 | . Applicative f 351 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 352 | -> Rewrite e f (AppSpine Expr) 353 | traverseExprAppSpine k = case _ of 354 | AppType tok ty -> AppType tok <$> k.onType ty 355 | AppTerm expr -> AppTerm <$> k.onExpr expr 356 | 357 | traverseDelimited 358 | :: forall f a 359 | . Applicative f 360 | => (a -> f a) 361 | -> Rewrite a f Delimited 362 | traverseDelimited k = traverseWrapped (traverse (traverseSeparated k)) 363 | 364 | traverseDelimitedNonEmpty 365 | :: forall a f 366 | . Applicative f 367 | => (a -> f a) 368 | -> Rewrite a f DelimitedNonEmpty 369 | traverseDelimitedNonEmpty k = traverseWrapped (traverseSeparated k) 370 | 371 | traverseSeparated 372 | :: forall f a 373 | . Applicative f 374 | => (a -> f a) 375 | -> Rewrite a f Separated 376 | traverseSeparated k (Separated sep) = ado 377 | head <- k sep.head 378 | tail <- traverse (traverse k) sep.tail 379 | in Separated { head, tail } 380 | 381 | traverseWrapped 382 | :: forall f a 383 | . Applicative f 384 | => (a -> f a) 385 | -> Rewrite a f Wrapped 386 | traverseWrapped k (Wrapped w) = 387 | (\value -> Wrapped w { value = value }) <$> k w.value 388 | 389 | traverseRecordLabeled 390 | :: forall f a 391 | . Applicative f 392 | => (a -> f a) 393 | -> Rewrite a f RecordLabeled 394 | traverseRecordLabeled k = case _ of 395 | RecordPun name -> pure (RecordPun name) 396 | RecordField name tok a -> RecordField name tok <$> k a 397 | 398 | traverseLabeled 399 | :: forall f a b 400 | . Applicative f 401 | => (b -> f b) 402 | -> Rewrite b f (Labeled a) 403 | traverseLabeled k (Labeled l) = 404 | (\value -> Labeled l { value = value }) <$> k l.value 405 | 406 | traverseRecordAccessor 407 | :: forall e f r 408 | . Applicative f 409 | => { | OnExpr (Rewrite e f) + r } 410 | -> Rewrite e f RecordAccessor 411 | traverseRecordAccessor k r = 412 | r { expr = _ } <$> k.onExpr r.expr 413 | 414 | traverseRecordUpdate 415 | :: forall e f r 416 | . Applicative f 417 | => { | OnExpr (Rewrite e f) + r } 418 | -> Rewrite e f RecordUpdate 419 | traverseRecordUpdate k = case _ of 420 | RecordUpdateLeaf name tok expr -> RecordUpdateLeaf name tok <$> k.onExpr expr 421 | RecordUpdateBranch name recordUpdates -> RecordUpdateBranch name <$> traverseWrapped (traverseSeparated (traverseRecordUpdate k)) recordUpdates 422 | 423 | traverseLambda 424 | :: forall e f r 425 | . Applicative f 426 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 427 | -> Rewrite e f Lambda 428 | traverseLambda k l = 429 | l { binders = _, body = _ } 430 | <$> traverse k.onBinder l.binders 431 | <*> k.onExpr l.body 432 | 433 | traverseIfThenElse 434 | :: forall e f r 435 | . Applicative f 436 | => { | OnExpr (Rewrite e f) + r } 437 | -> Rewrite e f IfThenElse 438 | traverseIfThenElse k r = 439 | r { cond = _, true = _, false = _ } 440 | <$> k.onExpr r.cond 441 | <*> k.onExpr r.true 442 | <*> k.onExpr r.false 443 | 444 | traverseCaseOf 445 | :: forall e f r 446 | . Applicative f 447 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 448 | -> Rewrite e f CaseOf 449 | traverseCaseOf k r = 450 | r { head = _, branches = _ } 451 | <$> traverseSeparated k.onExpr r.head 452 | <*> traverse (bitraverse (traverseSeparated k.onBinder) (traverseGuarded k)) r.branches 453 | 454 | traverseGuarded 455 | :: forall e f r 456 | . Applicative f 457 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 458 | -> Rewrite e f Guarded 459 | traverseGuarded k = case _ of 460 | Unconditional tok w -> Unconditional tok <$> traverseWhere k w 461 | Guarded guards -> Guarded <$> traverse (traverseGuardedExpr k) guards 462 | 463 | traverseGuardedExpr 464 | :: forall e f r 465 | . Applicative f 466 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 467 | -> Rewrite e f GuardedExpr 468 | traverseGuardedExpr k (GuardedExpr g) = 469 | (\ps wh -> GuardedExpr g { patterns = ps, where = wh }) 470 | <$> traverseSeparated (traversePatternGuard k) g.patterns 471 | <*> traverseWhere k g.where 472 | 473 | traversePatternGuard 474 | :: forall e f r 475 | . Applicative f 476 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 477 | -> Rewrite e f PatternGuard 478 | traversePatternGuard k (PatternGuard g) = 479 | (\binder expr -> PatternGuard { binder, expr }) 480 | <$> traverse (ltraverse k.onBinder) g.binder 481 | <*> k.onExpr g.expr 482 | 483 | traverseWhere 484 | :: forall e f r 485 | . Applicative f 486 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 487 | -> Rewrite e f Where 488 | traverseWhere k (Where w) = 489 | (\expr bindings -> Where { expr, bindings }) 490 | <$> k.onExpr w.expr 491 | <*> traverse (traverse (traverse (traverseLetBinding k))) w.bindings 492 | 493 | traverseLetBinding 494 | :: forall e f r 495 | . Applicative f 496 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 497 | -> Rewrite e f LetBinding 498 | traverseLetBinding k = case _ of 499 | LetBindingSignature name -> LetBindingSignature <$> traverseLabeled k.onType name 500 | LetBindingName valueBinders -> LetBindingName <$> traverseValueBindingFields k valueBinders 501 | LetBindingPattern binder tok w -> LetBindingPattern <$> k.onBinder binder <@> tok <*> traverseWhere k w 502 | LetBindingError e -> pure (LetBindingError e) 503 | 504 | traverseValueBindingFields 505 | :: forall e f r 506 | . Applicative f 507 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 508 | -> Rewrite e f ValueBindingFields 509 | traverseValueBindingFields k v = 510 | v { binders = _, guarded = _ } 511 | <$> traverse k.onBinder v.binders 512 | <*> traverseGuarded k v.guarded 513 | 514 | traverseLetIn 515 | :: forall e f r 516 | . Applicative f 517 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 518 | -> Rewrite e f LetIn 519 | traverseLetIn k l = 520 | l { bindings = _, body = _ } 521 | <$> traverse (traverseLetBinding k) l.bindings 522 | <*> k.onExpr l.body 523 | 524 | traverseDoStatement 525 | :: forall e f r 526 | . Applicative f 527 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 528 | -> Rewrite e f DoStatement 529 | traverseDoStatement k = case _ of 530 | DoLet tok letBindings -> DoLet tok <$> traverse (traverseLetBinding k) letBindings 531 | DoDiscard expr -> DoDiscard <$> k.onExpr expr 532 | DoBind binder tok expr -> DoBind <$> k.onBinder binder <@> tok <*> k.onExpr expr 533 | DoError e -> pure (DoError e) 534 | 535 | traverseDoBlock 536 | :: forall e f r 537 | . Applicative f 538 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 539 | -> Rewrite e f DoBlock 540 | traverseDoBlock k d = 541 | d { statements = _ } 542 | <$> traverse (traverseDoStatement k) d.statements 543 | 544 | traverseAdoBlock 545 | :: forall e f r 546 | . Applicative f 547 | => { | OnBinder (Rewrite e f) + OnExpr (Rewrite e f) + OnType (Rewrite e f) + r } 548 | -> Rewrite e f AdoBlock 549 | traverseAdoBlock k a = 550 | a { statements = _, result = _ } 551 | <$> traverse (traverseDoStatement k) a.statements 552 | <*> k.onExpr a.result 553 | 554 | traverseBinder 555 | :: forall e f r 556 | . Applicative f 557 | => { | OnBinder (Rewrite e f) + OnType (Rewrite e f) + r } 558 | -> Rewrite e f Binder 559 | traverseBinder k = case _ of 560 | BinderNamed name tok binder -> BinderNamed name tok <$> k.onBinder binder 561 | BinderConstructor name binders -> BinderConstructor name <$> traverse k.onBinder binders 562 | BinderArray binders -> BinderArray <$> traverseDelimited k.onBinder binders 563 | BinderRecord binders -> BinderRecord <$> traverseDelimited (traverseRecordLabeled k.onBinder) binders 564 | BinderParens binder -> BinderParens <$> traverseWrapped k.onBinder binder 565 | BinderTyped binder tok typ -> BinderTyped <$> k.onBinder binder <@> tok <*> k.onType typ 566 | BinderOp binder ops -> BinderOp <$> k.onBinder binder <*> traverse (traverse k.onBinder) ops 567 | binder -> pure binder 568 | 569 | bottomUpTraversal 570 | :: forall m e 571 | . Monad m 572 | => { | OnPureScript (Rewrite e m) } 573 | -> { | OnPureScript (Rewrite e m) } 574 | bottomUpTraversal visitor = visitor' 575 | where 576 | visitor' = 577 | { onBinder: \a -> visitor.onBinder =<< defer (\_ -> traverseBinder visitor' a) 578 | , onExpr: \a -> visitor.onExpr =<< defer (\_ -> traverseExpr visitor' a) 579 | , onType: \a -> visitor.onType =<< defer (\_ -> traverseType visitor' a) 580 | , onDecl: \a -> visitor.onDecl =<< defer (\_ -> traverseDecl visitor' a) 581 | } 582 | 583 | rewriteBottomUpM 584 | :: forall m e g 585 | . Monad m 586 | => ({ | OnPureScript (Rewrite e m) } -> Rewrite e m g) 587 | -> { | OnPureScript (Rewrite e m) } 588 | -> Rewrite e m g 589 | rewriteBottomUpM traversal visitor = do 590 | let visitor' = bottomUpTraversal visitor 591 | traversal visitor' 592 | 593 | rewriteModuleBottomUpM :: forall e m. Monad m => { | OnPureScript (Rewrite e m) } -> Rewrite e m Module 594 | rewriteModuleBottomUpM = rewriteBottomUpM traverseModule 595 | 596 | rewriteBinderBottomUpM :: forall e m. Monad m => { | OnPureScript (Rewrite e m) } -> Rewrite e m Binder 597 | rewriteBinderBottomUpM = rewriteBottomUpM _.onBinder 598 | 599 | rewriteExprBottomUpM :: forall e m. Monad m => { | OnPureScript (Rewrite e m) } -> Rewrite e m Expr 600 | rewriteExprBottomUpM = rewriteBottomUpM _.onExpr 601 | 602 | rewriteDeclBottomUpM :: forall e m. Monad m => { | OnPureScript (Rewrite e m) } -> Rewrite e m Declaration 603 | rewriteDeclBottomUpM = rewriteBottomUpM _.onDecl 604 | 605 | rewriteTypeBottomUpM :: forall e m. Monad m => { | OnPureScript (Rewrite e m) } -> Rewrite e m Type 606 | rewriteTypeBottomUpM = rewriteBottomUpM _.onType 607 | 608 | topDownTraversal 609 | :: forall m e 610 | . Monad m 611 | => { | OnPureScript (Rewrite e m) } 612 | -> { | OnPureScript (Rewrite e m) } 613 | topDownTraversal visitor = visitor' 614 | where 615 | visitor' = 616 | { onBinder: \a -> visitor.onBinder a >>= traverseBinder visitor' 617 | , onExpr: \a -> visitor.onExpr a >>= traverseExpr visitor' 618 | , onType: \a -> visitor.onType a >>= traverseType visitor' 619 | , onDecl: \a -> visitor.onDecl a >>= traverseDecl visitor' 620 | } 621 | 622 | rewriteTopDownM 623 | :: forall m e g 624 | . Monad m 625 | => ({ | OnPureScript (Rewrite e m) } -> Rewrite e m g) 626 | -> { | OnPureScript (Rewrite e m) } 627 | -> Rewrite e m g 628 | rewriteTopDownM traversal visitor = do 629 | let visitor' = topDownTraversal visitor 630 | traversal visitor' 631 | 632 | rewriteModuleTopDownM :: forall e m. Monad m => { | OnPureScript (Rewrite e m) } -> Rewrite e m Module 633 | rewriteModuleTopDownM = rewriteTopDownM traverseModule 634 | 635 | rewriteBinderTopDownM :: forall e m. Monad m => { | OnPureScript (Rewrite e m) } -> Rewrite e m Binder 636 | rewriteBinderTopDownM = rewriteTopDownM _.onBinder 637 | 638 | rewriteDeclTopDownM :: forall e m. Monad m => { | OnPureScript (Rewrite e m) } -> Rewrite e m Declaration 639 | rewriteDeclTopDownM = rewriteTopDownM _.onDecl 640 | 641 | rewriteExprTopDownM :: forall e m. Monad m => { | OnPureScript (Rewrite e m) } -> Rewrite e m Expr 642 | rewriteExprTopDownM = rewriteTopDownM _.onExpr 643 | 644 | rewriteTypeTopDownM :: forall e m. Monad m => { | OnPureScript (Rewrite e m) } -> Rewrite e m Type 645 | rewriteTypeTopDownM = rewriteTopDownM _.onType 646 | 647 | topDownTraversalWithContextM 648 | :: forall c m e 649 | . Monad m 650 | => { | OnPureScript (RewriteWithContext c e m) } 651 | -> { | OnPureScript (Rewrite e (ReaderT c m)) } 652 | topDownTraversalWithContextM visitor = visitor' 653 | where 654 | visitor' = 655 | { onBinder: \a -> ReaderT \ctx -> visitor.onBinder ctx a >>= uncurry (flip (runReaderT <<< traverseBinder visitor')) 656 | , onExpr: \a -> ReaderT \ctx -> visitor.onExpr ctx a >>= uncurry (flip (runReaderT <<< traverseExpr visitor')) 657 | , onDecl: \a -> ReaderT \ctx -> visitor.onDecl ctx a >>= uncurry (flip (runReaderT <<< traverseDecl visitor')) 658 | , onType: \a -> ReaderT \ctx -> visitor.onType ctx a >>= uncurry (flip (runReaderT <<< traverseType visitor')) 659 | } 660 | 661 | rewriteWithContextM 662 | :: forall c m e g 663 | . Monad m 664 | => ({ | OnPureScript (Rewrite e (ReaderT c m)) } -> Rewrite e (ReaderT c m) g) 665 | -> { | OnPureScript (RewriteWithContext c e m) } 666 | -> RewriteWithContext c e m g 667 | rewriteWithContextM traversal visitor ctx g = do 668 | let visitor' = topDownTraversalWithContextM visitor 669 | Tuple ctx <$> runReaderT ((traversal visitor') g) ctx 670 | 671 | rewriteModuleWithContextM :: forall c m e. Monad m => { | OnPureScript (RewriteWithContext c e m) } -> RewriteWithContext c e m Module 672 | rewriteModuleWithContextM = rewriteWithContextM traverseModule 673 | 674 | rewriteBinderWithContextM :: forall c m e. Monad m => { | OnPureScript (RewriteWithContext c e m) } -> RewriteWithContext c e m Binder 675 | rewriteBinderWithContextM = rewriteWithContextM _.onBinder 676 | 677 | rewriteDeclWithContextM :: forall c m e. Monad m => { | OnPureScript (RewriteWithContext c e m) } -> RewriteWithContext c e m Declaration 678 | rewriteDeclWithContextM = rewriteWithContextM _.onDecl 679 | 680 | rewriteExprWithContextM :: forall c m e. Monad m => { | OnPureScript (RewriteWithContext c e m) } -> RewriteWithContext c e m Expr 681 | rewriteExprWithContextM = rewriteWithContextM _.onExpr 682 | 683 | rewriteTypeWithContextM :: forall c m e. Monad m => { | OnPureScript (RewriteWithContext c e m) } -> RewriteWithContext c e m Type 684 | rewriteTypeWithContextM = rewriteWithContextM _.onType 685 | 686 | defer :: forall m a. Monad m => (Unit -> m a) -> m a 687 | defer = (pure unit >>= _) 688 | 689 | topDownMonoidalTraversal 690 | :: forall e m 691 | . Monoid m 692 | => { | OnPureScript (MonoidalRewrite e m) } 693 | -> { | OnPureScript (Rewrite e (Compose (Free Identity) (Const m))) } 694 | topDownMonoidalTraversal visitor = visitor' 695 | where 696 | visitor' = 697 | { onBinder: \a -> Compose (pure (Const (visitor.onBinder a))) <*> Compose (defer \_ -> (un Compose (traverseBinder visitor' a))) 698 | , onExpr: \a -> Compose (pure (Const (visitor.onExpr a))) <*> Compose (defer \_ -> (un Compose (traverseExpr visitor' a))) 699 | , onDecl: \a -> Compose (pure (Const (visitor.onDecl a))) <*> Compose (defer \_ -> (un Compose (traverseDecl visitor' a))) 700 | , onType: \a -> Compose (pure (Const (visitor.onType a))) <*> Compose (defer \_ -> (un Compose (traverseType visitor' a))) 701 | } 702 | 703 | monoidalRewrite 704 | :: forall e m g 705 | . Monoid m 706 | => ({ | OnPureScript (Rewrite e (Compose (Free Identity) (Const m))) } -> Rewrite e (Compose (Free Identity) (Const m)) g) 707 | -> { | OnPureScript (MonoidalRewrite e m) } 708 | -> MonoidalRewrite e m g 709 | monoidalRewrite traversal visitor g = do 710 | let visitor' = topDownMonoidalTraversal visitor 711 | un Const (runFree (un Identity) (un Compose ((traversal visitor') g))) 712 | 713 | foldMapModule :: forall e m. Monoid m => { | OnPureScript (MonoidalRewrite e m) } -> MonoidalRewrite e m Module 714 | foldMapModule = monoidalRewrite traverseModule 715 | 716 | foldMapBinder :: forall e m. Monoid m => { | OnPureScript (MonoidalRewrite e m) } -> MonoidalRewrite e m Binder 717 | foldMapBinder = monoidalRewrite _.onBinder 718 | 719 | foldMapDecl :: forall e m. Monoid m => { | OnPureScript (MonoidalRewrite e m) } -> MonoidalRewrite e m Declaration 720 | foldMapDecl = monoidalRewrite _.onDecl 721 | 722 | foldMapExpr :: forall e m. Monoid m => { | OnPureScript (MonoidalRewrite e m) } -> MonoidalRewrite e m Expr 723 | foldMapExpr = monoidalRewrite _.onExpr 724 | 725 | foldMapType :: forall e m. Monoid m => { | OnPureScript (MonoidalRewrite e m) } -> MonoidalRewrite e m Type 726 | foldMapType = monoidalRewrite _.onType 727 | 728 | bottomUpPureTraversal 729 | :: forall e 730 | . { | OnPureScript (PureRewrite e) } 731 | -> { | OnPureScript (Rewrite e (Free Identity)) } 732 | bottomUpPureTraversal visitor = visitor' 733 | where 734 | visitor' = 735 | { onBinder: \a -> pure <<< visitor.onBinder =<< traverseBinder visitor' a 736 | , onExpr: \a -> pure <<< visitor.onExpr =<< traverseExpr visitor' a 737 | , onType: \a -> pure <<< visitor.onType =<< traverseType visitor' a 738 | , onDecl: \a -> pure <<< visitor.onDecl =<< traverseDecl visitor' a 739 | } 740 | 741 | rewriteBottomUp 742 | :: forall e g 743 | . ({ | OnPureScript (Rewrite e (Free Identity)) } -> Rewrite e (Free Identity) g) 744 | -> { | OnPureScript (PureRewrite e) } 745 | -> PureRewrite e g 746 | rewriteBottomUp traversal visitor = do 747 | let visitor' = bottomUpPureTraversal visitor 748 | runFree (un Identity) <<< traversal visitor' 749 | 750 | rewriteModuleBottomUp :: forall e. { | OnPureScript (PureRewrite e) } -> PureRewrite e Module 751 | rewriteModuleBottomUp = rewriteBottomUp traverseModule 752 | 753 | rewriteBinderBottomUp :: forall e. { | OnPureScript (PureRewrite e) } -> PureRewrite e Binder 754 | rewriteBinderBottomUp = rewriteBottomUp _.onBinder 755 | 756 | rewriteExprBottomUp :: forall e. { | OnPureScript (PureRewrite e) } -> PureRewrite e Expr 757 | rewriteExprBottomUp = rewriteBottomUp _.onExpr 758 | 759 | rewriteDeclBottomUp :: forall e. { | OnPureScript (PureRewrite e) } -> PureRewrite e Declaration 760 | rewriteDeclBottomUp = rewriteBottomUp _.onDecl 761 | 762 | rewriteTypeBottomUp :: forall e. { | OnPureScript (PureRewrite e) } -> PureRewrite e Type 763 | rewriteTypeBottomUp = rewriteBottomUp _.onType 764 | 765 | topDownPureTraversal 766 | :: forall e 767 | . { | OnPureScript (PureRewrite e) } 768 | -> { | OnPureScript (Rewrite e (Free Identity)) } 769 | topDownPureTraversal visitor = visitor' 770 | where 771 | visitor' = 772 | { onBinder: \a -> pure (visitor.onBinder a) >>= traverseBinder visitor' 773 | , onExpr: \a -> pure (visitor.onExpr a) >>= traverseExpr visitor' 774 | , onType: \a -> pure (visitor.onType a) >>= traverseType visitor' 775 | , onDecl: \a -> pure (visitor.onDecl a) >>= traverseDecl visitor' 776 | } 777 | 778 | rewriteTopDown 779 | :: forall e g 780 | . ({ | OnPureScript (Rewrite e (Free Identity)) } -> Rewrite e (Free Identity) g) 781 | -> { | OnPureScript (PureRewrite e) } 782 | -> PureRewrite e g 783 | rewriteTopDown traversal visitor = do 784 | let visitor' = topDownPureTraversal visitor 785 | runFree (un Identity) <<< traversal visitor' 786 | 787 | rewriteModuleTopDown :: forall e. { | OnPureScript (PureRewrite e) } -> PureRewrite e Module 788 | rewriteModuleTopDown = rewriteTopDown traverseModule 789 | 790 | rewriteBinderTopDown :: forall e. { | OnPureScript (PureRewrite e) } -> PureRewrite e Binder 791 | rewriteBinderTopDown = rewriteTopDown _.onBinder 792 | 793 | rewriteExprTopDown :: forall e. { | OnPureScript (PureRewrite e) } -> PureRewrite e Expr 794 | rewriteExprTopDown = rewriteTopDown _.onExpr 795 | 796 | rewriteDeclTopDown :: forall e. { | OnPureScript (PureRewrite e) } -> PureRewrite e Declaration 797 | rewriteDeclTopDown = rewriteTopDown _.onDecl 798 | 799 | rewriteTypeTopDown :: forall e. { | OnPureScript (PureRewrite e) } -> PureRewrite e Type 800 | rewriteTypeTopDown = rewriteTopDown _.onType 801 | 802 | topDownTraversalWithContext 803 | :: forall c e 804 | . { | OnPureScript (PureRewriteWithContext c e) } 805 | -> { | OnPureScript (Rewrite e (ReaderT c Identity)) } 806 | topDownTraversalWithContext visitor = visitor' 807 | where 808 | visitor' = 809 | { onBinder: \a -> ReaderT \ctx -> pure (visitor.onBinder ctx a) >>= uncurry (flip (runReaderT <<< traverseBinder visitor')) 810 | , onExpr: \a -> ReaderT \ctx -> pure (visitor.onExpr ctx a) >>= uncurry (flip (runReaderT <<< traverseExpr visitor')) 811 | , onDecl: \a -> ReaderT \ctx -> pure (visitor.onDecl ctx a) >>= uncurry (flip (runReaderT <<< traverseDecl visitor')) 812 | , onType: \a -> ReaderT \ctx -> pure (visitor.onType ctx a) >>= uncurry (flip (runReaderT <<< traverseType visitor')) 813 | } 814 | 815 | rewriteWithContext 816 | :: forall c e g 817 | . ({ | OnPureScript (Rewrite e (ReaderT c Identity)) } -> Rewrite e (ReaderT c Identity) g) 818 | -> { | OnPureScript (PureRewriteWithContext c e) } 819 | -> PureRewriteWithContext c e g 820 | rewriteWithContext traversal visitor ctx g = do 821 | let visitor' = topDownTraversalWithContext visitor 822 | Tuple ctx (un Identity (runReaderT ((traversal visitor') g) ctx)) 823 | 824 | rewriteModuleWithContext :: forall c e. { | OnPureScript (PureRewriteWithContext c e) } -> PureRewriteWithContext c e Module 825 | rewriteModuleWithContext = rewriteWithContext traverseModule 826 | 827 | rewriteBinderWithContext :: forall c e. { | OnPureScript (PureRewriteWithContext c e) } -> PureRewriteWithContext c e Binder 828 | rewriteBinderWithContext = rewriteWithContext _.onBinder 829 | 830 | rewriteDeclWithContext :: forall c e. { | OnPureScript (PureRewriteWithContext c e) } -> PureRewriteWithContext c e Declaration 831 | rewriteDeclWithContext = rewriteWithContext _.onDecl 832 | 833 | rewriteExprWithContext :: forall c e. { | OnPureScript (PureRewriteWithContext c e) } -> PureRewriteWithContext c e Expr 834 | rewriteExprWithContext = rewriteWithContext _.onExpr 835 | 836 | rewriteTypeWithContext :: forall c e. { | OnPureScript (PureRewriteWithContext c e) } -> PureRewriteWithContext c e Type 837 | rewriteTypeWithContext = rewriteWithContext _.onType 838 | -------------------------------------------------------------------------------- /src/PureScript/CST/Types.purs: -------------------------------------------------------------------------------- 1 | module PureScript.CST.Types where 2 | 3 | import Prelude 4 | 5 | import Data.Array.NonEmpty (NonEmptyArray) 6 | import Data.Either (Either) 7 | import Data.Maybe (Maybe) 8 | import Data.Newtype (class Newtype) 9 | import Data.Tuple (Tuple) 10 | import Prim hiding (Row, Type) 11 | 12 | newtype ModuleName = ModuleName String 13 | 14 | derive newtype instance eqModuleName :: Eq ModuleName 15 | derive newtype instance ordModuleName :: Ord ModuleName 16 | derive instance newtypeModuleName :: Newtype ModuleName _ 17 | 18 | type SourcePos = 19 | { line :: Int 20 | , column :: Int 21 | } 22 | 23 | type SourceRange = 24 | { start :: SourcePos 25 | , end :: SourcePos 26 | } 27 | 28 | data Comment l 29 | = Comment String 30 | | Space Int 31 | | Line l Int 32 | 33 | data LineFeed 34 | = LF 35 | | CRLF 36 | 37 | data SourceStyle 38 | = ASCII 39 | | Unicode 40 | 41 | derive instance eqSourceStyle :: Eq SourceStyle 42 | 43 | data IntValue 44 | = SmallInt Int 45 | | BigInt String 46 | | BigHex String 47 | 48 | derive instance eqIntValue :: Eq IntValue 49 | 50 | data Token 51 | = TokLeftParen 52 | | TokRightParen 53 | | TokLeftBrace 54 | | TokRightBrace 55 | | TokLeftSquare 56 | | TokRightSquare 57 | | TokLeftArrow SourceStyle 58 | | TokRightArrow SourceStyle 59 | | TokRightFatArrow SourceStyle 60 | | TokDoubleColon SourceStyle 61 | | TokForall SourceStyle 62 | | TokEquals 63 | | TokPipe 64 | | TokTick 65 | | TokDot 66 | | TokComma 67 | | TokUnderscore 68 | | TokBackslash 69 | | TokAt 70 | | TokLowerName (Maybe ModuleName) String 71 | | TokUpperName (Maybe ModuleName) String 72 | | TokOperator (Maybe ModuleName) String 73 | | TokSymbolName (Maybe ModuleName) String 74 | | TokSymbolArrow SourceStyle 75 | | TokHole String 76 | | TokChar String Char 77 | | TokString String String 78 | | TokRawString String 79 | | TokInt String IntValue 80 | | TokNumber String Number 81 | | TokLayoutStart Int 82 | | TokLayoutSep Int 83 | | TokLayoutEnd Int 84 | 85 | derive instance eqToken :: Eq Token 86 | 87 | type SourceToken = 88 | { range :: SourceRange 89 | , leadingComments :: Array (Comment LineFeed) 90 | , trailingComments :: Array (Comment Void) 91 | , value :: Token 92 | } 93 | 94 | newtype Ident = Ident String 95 | 96 | derive newtype instance eqIdent :: Eq Ident 97 | derive newtype instance ordIdent :: Ord Ident 98 | derive instance newtypeIdent :: Newtype Ident _ 99 | 100 | newtype Proper = Proper String 101 | 102 | derive newtype instance eqProper :: Eq Proper 103 | derive newtype instance ordProper :: Ord Proper 104 | derive instance newtypeProper :: Newtype Proper _ 105 | 106 | newtype Label = Label String 107 | 108 | derive newtype instance eqLabel :: Eq Label 109 | derive newtype instance ordLabel :: Ord Label 110 | derive instance newtypeLabel :: Newtype Label _ 111 | 112 | newtype Operator = Operator String 113 | 114 | derive newtype instance eqOperator :: Eq Operator 115 | derive newtype instance ordOperator :: Ord Operator 116 | derive instance newtypeOperator :: Newtype Operator _ 117 | 118 | newtype Name a = Name 119 | { token :: SourceToken 120 | , name :: a 121 | } 122 | 123 | derive instance newtypeName :: Newtype (Name a) _ 124 | 125 | newtype QualifiedName a = QualifiedName 126 | { token :: SourceToken 127 | , module :: Maybe ModuleName 128 | , name :: a 129 | } 130 | 131 | derive instance newtypeQualifiedName :: Newtype (QualifiedName a) _ 132 | 133 | newtype Wrapped a = Wrapped 134 | { open :: SourceToken 135 | , value :: a 136 | , close :: SourceToken 137 | } 138 | 139 | derive instance newtypeWrapped :: Newtype (Wrapped a) _ 140 | 141 | newtype Separated a = Separated 142 | { head :: a 143 | , tail :: Array (Tuple SourceToken a) 144 | } 145 | 146 | derive instance newtypeSeparated :: Newtype (Separated a) _ 147 | 148 | newtype Labeled a b = Labeled 149 | { label :: a 150 | , separator :: SourceToken 151 | , value :: b 152 | } 153 | 154 | derive instance newtypeLabeled :: Newtype (Labeled a b) _ 155 | 156 | newtype Prefixed a = Prefixed 157 | { prefix :: Maybe SourceToken 158 | , value :: a 159 | } 160 | 161 | derive instance newtypePrefixed :: Newtype (Prefixed a) _ 162 | 163 | type Delimited a = Wrapped (Maybe (Separated a)) 164 | type DelimitedNonEmpty a = Wrapped (Separated a) 165 | 166 | data OneOrDelimited a 167 | = One a 168 | | Many (DelimitedNonEmpty a) 169 | 170 | data Type e 171 | = TypeVar (Name Ident) 172 | | TypeConstructor (QualifiedName Proper) 173 | | TypeWildcard SourceToken 174 | | TypeHole (Name Ident) 175 | | TypeString SourceToken String 176 | | TypeInt (Maybe SourceToken) SourceToken IntValue 177 | | TypeRow (Wrapped (Row e)) 178 | | TypeRecord (Wrapped (Row e)) 179 | | TypeForall SourceToken (NonEmptyArray (TypeVarBinding (Prefixed (Name Ident)) e)) SourceToken (Type e) 180 | | TypeKinded (Type e) SourceToken (Type e) 181 | | TypeApp (Type e) (NonEmptyArray (Type e)) 182 | | TypeOp (Type e) (NonEmptyArray (Tuple (QualifiedName Operator) (Type e))) 183 | | TypeOpName (QualifiedName Operator) 184 | | TypeArrow (Type e) SourceToken (Type e) 185 | | TypeArrowName SourceToken 186 | | TypeConstrained (Type e) SourceToken (Type e) 187 | | TypeParens (Wrapped (Type e)) 188 | | TypeError e 189 | 190 | data TypeVarBinding a e 191 | = TypeVarKinded (Wrapped (Labeled a (Type e))) 192 | | TypeVarName a 193 | 194 | newtype Row e = Row 195 | { labels :: Maybe (Separated (Labeled (Name Label) (Type e))) 196 | , tail :: Maybe (Tuple SourceToken (Type e)) 197 | } 198 | 199 | derive instance newtypeRow :: Newtype (Row e) _ 200 | 201 | newtype Module e = Module 202 | { header :: ModuleHeader e 203 | , body :: ModuleBody e 204 | } 205 | 206 | derive instance newtypeModule :: Newtype (Module e) _ 207 | 208 | newtype ModuleHeader e = ModuleHeader 209 | { keyword :: SourceToken 210 | , name :: Name ModuleName 211 | , exports :: Maybe (DelimitedNonEmpty (Export e)) 212 | , where :: SourceToken 213 | , imports :: Array (ImportDecl e) 214 | } 215 | 216 | derive instance newtypeModuleHeader :: Newtype (ModuleHeader e) _ 217 | 218 | newtype ModuleBody e = ModuleBody 219 | { decls :: Array (Declaration e) 220 | , trailingComments :: Array (Comment LineFeed) 221 | , end :: SourcePos 222 | } 223 | 224 | derive instance newtypeModuleBody :: Newtype (ModuleBody e) _ 225 | 226 | data Export e 227 | = ExportValue (Name Ident) 228 | | ExportOp (Name Operator) 229 | | ExportType (Name Proper) (Maybe DataMembers) 230 | | ExportTypeOp SourceToken (Name Operator) 231 | | ExportClass SourceToken (Name Proper) 232 | | ExportModule SourceToken (Name ModuleName) 233 | | ExportError e 234 | 235 | data DataMembers 236 | = DataAll SourceToken 237 | | DataEnumerated (Delimited (Name Proper)) 238 | 239 | data Declaration e 240 | = DeclData (DataHead e) (Maybe (Tuple SourceToken (Separated (DataCtor e)))) 241 | | DeclType (DataHead e) SourceToken (Type e) 242 | | DeclNewtype (DataHead e) SourceToken (Name Proper) (Type e) 243 | | DeclClass (ClassHead e) (Maybe (Tuple SourceToken (NonEmptyArray (Labeled (Name Ident) (Type e))))) 244 | | DeclInstanceChain (Separated (Instance e)) 245 | | DeclDerive SourceToken (Maybe SourceToken) (InstanceHead e) 246 | | DeclKindSignature SourceToken (Labeled (Name Proper) (Type e)) 247 | | DeclSignature (Labeled (Name Ident) (Type e)) 248 | | DeclValue (ValueBindingFields e) 249 | | DeclFixity FixityFields 250 | | DeclForeign SourceToken SourceToken (Foreign e) 251 | | DeclRole SourceToken SourceToken (Name Proper) (NonEmptyArray (Tuple SourceToken Role)) 252 | | DeclError e 253 | 254 | newtype Instance e = Instance 255 | { head :: InstanceHead e 256 | , body :: Maybe (Tuple SourceToken (NonEmptyArray (InstanceBinding e))) 257 | } 258 | 259 | derive instance newtypeInstance :: Newtype (Instance e) _ 260 | 261 | data InstanceBinding e 262 | = InstanceBindingSignature (Labeled (Name Ident) (Type e)) 263 | | InstanceBindingName (ValueBindingFields e) 264 | 265 | newtype ImportDecl e = ImportDecl 266 | { keyword :: SourceToken 267 | , module :: Name ModuleName 268 | , names :: Maybe (Tuple (Maybe SourceToken) (DelimitedNonEmpty (Import e))) 269 | , qualified :: Maybe (Tuple SourceToken (Name ModuleName)) 270 | } 271 | 272 | derive instance newtypeImportDecl :: Newtype (ImportDecl e) _ 273 | 274 | data Import e 275 | = ImportValue (Name Ident) 276 | | ImportOp (Name Operator) 277 | | ImportType (Name Proper) (Maybe DataMembers) 278 | | ImportTypeOp SourceToken (Name Operator) 279 | | ImportClass SourceToken (Name Proper) 280 | | ImportError e 281 | 282 | type DataHead e = 283 | { keyword :: SourceToken 284 | , name :: Name Proper 285 | , vars :: Array (TypeVarBinding (Name Ident) e) 286 | } 287 | 288 | newtype DataCtor e = DataCtor 289 | { name :: Name Proper 290 | , fields :: Array (Type e) 291 | } 292 | 293 | derive instance newtypeDataCtor :: Newtype (DataCtor e) _ 294 | 295 | type ClassHead e = 296 | { keyword :: SourceToken 297 | , super :: Maybe (Tuple (OneOrDelimited (Type e)) SourceToken) 298 | , name :: Name Proper 299 | , vars :: Array (TypeVarBinding (Name Ident) e) 300 | , fundeps :: Maybe (Tuple SourceToken (Separated ClassFundep)) 301 | } 302 | 303 | data ClassFundep 304 | = FundepDetermined SourceToken (NonEmptyArray (Name Ident)) 305 | | FundepDetermines (NonEmptyArray (Name Ident)) SourceToken (NonEmptyArray (Name Ident)) 306 | 307 | type InstanceHead e = 308 | { keyword :: SourceToken 309 | , name :: Maybe (Tuple (Name Ident) SourceToken) 310 | , constraints :: Maybe (Tuple (OneOrDelimited (Type e)) SourceToken) 311 | , className :: QualifiedName Proper 312 | , types :: Array (Type e) 313 | } 314 | 315 | data Fixity 316 | = Infix 317 | | Infixl 318 | | Infixr 319 | 320 | data FixityOp 321 | = FixityValue (QualifiedName (Either Ident Proper)) SourceToken (Name Operator) 322 | | FixityType SourceToken (QualifiedName Proper) SourceToken (Name Operator) 323 | 324 | type FixityFields = 325 | { keyword :: Tuple SourceToken Fixity 326 | , prec :: Tuple SourceToken Int 327 | , operator :: FixityOp 328 | } 329 | 330 | type ValueBindingFields e = 331 | { name :: Name Ident 332 | , binders :: Array (Binder e) 333 | , guarded :: Guarded e 334 | } 335 | 336 | data Guarded e 337 | = Unconditional SourceToken (Where e) 338 | | Guarded (NonEmptyArray (GuardedExpr e)) 339 | 340 | newtype GuardedExpr e = GuardedExpr 341 | { bar :: SourceToken 342 | , patterns :: Separated (PatternGuard e) 343 | , separator :: SourceToken 344 | , where :: Where e 345 | } 346 | 347 | derive instance newtypeGuardedExpr :: Newtype (GuardedExpr e) _ 348 | 349 | newtype PatternGuard e = PatternGuard 350 | { binder :: Maybe (Tuple (Binder e) SourceToken) 351 | , expr :: Expr e 352 | } 353 | 354 | derive instance newtypePatternGuard :: Newtype (PatternGuard e) _ 355 | 356 | data Foreign e 357 | = ForeignValue (Labeled (Name Ident) (Type e)) 358 | | ForeignData SourceToken (Labeled (Name Proper) (Type e)) 359 | | ForeignKind SourceToken (Name Proper) 360 | 361 | data Role 362 | = Nominal 363 | | Representational 364 | | Phantom 365 | 366 | data Expr e 367 | = ExprHole (Name Ident) 368 | | ExprSection SourceToken 369 | | ExprIdent (QualifiedName Ident) 370 | | ExprConstructor (QualifiedName Proper) 371 | | ExprBoolean SourceToken Boolean 372 | | ExprChar SourceToken Char 373 | | ExprString SourceToken String 374 | | ExprInt SourceToken IntValue 375 | | ExprNumber SourceToken Number 376 | | ExprArray (Delimited (Expr e)) 377 | | ExprRecord (Delimited (RecordLabeled (Expr e))) 378 | | ExprParens (Wrapped (Expr e)) 379 | | ExprTyped (Expr e) SourceToken (Type e) 380 | | ExprInfix (Expr e) (NonEmptyArray (Tuple (Wrapped (Expr e)) (Expr e))) 381 | | ExprOp (Expr e) (NonEmptyArray (Tuple (QualifiedName Operator) (Expr e))) 382 | | ExprOpName (QualifiedName Operator) 383 | | ExprNegate SourceToken (Expr e) 384 | | ExprRecordAccessor (RecordAccessor e) 385 | | ExprRecordUpdate (Expr e) (DelimitedNonEmpty (RecordUpdate e)) 386 | | ExprApp (Expr e) (NonEmptyArray (AppSpine Expr e)) 387 | | ExprLambda (Lambda e) 388 | | ExprIf (IfThenElse e) 389 | | ExprCase (CaseOf e) 390 | | ExprLet (LetIn e) 391 | | ExprDo (DoBlock e) 392 | | ExprAdo (AdoBlock e) 393 | | ExprError e 394 | 395 | data AppSpine f e 396 | = AppType SourceToken (Type e) 397 | | AppTerm (f e) 398 | 399 | data RecordLabeled a 400 | = RecordPun (Name Ident) 401 | | RecordField (Name Label) SourceToken a 402 | 403 | data RecordUpdate e 404 | = RecordUpdateLeaf (Name Label) SourceToken (Expr e) 405 | | RecordUpdateBranch (Name Label) (DelimitedNonEmpty (RecordUpdate e)) 406 | 407 | type RecordAccessor e = 408 | { expr :: Expr e 409 | , dot :: SourceToken 410 | , path :: Separated (Name Label) 411 | } 412 | 413 | type Lambda e = 414 | { symbol :: SourceToken 415 | , binders :: NonEmptyArray (Binder e) 416 | , arrow :: SourceToken 417 | , body :: Expr e 418 | } 419 | 420 | type IfThenElse e = 421 | { keyword :: SourceToken 422 | , cond :: Expr e 423 | , then :: SourceToken 424 | , true :: Expr e 425 | , else :: SourceToken 426 | , false :: Expr e 427 | } 428 | 429 | type CaseOf e = 430 | { keyword :: SourceToken 431 | , head :: Separated (Expr e) 432 | , of :: SourceToken 433 | , branches :: NonEmptyArray (Tuple (Separated (Binder e)) (Guarded e)) 434 | } 435 | 436 | type LetIn e = 437 | { keyword :: SourceToken 438 | , bindings :: NonEmptyArray (LetBinding e) 439 | , in :: SourceToken 440 | , body :: Expr e 441 | } 442 | 443 | newtype Where e = Where 444 | { expr :: Expr e 445 | , bindings :: Maybe (Tuple SourceToken (NonEmptyArray (LetBinding e))) 446 | } 447 | 448 | derive instance newtypeWhere :: Newtype (Where e) _ 449 | 450 | data LetBinding e 451 | = LetBindingSignature (Labeled (Name Ident) (Type e)) 452 | | LetBindingName (ValueBindingFields e) 453 | | LetBindingPattern (Binder e) SourceToken (Where e) 454 | | LetBindingError e 455 | 456 | type DoBlock e = 457 | { keyword :: SourceToken 458 | , statements :: NonEmptyArray (DoStatement e) 459 | } 460 | 461 | data DoStatement e 462 | = DoLet SourceToken (NonEmptyArray (LetBinding e)) 463 | | DoDiscard (Expr e) 464 | | DoBind (Binder e) SourceToken (Expr e) 465 | | DoError e 466 | 467 | type AdoBlock e = 468 | { keyword :: SourceToken 469 | , statements :: Array (DoStatement e) 470 | , in :: SourceToken 471 | , result :: Expr e 472 | } 473 | 474 | data Binder e 475 | = BinderWildcard SourceToken 476 | | BinderVar (Name Ident) 477 | | BinderNamed (Name Ident) SourceToken (Binder e) 478 | | BinderConstructor (QualifiedName Proper) (Array (Binder e)) 479 | | BinderBoolean SourceToken Boolean 480 | | BinderChar SourceToken Char 481 | | BinderString SourceToken String 482 | | BinderInt (Maybe SourceToken) SourceToken IntValue 483 | | BinderNumber (Maybe SourceToken) SourceToken Number 484 | | BinderArray (Delimited (Binder e)) 485 | | BinderRecord (Delimited (RecordLabeled (Binder e))) 486 | | BinderParens (Wrapped (Binder e)) 487 | | BinderTyped (Binder e) SourceToken (Type e) 488 | | BinderOp (Binder e) (NonEmptyArray (Tuple (QualifiedName Operator) (Binder e))) 489 | | BinderError e 490 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main (main) where 2 | 3 | import Prelude 4 | import Prim hiding (Type) 5 | 6 | import Data.Array as Array 7 | import Data.Array.NonEmpty as NonEmptyArray 8 | import Data.Maybe (Maybe(..), maybe) 9 | import Data.String (Pattern(..)) 10 | import Data.String as String 11 | import Data.String.CodeUnits as SCU 12 | import Effect (Effect) 13 | import Effect.Class.Console as Console 14 | import Node.Process as Process 15 | import PureScript.CST (RecoveredParserResult(..), parseBinder, parseDecl, parseExpr, parseModule, parseType) 16 | import PureScript.CST.Types (AppSpine(..), Binder, Comment(..), Declaration(..), DoStatement(..), Expr(..), Label(..), Labeled(..), LetBinding(..), LineFeed(..), Module(..), ModuleBody(..), ModuleHeader(..), Name(..), Prefixed(..), RecordLabeled(..), Separated(..), Token(..), Type(..), TypeVarBinding(..), Wrapped(..)) 17 | 18 | class ParseFor f where 19 | parseFor :: String -> RecoveredParserResult f 20 | 21 | instance ParseFor Module where 22 | parseFor = parseModule 23 | 24 | instance ParseFor Declaration where 25 | parseFor = parseDecl 26 | 27 | instance ParseFor Expr where 28 | parseFor = parseExpr 29 | 30 | instance ParseFor Type where 31 | parseFor = parseType 32 | 33 | instance ParseFor Binder where 34 | parseFor = parseBinder 35 | 36 | assertParse 37 | :: forall f 38 | . ParseFor f 39 | => String 40 | -> String 41 | -> (RecoveredParserResult f -> Boolean) 42 | -> Effect Unit 43 | assertParse name src k = do 44 | let res = parseFor (trim src) 45 | unless (k res) do 46 | Console.error $ "Assertion failed: " <> name 47 | Process.exit' 1 48 | where 49 | trim = 50 | String.split (Pattern "\n") 51 | >>> Array.dropWhile String.null 52 | >>> Array.uncons 53 | >>> maybe [] 54 | ( \{ head, tail } -> do 55 | let leadingSpaces = SCU.takeWhile (eq ' ') head 56 | let trimLine = SCU.drop (SCU.length leadingSpaces) 57 | Array.cons (trimLine head) (trimLine <$> tail) 58 | ) 59 | >>> String.joinWith "\n" 60 | 61 | main :: Effect Unit 62 | main = do 63 | assertParse "Recovered do statements" 64 | """ 65 | do 66 | foo <- bar 67 | a b c + 68 | foo 69 | """ 70 | case _ of 71 | ParseSucceededWithErrors (ExprDo { statements }) _ 72 | | [ DoBind _ _ _ 73 | , DoError _ 74 | , DoDiscard _ 75 | ] <- NonEmptyArray.toArray statements -> 76 | true 77 | _ -> 78 | false 79 | 80 | assertParse "Recovered ado statements" 81 | """ 82 | ado 83 | foo <- bar 84 | a b c + 85 | foo 86 | in 5 87 | """ 88 | case _ of 89 | ParseSucceededWithErrors (ExprAdo { statements }) _ 90 | | [ DoBind _ _ _ 91 | , DoError _ 92 | , DoDiscard _ 93 | ] <- statements -> 94 | true 95 | _ -> 96 | false 97 | 98 | assertParse "Recovered ado last statement" 99 | """ 100 | ado 101 | foo <- bar 102 | a b c + 103 | in 5 104 | """ 105 | case _ of 106 | ParseSucceededWithErrors (ExprAdo { statements }) _ 107 | | [ DoBind _ _ _ 108 | , DoError _ 109 | ] <- statements -> 110 | true 111 | _ -> 112 | false 113 | 114 | assertParse "Recovered ado first statement" 115 | """ 116 | ado 117 | a b c + 118 | foo <- bar 119 | in 5 120 | """ 121 | case _ of 122 | ParseSucceededWithErrors (ExprAdo { statements }) _ 123 | | [ DoError _ 124 | , DoBind _ _ _ 125 | ] <- statements -> 126 | true 127 | _ -> 128 | false 129 | 130 | assertParse "Empty ado in" 131 | """ 132 | ado in 1 133 | """ 134 | case _ of 135 | (ParseSucceeded _ :: RecoveredParserResult Expr) -> 136 | true 137 | _ -> 138 | false 139 | 140 | assertParse "Empty ado \\n in" 141 | """ 142 | ado 143 | in 1 144 | """ 145 | case _ of 146 | (ParseSucceeded _ :: RecoveredParserResult Expr) -> 147 | true 148 | _ -> 149 | false 150 | 151 | assertParse "Recovered let bindings" 152 | """ 153 | let 154 | a = b c + 155 | b = 42 156 | in 157 | a + b 158 | """ 159 | case _ of 160 | ParseSucceededWithErrors (ExprLet { bindings }) _ 161 | | [ LetBindingError _ 162 | , LetBindingName _ 163 | ] <- NonEmptyArray.toArray bindings -> 164 | true 165 | _ -> 166 | false 167 | 168 | assertParse "Recovered declarations" 169 | """ 170 | module Foo where 171 | a = 42 172 | {} 173 | b = 12 174 | """ 175 | case _ of 176 | ParseSucceededWithErrors (Module { body: ModuleBody { decls } }) _ 177 | | [ DeclValue _ 178 | , DeclError _ 179 | , DeclValue _ 180 | ] <- decls -> 181 | true 182 | _ -> 183 | false 184 | 185 | assertParse "Failed mismatched parens" 186 | """ 187 | wat (bad 188 | """ 189 | case _ of 190 | (ParseFailed _ :: RecoveredParserResult Expr) -> 191 | true 192 | _ -> 193 | false 194 | 195 | assertParse "Records with raw string labels" 196 | "{ \"\"\"key\"\"\": val }" 197 | case _ of 198 | ParseSucceeded 199 | ( ExprRecord 200 | ( Wrapped 201 | { value: Just 202 | ( Separated 203 | { head: RecordField 204 | ( Name 205 | { name: Label "key", token: { value: TokRawString "key" } } 206 | ) 207 | _ 208 | _ 209 | } 210 | ) 211 | } 212 | ) 213 | ) 214 | -> 215 | true 216 | _ -> 217 | false 218 | 219 | assertParse "Negative type-level integers" 220 | """ 221 | cons 222 | :: forall len len_plus_1 elem 223 | . Add 1 len len_plus_1 224 | => Compare len (-1) GT 225 | => elem 226 | -> Vect len elem 227 | -> Vect len_plus_1 elem 228 | cons elem (Vect arr) = Vect (A.cons elem arr) 229 | """ 230 | case _ of 231 | (ParseSucceeded _ :: RecoveredParserResult Declaration) -> 232 | true 233 | _ -> 234 | false 235 | 236 | assertParse "String with Unicode astral code point hex literal" 237 | """ 238 | "\x10ffff" 239 | """ 240 | case _ of 241 | ParseSucceeded (ExprString _ _) -> 242 | true 243 | _ -> 244 | false 245 | 246 | assertParse "Unicode astral code point Char hex literal" 247 | """ 248 | '\x10ffff' 249 | """ 250 | case _ of 251 | (ParseFailed _ :: RecoveredParserResult Expr) -> 252 | true 253 | _ -> 254 | false 255 | 256 | assertParse "Type applications" 257 | """ 258 | foo @Bar bar @(Baz 42) 42 259 | """ 260 | case _ of 261 | (ParseSucceeded (ExprApp _ apps)) 262 | | [ AppType _ _ 263 | , AppTerm _ 264 | , AppType _ _ 265 | , AppTerm _ 266 | ] <- NonEmptyArray.toArray apps -> 267 | true 268 | _ -> 269 | false 270 | 271 | assertParse "Forall visibility" 272 | """ 273 | forall @a (@b :: Type) c. a -> c 274 | """ 275 | case _ of 276 | ParseSucceeded (TypeForall _ binders _ _) 277 | | [ TypeVarName (Prefixed { prefix: Just _ }) 278 | , TypeVarKinded (Wrapped { value: Labeled { label: Prefixed { prefix: Just _ } } }) 279 | , TypeVarName (Prefixed { prefix: Nothing }) 280 | ] <- NonEmptyArray.toArray binders -> 281 | true 282 | _ -> 283 | false 284 | 285 | assertParse "Kind applications not supported" 286 | """ 287 | Foo @Bar 288 | """ 289 | case _ of 290 | ParseSucceeded (TypeConstructor _) -> 291 | true 292 | _ -> 293 | false 294 | 295 | assertParse "No module shebang" 296 | """ 297 | -- no shebang 298 | module Test where 299 | """ 300 | case _ of 301 | ParseSucceeded (Module { header: ModuleHeader { keyword } }) 302 | | [ Comment "-- no shebang" 303 | , Line LF 1 304 | ] <- keyword.leadingComments -> 305 | true 306 | _ -> 307 | false 308 | 309 | assertParse "Module shebang" 310 | """ 311 | #! shebang 312 | module Test where 313 | """ 314 | case _ of 315 | ParseSucceeded (Module { header: ModuleHeader { keyword } }) 316 | | [ Comment "#! shebang" 317 | , Line LF 1 318 | ] <- keyword.leadingComments -> 319 | true 320 | _ -> 321 | false 322 | 323 | assertParse "Multiple module shebangs" 324 | """ 325 | #! shebang 1 326 | #! shebang 2 327 | #! shebang 3 328 | -- no shebang 329 | module Test where 330 | """ 331 | case _ of 332 | ParseSucceeded (Module { header: ModuleHeader { keyword } }) 333 | | [ Comment "#! shebang 1" 334 | , Line LF 1 335 | , Comment "#! shebang 2" 336 | , Line LF 1 337 | , Comment "#! shebang 3" 338 | , Line LF 1 339 | , Comment "-- no shebang" 340 | , Line LF 1 341 | ] <- keyword.leadingComments -> 342 | true 343 | _ -> 344 | false 345 | 346 | assertParse "Multiple lines between shebangs should fail" 347 | """ 348 | #! shebang 1 349 | 350 | #! shebang 2 351 | #! shebang 3 352 | module Test where 353 | """ 354 | case _ of 355 | (ParseFailed _ :: RecoveredParserResult Module) -> 356 | true 357 | _ -> 358 | false 359 | 360 | assertParse "Comments between shebangs should fail" 361 | """ 362 | #! shebang 1 363 | -- no shebang 364 | #! shebang 2 365 | #! shebang 3 366 | module Test where 367 | """ 368 | case _ of 369 | (ParseFailed _ :: RecoveredParserResult Module) -> 370 | true 371 | _ -> 372 | false 373 | 374 | assertParse "Indented module" 375 | """ 376 | module Test where 377 | test = 42 378 | """ 379 | case _ of 380 | ParseSucceeded (Module _) -> 381 | true 382 | _ -> 383 | false 384 | --------------------------------------------------------------------------------