├── .ghcid ├── Setup.hs ├── plugin ├── RecordDotPreprocessor │ └── Lib.hs ├── Compat.hs └── RecordDotPreprocessor.hs ├── .gitignore ├── .ghci ├── travis.hs ├── PULL_REQUEST_TEMPLATE.md ├── examples ├── Readme.hs ├── Both2.hs ├── Header_in.hs ├── Preprocessor.hs └── Both.hs ├── test ├── PluginExample.hs └── Test.hs ├── preprocessor ├── Preprocessor.hs ├── Paren.hs ├── Lexer.hs └── Edit.hs ├── .github └── workflows │ └── ci.yml ├── CHANGES.txt ├── proposal ├── alternatives.md └── 0000-record-dot-syntax.md ├── record-dot-preprocessor.cabal ├── README.md └── LICENSE /.ghcid: -------------------------------------------------------------------------------- 1 | --test=:test 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /plugin/RecordDotPreprocessor/Lib.hs: -------------------------------------------------------------------------------- 1 | module RecordDotPreprocessor.Lib (module X) where 2 | 3 | import Edit as X 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /dist-newstyle/ 3 | /.hpc/ 4 | .stack-work/ 5 | stack.yaml 6 | stack.yaml.lock 7 | examples/*_out.hs 8 | *.hi 9 | *.o 10 | .envrc 11 | .ghc.environment.* 12 | -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -Wunused-binds -Wunused-imports -Worphans 2 | :set -ipreprocessor -iplugin -itest 3 | :set -package=ghc 4 | :set -hide-package=ghc-lib-parser 5 | :load test/Test.hs 6 | :def test \x -> pure $ ":main " ++ x 7 | -------------------------------------------------------------------------------- /travis.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Monad 3 | import Data.List 4 | import System.Exit 5 | import System.Process.Extra 6 | 7 | main = do 8 | system_ "chmod go-w .ghci" 9 | system_ "chmod go-w ." 10 | (code, xs) <- systemOutput "ghc -e \":test --installed\"" 11 | putStrLn xs 12 | when (code /= ExitSuccess || not ("Success" `isInfixOf` xs)) $ 13 | putStrLn "Running the test did not succeed" 14 | -------------------------------------------------------------------------------- /PULL_REQUEST_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | Thanks for the pull request! 2 | 3 | By raising this pull request you confirm you are licensing your contribution under all licenses that apply to this project (see LICENSE) and that you have no patents covering your contribution. 4 | 5 | If you care, my PR preferences are at https://github.com/ndmitchell/neil#contributions, but they're all guidelines, and I'm not too fussy - you don't have to read them. 6 | -------------------------------------------------------------------------------- /examples/Readme.hs: -------------------------------------------------------------------------------- 1 | -- This is the example from README.md to test 2 | 3 | data Company = Company {name :: String, owner :: Person} 4 | data Person = Person {name :: String, age :: Int} 5 | 6 | display :: Company -> String 7 | display c = c.name ++ " is run by " ++ c.owner.name 8 | 9 | nameAfterOwner :: Company -> Company 10 | nameAfterOwner c = c{name = c.owner.name ++ "'s Company"} 11 | 12 | main :: IO () 13 | main = putStrLn $ display $ nameAfterOwner c 14 | where c = Company "A" $ Person "B" 3 15 | -------------------------------------------------------------------------------- /examples/Both2.hs: -------------------------------------------------------------------------------- 1 | -- Test DuplicateRecordFields extension 2 | 3 | main :: IO () 4 | main = test1 >> putStrLn "All worked" 5 | 6 | (===) :: (Show a, Eq a) => a -> a -> IO () 7 | a === b = if a == b then pure () else fail $ "Mismatch, " ++ show a ++ " /= " ++ show b 8 | 9 | 10 | --------------------------------------------------------------------- 11 | -- CHECK DUPLICATE NAMES WORK 12 | 13 | data Foo = Foo {id :: String} deriving (Show, Eq) 14 | 15 | test1 :: IO () 16 | test1 = do 17 | (Foo "test").id === "test" 18 | (Foo "test"){id = "bar"} === Foo "bar" 19 | map (.id) [Foo "test"] === ["test"] 20 | -------------------------------------------------------------------------------- /test/PluginExample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | #if __GLASGOW_HASKELL__ < 806 5 | 6 | module PluginExample where 7 | main :: IO () 8 | main = pure () 9 | 10 | #elif mingw32_HOST_OS 11 | 12 | module PluginExample where 13 | import RecordDotPreprocessor() -- To check the plugin compiles 14 | main :: IO () 15 | main = pure () 16 | 17 | #else 18 | 19 | {-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} 20 | 21 | #include "../examples/Header_in.hs" 22 | 23 | module PluginExample where 24 | 25 | #include "../examples/Both.hs" 26 | 27 | data PolyField = PolyField 28 | { polyField :: forall a. a -> IO () 29 | } 30 | 31 | data PolyGieldGADTs where 32 | PolyFieldGADTs :: { a' :: forall a. a } -> PolyGieldGADTs 33 | 34 | #endif 35 | -------------------------------------------------------------------------------- /preprocessor/Preprocessor.hs: -------------------------------------------------------------------------------- 1 | 2 | module Preprocessor(main) where 3 | 4 | import Edit 5 | import System.IO.Extra 6 | import System.Environment 7 | 8 | 9 | -- GHC calls me with: original input output 10 | -- Test calls me with: --test directory 11 | -- Users call me with: input 12 | main :: IO () 13 | main = do 14 | args <- getArgs 15 | case args of 16 | original:input:output:_ -> runConvert original input output 17 | input:output:_ -> runConvert input input output 18 | input:_ -> runConvert input input "-" 19 | [] -> putStrLn "record-dot-preprocess [FILE-TO-CONVERT]" 20 | 21 | 22 | runConvert :: FilePath -> FilePath -> FilePath -> IO () 23 | runConvert original input output = do 24 | res <- recordDotPreprocessor original <$> readFileUTF8' input 25 | if output == "-" then putStrLn res else writeFileUTF8 output res 26 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: ci 2 | on: 3 | push: 4 | pull_request: 5 | schedule: 6 | - cron: '0 3 * * 6' # 3am Saturday 7 | jobs: 8 | test: 9 | runs-on: ${{ matrix.os }} 10 | 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | os: [ubuntu-latest] 15 | ghc: ['9.8', '9.6', '9.4', '9.2', '9.0', '8.10', '8.8'] 16 | # It sometimes works a bit Windows, but not very robustly, 17 | # and not in CI - so exclude it 18 | include: 19 | - os: macOS-latest 20 | ghc: "8.10" 21 | 22 | steps: 23 | - run: git config --global core.autocrlf false 24 | - uses: actions/checkout@v2 25 | - uses: haskell/actions/setup@v2 26 | id: setup-haskell 27 | with: 28 | ghc-version: ${{ matrix.ghc }} 29 | - run: cabal v2-freeze --enable-tests 30 | - uses: actions/cache@v2 31 | with: 32 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 33 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 34 | restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- 35 | - uses: ndmitchell/neil@master 36 | with: 37 | hlint-arguments: preprocessor plugin 38 | -------------------------------------------------------------------------------- /examples/Header_in.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE PartialTypeSignatures #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE TypeSynonymInstances #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | 19 | {-# OPTIONS_GHC -Wall #-} 20 | 21 | {-# OPTIONS_GHC -Werror #-} 22 | {-# OPTIONS_GHC -Wincomplete-record-updates #-} 23 | {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} 24 | {-# OPTIONS_GHC -Wno-partial-type-signatures #-} 25 | {-# OPTIONS_GHC -Wno-type-defaults #-} 26 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 27 | 28 | #if __GLASGOW_HASKELL__ >= 902 29 | {-# OPTIONS_GHC -Wno-ambiguous-fields #-} 30 | #endif 31 | -------------------------------------------------------------------------------- /preprocessor/Paren.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, DeriveFunctor #-} 2 | 3 | -- Most of this module follows the Haskell report, https://www.haskell.org/onlinereport/lexemes.html 4 | module Paren(Paren(..), parens, unparens) where 5 | 6 | import Data.Tuple.Extra 7 | import Lexer(Lexeme(..)) 8 | 9 | -- | A list of items which are paranthesised. 10 | data Paren a 11 | = Item a -- Indiviaaul item 12 | | Paren a [Paren a] a -- parenthesise, open, inner, close 13 | deriving (Show,Eq,Functor) 14 | 15 | parenOn :: forall a b . Eq b => (a -> b) -> [(b, b)] -> [a] -> [Paren a] 16 | parenOn proj pairs = fst . go Nothing 17 | where 18 | -- invariant: if first argument is Nothing, second component of result will be Nothing 19 | go :: Maybe b -> [a] -> ([Paren a], Maybe (a, [a])) 20 | go (Just close) (x:xs) | close == proj x = ([], Just (x, xs)) 21 | go close (start:xs) 22 | | Just end <- lookup (proj start) pairs 23 | , (inner, res) <- go (Just end) xs 24 | = case res of 25 | Nothing -> (Item start : inner, Nothing) 26 | Just (end, xs) -> first (Paren start inner end :) $ go close xs 27 | go close (x:xs) = first (Item x :) $ go close xs 28 | go close [] = ([], Nothing) 29 | 30 | parens :: [Lexeme] -> [Paren Lexeme] 31 | parens = parenOn lexeme [("(",")"),("[","]"),("{","}"),("`","`")] 32 | 33 | unparens :: [Paren a] -> [a] 34 | unparens = concatMap unparen 35 | 36 | unparen :: Paren a -> [a] 37 | unparen (Item x) = [x] 38 | unparen (Paren a b c) = [a] ++ unparens b ++ [c] 39 | -------------------------------------------------------------------------------- /examples/Preprocessor.hs: -------------------------------------------------------------------------------- 1 | -- Test for things only supported by the preprocessor 2 | 3 | 4 | import Data.Function 5 | import Data.Char 6 | import Data.List 7 | 8 | 9 | (===) :: (Show a, Eq a) => a -> a -> IO () 10 | a === b = if a == b then pure () else fail $ "Mismatch, " ++ show a ++ " /= " ++ show b 11 | 12 | 13 | -- can you deal with multiple alternatives 14 | data Animal = Human {name :: !String, job :: Prelude.String} 15 | | Nonhuman {name :: String} 16 | deriving (Show,Eq) 17 | 18 | -- can you deal with polymorphism 19 | data Foo a b = Foo {name :: (a, Maybe b), the_b :: b, x :: Int} 20 | deriving (Show,Eq) 21 | 22 | data Person = Person {age :: Int, address :: String} 23 | deriving (Show,Eq) 24 | 25 | test1 :: IO () 26 | test1 = do 27 | let foo1 = Foo{name=(1, Nothing), the_b=Human "a" "b", x=1} 28 | let foo2 = Foo (19, Just 2) 2 1 29 | foo1.the_b.job === "b" 30 | foo2.name._1 === 19 31 | foo2.x === 1 32 | 33 | -- check complex updates 34 | foo2{the_b = 8}.the_b === 8 35 | foo1{the_b.job = "c"} === foo1{the_b = foo1.the_b{job = "c"}} 36 | foo1.the_b{job ++ "b"} === (foo1.the_b){job = "bb"} 37 | foo1{the_b.job ++ "b", the_b.name = "q"} === foo1{the_b = Human "q" "bb"} 38 | foo1{the_b.job `union` "qbz"} === foo1{the_b = Human "a" "bqz"} 39 | 40 | -- check updates are ordered correctly 41 | foo1{the_b = Human "x" "y", the_b.job="z"} === foo1{the_b = Human "x" "z"} 42 | 43 | -- check for nesting 44 | (foo1.the_b).job === "b" 45 | foo1{the_b = foo1.the_b{job="r"}}.the_b.job === "r" 46 | (foo1{the_b.job="n"}){the_b.name="m"}.the_b === Human "m" "n" 47 | let foo11 = (foo1, foo1) 48 | foo11._1.the_b{job="n"} === Human "a" "n" 49 | 50 | let person = Person 10 "Home" 51 | (person{age - 3}){age * 2} === person{age = 14} 52 | 53 | -- check for puns 54 | let human = Human "x" "y" 55 | human{foo1.the_b.job} === Human "x" "b" 56 | human{foo1.the_b.job, name & map toUpper} === Human "X" "b" 57 | 58 | 59 | main :: IO () 60 | main = test1 >> putStrLn "Preprocessor worked" 61 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | module Test(main) where 2 | 3 | import qualified Preprocessor 4 | import qualified PluginExample -- To test the plugin 5 | import GHC.Records.Extra() -- To ensure the runtime dependency is present 6 | 7 | import System.Directory.Extra 8 | import System.Environment 9 | import System.FilePath 10 | import Control.Monad 11 | import System.IO.Extra 12 | import System.Info 13 | import System.Process.Extra 14 | import Data.List 15 | import Data.Version 16 | 17 | 18 | main :: IO () 19 | main = do 20 | -- TODO: If you pass `--installed` should create temp files with the magic string in front 21 | args <- getArgs 22 | files <- listFiles "examples" 23 | header <- readFile "examples/Header_in.hs" 24 | let installed = "--installed" `elem` args 25 | unless installed $ do 26 | putStrLn "# PluginExample.hs" 27 | PluginExample.main 28 | forM_ (reverse files) $ \file -> 29 | when (takeExtension file == ".hs" && not ("_out.hs" `isSuffixOf` file) && not ("_in.hs" `isSuffixOf` file)) $ do 30 | src <- readFile' file 31 | if installed then do 32 | forM_ [("Preprocessor", "{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-}") 33 | ,("Plugin", "{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}") 34 | ] $ 35 | \(name,prefix) -> withTempDir $ \dir -> 36 | when (compilerVersion >= makeVersion [8,6] && not (blacklist name (takeBaseName file))) $ do 37 | let inp = dir takeFileName file 38 | putStrLn $ "# " ++ name ++ " " ++ takeFileName file 39 | writeFile inp $ prefix ++ "\n" ++ header ++ "\nmodule Main where\n" ++ src 40 | system_ $ "runhaskell -package=record-dot-preprocessor " ++ inp 41 | else withTempDir $ \dir -> do 42 | let inp = dir takeFileName file 43 | let out = dropExtension file ++ "_out.hs" 44 | writeFile inp $ header ++ "\n" ++ "module Main where\n" ++ src 45 | putStrLn $ "# Preprocessor " ++ takeFileName file 46 | withArgs [file,inp,out] Preprocessor.main 47 | system_ $ "runhaskell " ++ out 48 | putStrLn "Success" 49 | 50 | -- Blacklist tests we know aren't compatible 51 | blacklist "Plugin" "Preprocessor" = True 52 | blacklist "Plugin" "Both2" = True 53 | blacklist _ _ = False 54 | -------------------------------------------------------------------------------- /CHANGES.txt: -------------------------------------------------------------------------------- 1 | Changelog for record-dot-preprocessor 2 | 3 | 0.2.17, released 2024-01-13 4 | Support GHC 9.8 5 | #59, support GHC 9.6 6 | 0.2.16, released 2023-03-03 7 | #57, support GHC 9.4 8 | #54, skip polymorphic fields with forall 9 | #52, properly deal with nested block comments 10 | 0.2.15, released 2022-07-09 11 | #50, support GHC 9.2 12 | #50, add ghc version bounds 13 | 0.2.14, released 2022-02-11 14 | #48, do not derive HasField for existentials 15 | 0.2.13, released 2021-11-03 16 | #46, make sure [a|b/|] gets treated as quasi quotes 17 | 0.2.12, released 2021-09-01 18 | #45, re-export preprocessor internals as library 19 | 0.2.11, released 2021-05-28 20 | #41, use qualified names in the plugin 21 | 0.2.10, released 2021-03-01 22 | #40, compatibility with qualified QuasiQuotes 23 | Emit LINE pragmas slightly earlier in some cases 24 | #37, do a better job at HLint clean 25 | 0.2.9, released 2021-02-27 26 | #37, make the output HLint clean 27 | Don't add the OverloadedLabels extension 28 | 0.2.8, released 2021-02-21 29 | Support GHC 9.0 30 | #38, make the preprocessor avoid quasi quotes 31 | 0.2.7, released 2020-10-02 32 | #29, deal with records containing type families in field types 33 | 0.2.6, released 2020-08-12 34 | #30, don't warn about incomplete record updates 35 | #31, allow fields to have names that clash with functions 36 | 0.2.5, released 2020-05-06 37 | #28, deal with kind signatures on data types 38 | 0.2.4, released 2020-05-04 39 | #3, emit more LINE declarations 40 | 0.2.3, released 2020-04-01 41 | Support GHC 8.10 42 | 0.2.2, released 2019-12-08 43 | #26, make a {b=c} not desugar to setField 44 | 0.2.1, released 2019-11-02 45 | #25, support promoted data kinds, e.g. 'Int 46 | #12, support more things around GADTs 47 | Make sure the plugin errors on update{} 48 | 0.2, released 2019-03-29 49 | Add a GHC source plugin 50 | Support for e{foo.bar} 51 | Support for (.foo.bar) 52 | a.b{c=d} now equivalent to (a.b){c=d}, previously was a{b.c=d} 53 | 0.1.5, released 2019-02-09 54 | #10, support fields named 'x' 55 | 0.1.4, released 2018-09-07 56 | Licensed under BSD-3-Clause OR Apache-2.0 57 | 0.1.3, released 2018-07-26 58 | Give a unique name to each _preprocessor_unused 59 | 0.1.2, released 2018-07-26 60 | Make qualified types in records work 61 | Add LINE droppings to get approximate line numbers correct 62 | Don't depend on anything not imported from Control.Lens 63 | 0.1.1, released 2018-05-09 64 | Handle - as an update operator 65 | Be compatible with qualified imports 66 | 0.1, released 2018-05-06 67 | Initial version 68 | -------------------------------------------------------------------------------- /proposal/alternatives.md: -------------------------------------------------------------------------------- 1 | # Scheme 1 2 | Naked `.lbl` is illegal. 3 | 4 | ## Lexer 5 | 6 | A new lexeme *fieldid* is introduced. 7 |
8 |
*lexeme* → *qvarid* | *qconid* | *qvarsym* | *qconsym* 9 | | *literal* | *special* | *reservedop* | *reservedid* | *fieldid* 10 |
*fieldid* → *.varid{.varid}* 11 | 12 | ## Parser 13 | 14 | #### Field selections 15 | 16 | To support field selection the *fexp* production is extended. 17 |
18 |
*fexp* → [ *fexp* ] *aexp* | *fexp* *fieldid* 19 | 20 | #### Field updates 21 | 22 | To support field update, the *aexp* production is extended. 23 |
24 |
*aexp* → *aexp⟨qcon⟩* { *pbind* , … , *pbind* } 25 |
*pbind* -> *qvar*=*exp* | *var* *fieldid*=*exp* 26 | 27 | ### Sections 28 | 29 | To support sections (e.g. `(.foo.bar.baz)`), we generalize *aexp*. 30 |
31 |
*aexp* → ( *infixexp* *qop* ) (left section) 32 | | ( *qop* *infixexp* ) (right section) 33 | | ( *fieldid* ) (projection (right) section) 34 | 35 | # Scheme 2 36 | Naked `.lbl` means `(\x -> x.lbl)`. 37 | 38 | ## Lexer 39 | 40 | A new lexeme *fieldid* is introduced. 41 |
42 |
*lexeme* → *qvarid* | *qconid* | *qvarsym* | *qconsym* 43 | | *literal* | *special* | *reservedop* | *reservedid* | *fieldid* 44 |
*fieldid* → *.varid{.varid}* 45 | 46 | ## Parser 47 | 48 | ### Sections 49 | 50 | To support sections (e.g. `.foo.bar.baz`), we generalize *aexp*. 51 |
52 |
*aexp* → *fieldid* 53 | 54 | ## Field selections 55 | 56 | To support field selections, the existing production *fexp* → *[fexp]* *aexp* is sufficient. 57 | 58 | ### Field updates 59 | 60 | To support field updates, the *aexp* production is extended. 61 |
62 |
*aexp* → *aexp⟨qcon⟩* { *pbind* , … , *pbind* } 63 |
*pbind* -> *qvar*=*exp* | *var* *aexp*=*exp* 64 | 65 | # Scheme 3 66 | Naked `.lbl` is allowed in a function application. 67 | 68 | ## Lexer 69 | 70 | A new lexeme *fieldid* is introduced. 71 |
72 |
*lexeme* → *qvarid* | *qconid* | *qvarsym* | *qconsym* 73 | | *literal* | *special* | *reservedop* | *reservedid* | *fieldid* 74 |
*fieldid* → *.varid* 75 | 76 | ## Parser 77 | 78 | ### Field selections 79 | 80 | To support field selection the *fexp* production is extended. 81 |
82 |
*fexp* → [ *fexp* ] *aexp* | *fexp* *fieldid* 83 | 84 | ### Field updates 85 | 86 | To support field update, the *aexp* production is extended. 87 |
88 |
*aexp* → *aexp⟨qcon⟩* { *pbind* , … , *pbind* } 89 |
*pbind* -> *qvar*=*exp* | *var* *fieldids*=*exp* 90 |
*fieldids* -> *fieldids* *fieldid* 91 | 92 | ### Sections 93 | 94 | To support sections (e.g. `(.foo.bar.baz)`), we generalize *aexp*. 95 |
96 |
*aexp* → ( *infixexp* *qop* ) (left section) 97 | | ( *qop* *infixexp* ) (right section) 98 | | ( *fieldids* ) (projection (right) section) 99 | -------------------------------------------------------------------------------- /record-dot-preprocessor.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.18 2 | build-type: Simple 3 | name: record-dot-preprocessor 4 | version: 0.2.17 5 | license: BSD3 6 | x-license: BSD-3-Clause OR Apache-2.0 7 | license-file: LICENSE 8 | category: Development 9 | author: Neil Mitchell 10 | maintainer: Neil Mitchell 11 | copyright: Neil Mitchell 2018-2024 12 | synopsis: Preprocessor to allow record.field syntax 13 | description: 14 | In almost every programming language @a.b@ will get the @b@ field from the @a@ data type, and many different data types can have a @b@ field. 15 | The reason this feature is ubiquitous is because it's /useful/. 16 | The @record-dot-preprocessor@ brings this feature to Haskell - see the README for full details. 17 | homepage: https://github.com/ndmitchell/record-dot-preprocessor#readme 18 | bug-reports: https://github.com/ndmitchell/record-dot-preprocessor/issues 19 | extra-doc-files: 20 | README.md 21 | CHANGES.txt 22 | tested-with: GHC==9.8, GHC==9.6, GHC==9.4, GHC==9.2, GHC==9.0, GHC==8.10, GHC==8.8 23 | extra-source-files: 24 | examples/Both.hs 25 | examples/Both2.hs 26 | examples/Header_in.hs 27 | examples/Preprocessor.hs 28 | examples/Readme.hs 29 | 30 | source-repository head 31 | type: git 32 | location: https://github.com/ndmitchell/record-dot-preprocessor.git 33 | 34 | library 35 | default-language: Haskell2010 36 | hs-source-dirs: 37 | plugin 38 | preprocessor 39 | build-depends: 40 | base >= 4.8 && < 5, 41 | uniplate, 42 | ghc >=8.6 && <9.9, 43 | extra 44 | exposed-modules: 45 | RecordDotPreprocessor 46 | RecordDotPreprocessor.Lib 47 | other-modules: 48 | Compat 49 | Edit 50 | Lexer 51 | Paren 52 | 53 | executable record-dot-preprocessor 54 | default-language: Haskell2010 55 | hs-source-dirs: preprocessor 56 | main-is: Preprocessor.hs 57 | ghc-options: -main-is Preprocessor 58 | build-depends: 59 | base >= 4.8 && < 5, 60 | extra 61 | other-modules: 62 | Edit 63 | Lexer 64 | Paren 65 | 66 | test-suite record-dot-preprocessor-test 67 | default-language: Haskell2010 68 | type: exitcode-stdio-1.0 69 | hs-source-dirs: preprocessor, test 70 | main-is: Test.hs 71 | ghc-options: -main-is Test.main 72 | build-depends: 73 | base == 4.*, 74 | extra, 75 | record-hasfield, 76 | filepath 77 | if impl(ghc >= 8.6) 78 | build-depends: 79 | record-dot-preprocessor 80 | other-modules: 81 | PluginExample 82 | Preprocessor 83 | Edit 84 | Lexer 85 | Paren 86 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # record-dot-preprocessor [![Hackage version](https://img.shields.io/hackage/v/record-dot-preprocessor.svg?label=Hackage)](https://hackage.haskell.org/package/record-dot-preprocessor) [![Stackage version](https://www.stackage.org/package/record-dot-preprocessor/badge/nightly?label=Stackage)](https://www.stackage.org/package/record-dot-preprocessor) [![Build status](https://img.shields.io/github/actions/workflow/status/ndmitchell/record-dot-preprocessor/ci.yml?branch=master)](https://github.com/ndmitchell/record-dot-preprocessor/actions) 2 | 3 | In almost every programming language `a.b` will get the `b` field from the `a` data type, and many different data types can have a `b` field. The reason this feature is ubiquitous is because it's _useful_. The `record-dot-preprocessor` brings this feature to modern GHC versions. This feature has been [proposed for Haskell](https://github.com/ghc-proposals/ghc-proposals/pull/282) as `RecordDotSyntax`. Since GHC 9.2 the [`OverloadedRecordDot`](https://downloads.haskell.org/~ghc/9.2.3/docs/html/users_guide/exts/overloaded_record_dot.html#extension-OverloadedRecordDot) and [`OverloadedRecordUpdate`](https://downloads.haskell.org/~ghc/9.2.3/docs/html/users_guide/exts/overloaded_record_update.html) extensions implement much the same functionality. Some examples: 4 | 5 | ```haskell 6 | data Company = Company {name :: String, owner :: Person} 7 | data Person = Person {name :: String, age :: Int} 8 | 9 | display :: Company -> String 10 | display c = c.name ++ " is run by " ++ c.owner.name 11 | 12 | nameAfterOwner :: Company -> Company 13 | nameAfterOwner c = c{name = c.owner.name ++ "'s Company"} 14 | ``` 15 | 16 | Here we declare two records both with `name` as a field, then write `c.name` and `c.owner.name` to get those fields. We can also write `c{name = x}` as a record update, which still works even though `name` is no longer unique. 17 | 18 | ## How do I use this magic? 19 | 20 | First install `record-dot-preprocessor` with either `stack install record-dot-preprocessor` or `cabal update && cabal install record-dot-preprocessor`. Then at the top of the file add: 21 | 22 | * Either: `{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-}` for the preprocessor. 23 | * Or: `{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}` and `{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, UndecidableInstances, GADTs #-}` for the GHC plugin. 24 | 25 | The GHC plugin only runs on GHC 8.6 or higher, [has some issues on Windows](https://gitlab.haskell.org/ghc/ghc/issues/16405) and has much better error messages. In contrast, the preprocessor runs everywhere and has more features. 26 | 27 | You must make sure that the `OPTIONS_GHC` is applied both to the file _where your records are defined_, and _where the record syntax is used_. The resulting program will require the [`record-hasfield` library](https://hackage.haskell.org/package/record-hasfield). 28 | 29 | ## What magic is available, precisely? 30 | 31 | Using the preprocessor or the GHC plugin you can write: 32 | 33 | * `expr.lbl` is equivalent to `getField @"lbl" expr` (the `.` cannot have whitespace on either side). 34 | * `expr{lbl = val}` is equivalent to `setField @"lbl" expr val` (the `{` cannot have whitespace before it). 35 | * `(.lbl)` is equivalent to `(\x -> x.lbl)` (the `.` cannot have whitespace after). 36 | 37 | Using the preprocessor, but _not_ the GHC plugin: 38 | 39 | * `expr{lbl1.lbl2 = val}` is equivalent to `expr{lbl1 = (expr.lbl1){lbl2 = val}}`, performing a nested update. 40 | * `expr{lbl * val}` is equivalent to `expr{lbl = expr.lbl * val}`, where `*` can be any operator. 41 | * `expr{lbl1.lbl2}` is equivalent to `expr{lbl1.lbl2 = lbl2}`. 42 | 43 | These forms combine to offer the identities: 44 | 45 | * `expr.lbl1.lbl2` is equivalent to `(expr.lbl1).lbl2`. 46 | * `(.lbl1.lbl2)` is equivalent to `(\x -> x.lbl1.lbl2)`. 47 | * `expr.lbl1{lbl2 = val}` is equivalent to `(expr.lbl1){lbl2 = val}`. 48 | * `expr{lbl1 = val}.lbl2` is equivalent to `(expr{lbl1 = val}).lbl2`. 49 | * `expr{lbl1.lbl2 * val}` is equivalent to `expr{lbl1.lbl2 = expr.lbl1.lbl2 * val}`. 50 | * `expr{lbl1 = val1, lbl2 = val2}` is equivalent to `(expr{lbl1 = val1}){lbl2 = val2}`. 51 | 52 | ## How does this magic compare to other magic? 53 | 54 | Records in Haskell are well known to be [pretty lousy](https://www.yesodweb.com/blog/2011/09/limitations-of-haskell). There are [many proposals](https://wiki.haskell.org/Extensible_record) that aim to make Haskell records more powerful using dark arts taken from type systems and category theory. This preprocessor aims for simplicity - combining existing elements into a coherent story. The aim is to do no worse than Java, not achieve perfection. 55 | 56 | ## Any advice for using this magic? 57 | 58 | The most important consideration is that all records used by `a.b` or `a{b=c}` syntax _must_ have `HasField` instances, which requires either running the preprocessor/plugin over the module defining them, or writing orphan instances by hand. To use records which don't have such instances use normal selector functions (e.g. `b a`) and insert a space before the `{` (e.g. `a {b=c}`). 59 | 60 | ## Limitations 61 | 62 | * The preprocessor doesn't deal with anti-quoted expressions inside `QuasiQuotes`, e.g. `[D.pgSQL|$ SELECT ${dummy.x} :: text|]`. 63 | -------------------------------------------------------------------------------- /preprocessor/Lexer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, BangPatterns #-} 2 | 3 | -- Most of this module follows the Haskell report, https://www.haskell.org/onlinereport/lexemes.html 4 | module Lexer(Lexeme(..), lexer, unlexerFile) where 5 | 6 | import Data.Char 7 | import Data.List.Extra 8 | import Data.Tuple.Extra 9 | 10 | -- | A lexeme of text, approx some letters followed by some space. 11 | data Lexeme = Lexeme 12 | {line :: {-# UNPACK #-} !Int -- ^ 1-based line number (0 = generated) 13 | ,col :: {-# UNPACK #-} !Int -- ^ 1-based col number (0 = generated) 14 | ,lexeme :: String -- ^ Actual text of the item 15 | ,whitespace :: String -- ^ Suffix spaces and comments 16 | } deriving Show 17 | 18 | 19 | charNewline x = x == '\r' || x == '\n' || x == '\f' 20 | charSpecial x = x `elem` "(),;[]`{}" 21 | charAscSymbol x = x `elem` "!#$%&*+./<=>?@\\^|-~" || x == ':' -- special case for me 22 | charSymbol x = charAscSymbol x || (isSymbol x && not (charSpecial x) && x `notElem` "_\"\'") 23 | 24 | charIdentStart x = isAlpha x || x == '_' 25 | charIdentCont x = isAlphaNum x || x == '_' || x == '\'' 26 | 27 | 28 | lexer :: String -> [Lexeme] 29 | lexer = go1 1 1 30 | where 31 | -- we might start with whitespace, before any lexemes 32 | go1 line col xs 33 | | (whitespace, xs) <- lexerWhitespace xs 34 | , whitespace /= "" 35 | , (line2, col2) <- reposition line col whitespace 36 | = Lexeme{lexeme="", ..} : go line2 col2 xs 37 | go1 line col xs = go line col xs 38 | 39 | go line col "" = [] 40 | go line col xs 41 | | (lexeme, xs) <- lexerLexeme xs 42 | , (whitespace, xs) <- lexerWhitespace xs 43 | , (line2, col2) <- reposition line col $ lexeme ++ whitespace 44 | = Lexeme{..} : go line2 col2 xs 45 | 46 | 47 | reposition :: Int -> Int -> String -> (Int, Int) 48 | reposition = go 49 | where 50 | go !line !col [] = (line, col) 51 | go line col (x:xs) 52 | | x == '\n' = go (line+1) 1 xs 53 | | x == '\t' = go line (col+8) xs -- technically not totally correct, but please, don't use tabs 54 | | otherwise = go line (col+1) xs 55 | 56 | 57 | -- We take a lot of liberties with lexemes around module qualification, because we want to make fields magic 58 | -- we ignore numbers entirely because they don't have any impact on what we want to do 59 | lexerLexeme :: String -> (String, String) 60 | lexerLexeme ('\'':x:'\'':xs) = (['\'',x,'\''], xs) 61 | lexerLexeme ('\'':x:xs) | x /= '\'' = ("\'", x:xs) -- might be a data kind, see #25 62 | lexerLexeme (open:xs) | open == '\'' || open == '\"' = seen [open] $ go xs 63 | where 64 | go (x:xs) | x == open = ([x], xs) 65 | | x == '\\', x2:xs <- xs = seen [x,x2] $ go xs 66 | | otherwise = seen [x] $ go xs 67 | go [] = ([], []) 68 | lexerLexeme (x:xs) 69 | | charSymbol x 70 | , (a, xs) <- span charSymbol xs 71 | = (x:a, xs) 72 | lexerLexeme (x:xs) 73 | | charIdentStart x 74 | , (a, xs) <- span charIdentCont xs 75 | = (x:a, xs) 76 | lexerLexeme (x:xs) = ([x], xs) 77 | lexerLexeme [] = ([], []) 78 | 79 | 80 | lexerWhitespace :: String -> (String, String) 81 | lexerWhitespace (x:xs) | isSpace x = seen [x] $ lexerWhitespace xs 82 | lexerWhitespace ('-':'-':xs) 83 | | (a, xs) <- span (== '-') xs 84 | , not $ any charSymbol $ take 1 xs 85 | , (b, xs) <- break charNewline xs 86 | , (c, xs) <- splitAt 1 xs 87 | = seen "--" $ seen a $ seen b $ seen c $ lexerWhitespace xs 88 | lexerWhitespace ('{':'-':xs) = seen "{-" $ f 1 xs 89 | where 90 | f 1 ('-':'}':xs) = seen "-}" $ lexerWhitespace xs 91 | f i ('-':'}':xs) = seen "-}" $ f (i-1) xs 92 | f i ('{':'-':xs) = seen "{-" $ f (i+1) xs 93 | f i (x:xs) = seen [x] $ f i xs 94 | f i [] = ([], []) 95 | lexerWhitespace xs = ([], xs) 96 | 97 | seen xs = first (xs++) 98 | 99 | 100 | unlexerFile :: Maybe FilePath -> [Lexeme] -> String 101 | unlexerFile src xs = 102 | dropping 1 ++ 103 | -- we split the whitespace up to increase the chances of startLine being true below 104 | -- pretty ugly code... 105 | go 1 True (concat 106 | [ [(line, lexeme ++ w1 ++ take 1 w2) 107 | ,(if line == 0 then 0 else line + length (filter (== '\n') (lexeme ++ w1 ++ take 1 w2)), drop1 w2)] 108 | | Lexeme{..} <- xs, let (w1,w2) = break (== '\n') whitespace]) 109 | where 110 | go 111 | :: Int -- ^ What line does GHC think we are on 112 | -> Bool -- ^ Are we at the start of a line 113 | -> [(Int, String)] -- ^ (original line, lexemes followed by their whitespace) 114 | -> String 115 | go ghcLine startLine ((i, x):xs) = 116 | (if emitDropping then dropping i else "") ++ 117 | x ++ 118 | go 119 | ((if emitDropping then i else ghcLine) + length (filter (== '\n') x)) 120 | (if null x then startLine else "\n" `isSuffixOf` x) 121 | xs 122 | where emitDropping = ghcLine /= i && i /= 0 && startLine 123 | go _ _ [] = "" 124 | 125 | -- write out a line marker with a trailing newline 126 | dropping n = case src of 127 | Just src' -> "{-# LINE " ++ show n ++ " " ++ show src' ++ " #-}\n" 128 | Nothing -> "" 129 | -------------------------------------------------------------------------------- /examples/Both.hs: -------------------------------------------------------------------------------- 1 | -- Test for everything that is supported by both the plugin and the preprocessor 2 | 3 | import Control.Exception 4 | import Data.Version 5 | import Data.Proxy 6 | import Data.Functor.Identity (Identity(..)) 7 | import qualified Data.Kind as T 8 | 9 | 10 | main :: IO () 11 | main = test1 >> test2 >> test3 >> test4 >> test5 >> test6 >> test7 >> test8 >> test9 >> putStrLn "All worked" 12 | 13 | (===) :: (Show a, Eq a) => a -> a -> IO () 14 | a === b = if a == b then pure () else fail $ "Mismatch, " ++ show a ++ " /= " ++ show b 15 | 16 | fails :: a -> IO () 17 | fails val = do 18 | res <- try $ evaluate val 19 | case res of 20 | Left e -> let _ = e :: SomeException in pure () 21 | Right _ -> fail "Expected an exception" 22 | 23 | 24 | --------------------------------------------------------------------- 25 | -- CHECK THE BASICS WORK 26 | 27 | data Foo a = Foo {foo1 :: !a, _foo2 :: Int} deriving (Show,Eq) 28 | 29 | -- can you deal with multiple alternatives 30 | data Animal = Human {name :: !String, job :: Prelude.String} 31 | | Nonhuman {name :: String} 32 | deriving (Show,Eq) 33 | 34 | 35 | test1 :: IO () 36 | test1 = do 37 | -- test expr.lbl 38 | (Foo "test" 1).foo1 === "test" 39 | let foo = Foo "test" 2 40 | foo.foo1 === "test" 41 | foo._foo2 === 2 42 | (Foo (1,2) 3).foo1._1 === 1 43 | let foo2 = Foo (1,2) 3 44 | foo2.foo1._2 === 2 45 | (foo2.foo1)._2 === 2 46 | 47 | -- test expr{lbl = val} 48 | foo{foo1 = "a"} === Foo "a" 2 49 | foo{foo1 = "a", foo1 = "b"} === foo{foo1 = "b"} 50 | null (foo{foo1 = []}.foo1) === True 51 | foo{foo1 = "a"}.foo1 === "a" 52 | let _foo2 = 8 in foo{_foo2} === Foo "test" 8 53 | 54 | -- (.lbl) 55 | map (.foo1) [foo, foo{foo1="q"}] === ["test", "q"] 56 | ( .foo1._foo2 ) (Foo foo 3) === 2 57 | 58 | -- alternatives work 59 | (Human "a" "b").name === "a" -- comment here 60 | (Nonhuman "x").name === "x" 61 | fails (Nonhuman "x").job 62 | 63 | 64 | --------------------------------------------------------------------- 65 | -- DEAL WITH INFIX APPLICATIONS AND ASSOCIATIVITY 66 | 67 | data Company = Company {name :: String, owner :: Person -- trailing comment 68 | } 69 | data Person = Person {name :: String, age :: Int} 70 | 71 | test2 :: IO () 72 | test2 = do 73 | let c = Company "A" $ Person "B" 3 74 | let x = True 75 | (===) "A" $ f c.name x 76 | (===) "B" $ f c.owner.name x 77 | (===) "A" $ gL $ 1 @+ c.name @+ True 78 | (===) "B" $ gL $ 1 @+ c.owner.name @+ True 79 | (===) "A" $ gL $ 1 @+ f c.name x @+ True 80 | (===) "B" $ gL $ 1 @+ f c.owner.name x @+ True 81 | (===) "A" $ gR $ 1 +@ c.name +@ True 82 | (===) "B" $ gR $ 1 +@ c.owner.name +@ True 83 | (===) "A" $ gR $ 1 +@ f c.name x +@ True 84 | (===) "B" $ gR $ 1 +@ f c.owner.name x +@ True 85 | 86 | f :: String -> Bool -> String 87 | f x _ = x 88 | 89 | infixl 9 @+ 90 | infixr 9 +@ 91 | (@+), (+@) :: _ 92 | (@+) = (,) 93 | (+@) = (,) 94 | 95 | gL :: ((Int, String), Bool) -> String 96 | gL ((_,x),_) = x 97 | 98 | gR :: (Int, (String, Bool)) -> String 99 | gR (_,(x,_)) = x 100 | 101 | 102 | --------------------------------------------------------------------- 103 | -- GADTS AND EXISTENTIALS 104 | 105 | data GADT where 106 | GADT :: {gadt :: Int} -> GADT 107 | deriving (Show,Eq) 108 | 109 | data V3 a = Num a => V3 { xx, yy, zz :: a } 110 | deriving instance Show a => Show (V3 a) 111 | deriving instance Eq a => Eq (V3 a) 112 | 113 | test3 :: IO () 114 | test3 = do 115 | let val = GADT 3 116 | val.gadt === 3 117 | val{gadt=5} === GADT 5 118 | 119 | let v3 = V3 1 2 3 120 | v3.xx === 1 121 | v3{yy=1, zz=2} === V3 1 1 2 122 | 123 | -- --------------------------------------------------------------------- 124 | -- Another volley of tests combining constructions, updates and 125 | -- applications adapted from the DAML test-suite 126 | 127 | data AA = AA {xx :: Int} deriving (Eq, Show) 128 | data BB = BB {yy :: AA, zz :: AA} deriving (Eq, Show) 129 | data CC = CC {aa :: Int, bb :: Int} deriving (Eq, Show) 130 | 131 | test4 :: IO () 132 | test4 = do 133 | f1 CC{aa = 1, bb = 2} 3 4 === CC{aa = 3, bb = 4} 134 | f2 CC{aa = 1, bb = 2} 1 2 === CC{aa = 3, bb = 2} 135 | (f3 AA{xx = 1}).xx === 2 136 | (f4 BB{yy = AA{xx = 1}, zz = AA{xx = 2}}).zz.xx === 4 137 | let res = f4 BB{yy = AA{xx = 1}, zz = AA{xx = 2}} in res.zz.xx === 4 138 | (f5 BB{yy = AA{xx = 1}, zz = AA{xx = 2}}).zz.xx === 4 139 | (f6 BB{yy = AA{xx = 1}, zz = AA{xx = 2}}).yy.xx === 2 140 | (f6 BB{yy = AA{xx = 1}, zz = AA{xx = 2}}).zz.xx === 4 141 | f7 [AA 1, AA 2, AA 3] === [1, 2, 3] 142 | f8 [BB (AA 1) (AA 2), BB (AA 2) (AA 3), BB (AA 3) (AA 4)] === [1, 2, 3] 143 | where 144 | f1 :: CC -> Int -> Int -> CC; f1 s t u = s{aa = t, bb = u} 145 | f2 :: CC -> Int -> Int -> CC; f2 s t u = s{aa = t + u} 146 | f3 :: AA -> AA; f3 s = s{xx = s.xx + 1} 147 | f4 :: BB -> BB; f4 s = s{yy = s.yy, zz = s.zz{xx = 4}} 148 | f5 :: BB -> BB; f5 s = s{yy = s.yy, zz = s.zz{xx = (\ x -> x * x) s.zz.xx}} 149 | f6 :: BB -> BB; f6 s = s{yy = s.yy{xx = s.yy.xx + 1}, zz = s.zz{xx = (\ x -> x * x) s.zz{xx = s.zz.xx}.xx}} 150 | f7 :: [AA] -> [Int]; f7 l = map (.xx) l 151 | f8 :: [BB] -> [Int]; f8 l = map (.yy.xx) l 152 | 153 | -- --------------------------------------------------------------------- 154 | -- Test we can still non-instance fields 155 | 156 | test5 :: IO () 157 | test5 = do 158 | let v = makeVersion [1,2,3] 159 | versionBranch v === [1,2,3] 160 | -- the space before the { stops it from using record update 161 | showVersion (v {versionBranch=[1]}) === "1" 162 | 163 | -- --------------------------------------------------------------------- 164 | -- Deal with type promotion 165 | 166 | type Type = '[Int] 167 | 168 | typeProxy :: Proxy Type 169 | typeProxy = Proxy 170 | 171 | test6 :: IO () 172 | test6 = do 173 | _ <- evaluate typeProxy 174 | return () 175 | 176 | 177 | -- --------------------------------------------------------------------- 178 | -- Deal with kind signatures 179 | 180 | data UserF (f :: T.Type -> T.Type) = UserF { userf_name :: String } 181 | 182 | test7 :: IO () 183 | test7 = do 184 | (UserF "test").userf_name === "test" 185 | 186 | 187 | -- --------------------------------------------------------------------- 188 | -- Deal with incomplete types with no warning 189 | 190 | data Foo8 = Foo8 { 191 | bar8 :: Int, 192 | baz8 :: Float 193 | } | Quux8 { 194 | quux8 :: String 195 | } deriving Show 196 | 197 | test8 :: IO () 198 | test8 = do 199 | let foo = Foo8 1 2 200 | let quux = Quux8 "test" 201 | (foo.bar8, foo.baz8) === (1, 2) 202 | quux.quux8 === "test" 203 | fails $ foo.quux8 204 | fails $ length $ show $ quux{bar8=1} 205 | 206 | -- --------------------------------------------------------------------- 207 | -- Deal with HKD 208 | 209 | -- Emulate simple HKD functionality 210 | data Nullable (f :: T.Type -> T.Type) (a :: T.Type) 211 | 212 | type family C (f :: T.Type -> T.Type) (a :: T.Type) :: T.Type where 213 | C Identity a = a 214 | C (Nullable c) a = C c (Maybe a) 215 | C f a = f a 216 | 217 | -- Existential typed field xc' need to be omitted from types, otherwise 218 | -- compiler produce following error: 219 | -- • Illegal instance declaration for 220 | -- ‘GHC.Records.Extra.HasField "xc'" (Existential a) aplg’ 221 | -- The liberal coverage condition fails in class ‘GHC.Records.Extra.HasField’ 222 | -- for functional dependency: ‘x r -> a’ 223 | -- Reason: lhs types ‘"xc'"’, ‘Existential a’ 224 | -- do not jointly determine rhs type ‘aplg’ 225 | -- Un-determined variable: aplg 226 | data Existential a = forall b. Bar { xa :: a, xb :: !a, xc' :: b } 227 | 228 | data Foo9 f = Foo9 { 229 | bar :: C f Int, 230 | baz :: String 231 | } 232 | 233 | data Foo92 f = Foo92 { 234 | bar2 :: C (Nullable f) Int, 235 | baz2 :: String 236 | } 237 | 238 | tstObj :: Foo9 Identity 239 | tstObj = Foo9 1 "test" 240 | 241 | tstObj2 :: Foo92 Identity 242 | tstObj2 = Foo92 (Just 1) "test" 243 | 244 | test9 :: IO () 245 | test9 = do 246 | tstObj.baz === "test" 247 | tstObj.bar === 1 248 | tstObj2.baz2 === "test" 249 | tstObj2.bar2 === Just 1 250 | -------------------------------------------------------------------------------- /plugin/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE ImplicitParams #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {- HLINT ignore "Use camelCase" -} 9 | {- HLINT ignore "Unused LANGUAGE pragma" -} 10 | 11 | -- | Module containing the plugin. 12 | module Compat(module Compat) where 13 | 14 | import GHC 15 | #if __GLASGOW_HASKELL__ > 901 16 | import GHC.Types.SourceText ( SourceText(NoSourceText) ) 17 | import GHC.Data.FastString (FastString, NonDetFastString (NonDetFastString)) 18 | #elif __GLASGOW_HASKELL__ >=900 19 | import GHC.Data.FastString (FastString) 20 | #else 21 | import FastString (FastString) 22 | #endif 23 | 24 | #if __GLASGOW_HASKELL__ < 900 25 | import BasicTypes 26 | import TcEvidence 27 | import RnTypes as Compat 28 | import UniqSupply 29 | #else 30 | import GHC.Types.Basic 31 | #if __GLASGOW_HASKELL__ < 906 32 | import GHC.Unit.Types 33 | #endif 34 | #if __GLASGOW_HASKELL__ < 902 35 | import GHC.Parser.Annotation 36 | #endif 37 | import GHC.Rename.HsType as Compat 38 | import GHC.Types.Unique.Supply 39 | #endif 40 | #if __GLASGOW_HASKELL__ < 810 41 | import HsSyn as Compat 42 | #else 43 | import GHC.Hs as Compat 44 | #endif 45 | #if __GLASGOW_HASKELL__ < 808 46 | import System.IO.Unsafe as Compat (unsafePerformIO) 47 | import TcRnTypes 48 | import IOEnv 49 | import DynFlags 50 | import HscTypes 51 | #endif 52 | #if __GLASGOW_HASKELL__ >= 904 53 | import GHC.Types.PkgQual (RawPkgQual(NoRawPkgQual)) 54 | #endif 55 | import Data.IORef as Compat 56 | 57 | --------------------------------------------------------------------- 58 | -- LOCATIONS 59 | 60 | class WithoutLoc a b | b -> a where 61 | -- | Without location information 62 | -- 63 | -- Different GHC versions want different kind of location information in 64 | -- different places. This class is intended to abstract over this. 65 | noL :: a -> b 66 | 67 | #if __GLASGOW_HASKELL__ >= 902 68 | instance WithoutLoc a (GenLocated (SrcAnn ann) a) where 69 | noL = reLocA . noLoc 70 | #endif 71 | 72 | instance WithoutLoc a (Located a) where 73 | noL = noLoc 74 | 75 | instance WithoutLoc (HsTupArg p) (HsTupArg p) where noL = id 76 | instance WithoutLoc (HsLocalBindsLR p q) (HsLocalBindsLR p q) where noL = id 77 | 78 | #if __GLASGOW_HASKELL__ < 902 79 | reLocA :: Located e -> Located e 80 | reLocA = id 81 | 82 | reLoc :: Located e -> Located e 83 | reLoc = id 84 | #endif 85 | 86 | --------------------------------------------------------------------- 87 | -- TREE EXTENSIONS 88 | 89 | class WithoutExt a where 90 | -- | No extension 91 | -- 92 | -- Different GHC versions want different kinds of annotations. This class is 93 | -- intended to abstract over this. 94 | noE :: a 95 | 96 | #if __GLASGOW_HASKELL__ >= 902 97 | instance WithoutExt (EpAnn a) where 98 | noE = EpAnnNotUsed 99 | 100 | instance WithoutExt EpAnnComments where 101 | noE = emptyComments 102 | #endif 103 | 104 | #if __GLASGOW_HASKELL__ >= 810 105 | instance WithoutExt NoExtField where 106 | noE = noExtField 107 | #else 108 | instance WithoutExt NoExt where 109 | noE = NoExt 110 | #endif 111 | 112 | #if __GLASGOW_HASKELL__ >= 906 113 | instance WithoutExt XImportDeclPass where 114 | noE = XImportDeclPass noE NoSourceText True {- implicit -} 115 | 116 | instance WithoutExt GHC.Types.Basic.Origin where 117 | noE = Generated 118 | #if __GLASGOW_HASKELL__ >= 908 119 | SkipPmc 120 | #endif 121 | #endif 122 | 123 | --------------------------------------------------------------------- 124 | -- UTILITIES 125 | 126 | #if __GLASGOW_HASKELL__ < 902 127 | 128 | mkNonDetFastString :: FastString -> FastString 129 | mkNonDetFastString = id 130 | 131 | #else 132 | 133 | mkNonDetFastString :: FastString -> NonDetFastString 134 | mkNonDetFastString = NonDetFastString 135 | 136 | #endif 137 | 138 | realSrcLoc :: SrcLoc -> Maybe RealSrcLoc 139 | #if __GLASGOW_HASKELL__ < 811 140 | realSrcLoc (RealSrcLoc x) = Just x 141 | #else 142 | realSrcLoc (RealSrcLoc x _) = Just x 143 | #endif 144 | realSrcLoc _ = Nothing 145 | 146 | #if __GLASGOW_HASKELL__ >= 902 147 | hsLTyVarBndrToType :: (Anno (IdP (GhcPass p)) ~ SrcSpanAnn' (EpAnn NameAnn)) => LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p) 148 | hsLTyVarBndrToType x = noL $ HsTyVar noE NotPromoted $ noL $ hsLTyVarName x 149 | #elif __GLASGOW_HASKELL__ >= 900 150 | hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p) 151 | hsLTyVarBndrToType x = noL $ HsTyVar noE NotPromoted $ noL $ hsLTyVarName x 152 | #endif 153 | 154 | --------------------------------------------------------------------- 155 | -- COMMON SIGNATURES 156 | 157 | #if __GLASGOW_HASKELL__ < 811 158 | type Module = HsModule GhcPs 159 | #elif __GLASGOW_HASKELL__ >= 906 160 | type Module = HsModule GhcPs 161 | #else 162 | type Module = HsModule 163 | #endif 164 | 165 | mkAppType :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs 166 | mkTypeAnn :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs 167 | mkFunTy :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs 168 | newFunBind :: Located RdrName -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsBind GhcPs 169 | 170 | #if __GLASGOW_HASKELL__ < 807 171 | 172 | -- GHC 8.6 173 | mkAppType expr typ = noL $ HsAppType (HsWC noE typ) expr 174 | mkTypeAnn expr typ = noL $ ExprWithTySig (HsWC noE (HsIB noE typ)) expr 175 | 176 | #elif __GLASGOW_HASKELL__ < 901 177 | 178 | -- GHC 8.8-9.0 179 | mkAppType expr typ = noL $ HsAppType noE expr (HsWC noE typ) 180 | mkTypeAnn expr typ = noL $ ExprWithTySig noE expr (HsWC noE (HsIB noE typ)) 181 | 182 | #elif __GLASGOW_HASKELL__ >= 906 183 | 184 | -- GHC 9.6+ 185 | mkAppType expr typ = noL $ HsAppType noE expr noHsTok (HsWC noE typ) 186 | mkTypeAnn expr typ = noL $ ExprWithTySig noE expr (hsTypeToHsSigWcType typ) 187 | 188 | #else 189 | 190 | -- GHC 9.2-9.4 191 | mkAppType expr typ = noL $ HsAppType noSrcSpan expr (HsWC noE typ) 192 | mkTypeAnn expr typ = noL $ ExprWithTySig noE expr (hsTypeToHsSigWcType typ) 193 | 194 | #endif 195 | 196 | #if __GLASGOW_HASKELL__ < 811 197 | 198 | -- GHC 8.10 and below 199 | mkFunTy a b = noL $ HsFunTy noE a b 200 | newFunBind a b = FunBind noE a b WpHole [] 201 | 202 | #elif __GLASGOW_HASKELL__ < 904 203 | 204 | -- GHC 9.0 and 9.2 205 | mkFunTy a b = noL $ HsFunTy noE (HsUnrestrictedArrow NormalSyntax) a b 206 | newFunBind a b = FunBind noE (reLocA a) b [] 207 | 208 | #elif __GLASGOW_HASKELL__ >= 906 209 | 210 | -- GHC 9.6+ 211 | mkFunTy a b = noL $ HsFunTy noE (HsUnrestrictedArrow $ L NoTokenLoc HsNormalTok) a b 212 | newFunBind a = FunBind noE (reLocA a) 213 | 214 | #else 215 | 216 | -- GHC 9.4 217 | mkFunTy a b = noL $ HsFunTy noE (HsUnrestrictedArrow $ L NoTokenLoc HsNormalTok) a b 218 | newFunBind a b = FunBind noE (reLocA a) b [] 219 | 220 | #endif 221 | 222 | 223 | #if __GLASGOW_HASKELL__ < 807 224 | 225 | -- GHC 8.6 226 | compat_m_pats :: [Pat GhcPs] -> [LPat GhcPs] 227 | compat_m_pats = map noL 228 | 229 | #elif __GLASGOW_HASKELL__ < 809 230 | 231 | -- GHC 8.8 232 | compat_m_pats :: [Pat GhcPs] -> [Pat GhcPs] 233 | compat_m_pats = id 234 | 235 | #else 236 | 237 | -- 8.10 238 | compat_m_pats :: [Pat GhcPs] -> [LPat GhcPs] 239 | compat_m_pats = map noL 240 | 241 | #endif 242 | 243 | 244 | qualifiedImplicitImport :: ModuleName -> LImportDecl GhcPs 245 | 246 | #if __GLASGOW_HASKELL__ < 809 247 | 248 | -- GHC 8.8 249 | qualifiedImplicitImport x = noL $ ImportDecl noE NoSourceText (noL x) Nothing False False 250 | True {- qualified -} True {- implicit -} Nothing Nothing 251 | 252 | #elif __GLASGOW_HASKELL__ < 811 253 | 254 | -- GHC 8.10 255 | qualifiedImplicitImport x = noL $ ImportDecl noE NoSourceText (noL x) Nothing False False 256 | QualifiedPost {- qualified -} True {- implicit -} Nothing Nothing 257 | 258 | #elif __GLASGOW_HASKELL__ < 904 259 | 260 | -- GHC 9.0 and 9.2 261 | qualifiedImplicitImport x = noL $ ImportDecl noE NoSourceText (noL x) Nothing NotBoot False 262 | QualifiedPost {- qualified -} True {- implicit -} Nothing Nothing 263 | 264 | #elif __GLASGOW_HASKELL__ >= 906 265 | 266 | -- GHC 9.6+ 267 | qualifiedImplicitImport x = noL $ ImportDecl noE (noL x) NoRawPkgQual NotBoot False 268 | QualifiedPost {- qualified -} Nothing Nothing 269 | 270 | #else 271 | 272 | -- GHC 9.4 273 | qualifiedImplicitImport x = noL $ ImportDecl noE NoSourceText (noL x) NoRawPkgQual NotBoot False 274 | QualifiedPost {- qualified -} True {- implicit -} Nothing Nothing 275 | 276 | #endif 277 | 278 | type PluginEnv = (?hscenv :: HscEnv, ?uniqSupply :: IORef UniqSupply) 279 | 280 | dropRnTraceFlags :: HscEnv -> HscEnv 281 | #if __GLASGOW_HASKELL__ < 808 282 | dropRnTraceFlags env@HscEnv{hsc_dflags = dflags} = env{hsc_dflags = dopt_unset dflags Opt_D_dump_rn_trace} 283 | #else 284 | dropRnTraceFlags = id 285 | #endif 286 | 287 | freeTyVars :: PluginEnv => LHsType GhcPs -> [Located RdrName] 288 | #if __GLASGOW_HASKELL__ < 808 289 | {-# NOINLINE freeTyVars #-} 290 | freeTyVars = freeKiTyVarsAllVars . runRnM . extractHsTyRdrTyVars 291 | where 292 | runRnM :: RnM a -> a 293 | runRnM rnm = unsafePerformIO $ do 294 | let env = Env ?hscenv ?uniqSupply unused unused 295 | runIOEnv env rnm 296 | unused = error "never called" 297 | #elif __GLASGOW_HASKELL__ < 810 298 | freeTyVars = freeKiTyVarsAllVars . extractHsTyRdrTyVars 299 | #else 300 | freeTyVars = map reLoc . extractHsTyRdrTyVars 301 | #endif 302 | 303 | #if __GLASGOW_HASKELL__ >= 902 304 | isLHsForAllTy :: LHsType GhcPs -> Bool 305 | isLHsForAllTy (L _ (HsForAllTy {})) = True 306 | isLHsForAllTy _ = False 307 | #endif 308 | 309 | #if __GLASGOW_HASKELL__ >= 904 310 | rdrNameFieldOcc :: FieldOcc GhcPs -> LocatedN RdrName 311 | rdrNameFieldOcc = foLabel 312 | #endif 313 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Neil Mitchell 2018-2024. 2 | 3 | Licensed under either of: 4 | 5 | * BSD-3-Clause license (https://opensource.org/licenses/BSD-3-Clause) 6 | * Apache License, version 2.0 (https://opensource.org/licenses/Apache-2.0) 7 | 8 | As a user, you may use this code under either license, at your option. 9 | 10 | 11 | --------------------------------------------------------------------- 12 | BSD 3-Clause License 13 | All rights reserved. 14 | 15 | Redistribution and use in source and binary forms, with or without 16 | modification, are permitted provided that the following conditions 17 | are met: 18 | 19 | * Redistributions of source code must retain the above copyright 20 | notice, this list of conditions and the following disclaimer. 21 | 22 | * Redistributions in binary form must reproduce the above 23 | copyright notice, this list of conditions and the following 24 | disclaimer in the documentation and/or other materials provided 25 | with the distribution. 26 | 27 | * Neither the name of Neil Mitchell nor the names of other 28 | contributors may be used to endorse or promote products derived 29 | from this software without specific prior written permission. 30 | 31 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 32 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 33 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 34 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 35 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 36 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 37 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 38 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 39 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 40 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 41 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 42 | 43 | 44 | --------------------------------------------------------------------- 45 | Apache License 46 | Version 2.0, January 2004 47 | 48 | 49 | Terms and Conditions for use, reproduction, and distribution 50 | 1. Definitions 51 | "License" shall mean the terms and conditions for use, reproduction, 52 | and distribution as defined by Sections 1 through 9 of this document. 53 | 54 | "Licensor" shall mean the copyright owner or entity authorized by the 55 | copyright owner that is granting the License. 56 | 57 | "Legal Entity" shall mean the union of the acting entity and all 58 | other entities that control, are controlled by, or are under common 59 | control with that entity. For the purposes of this definition, 60 | "control" means (i) the power, direct or indirect, to cause the 61 | direction or management of such entity, whether by contract or 62 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 63 | outstanding shares, or (iii) beneficial ownership of such entity. 64 | 65 | "You" (or "Your") shall mean an individual or Legal Entity exercising 66 | permissions granted by this License. 67 | 68 | "Source" form shall mean the preferred form for making modifications, 69 | including but not limited to software source code, documentation 70 | source, and configuration files. 71 | 72 | "Object" form shall mean any form resulting from mechanical 73 | transformation or translation of a Source form, including but not 74 | limited to compiled object code, generated documentation, and 75 | conversions to other media types. 76 | 77 | "Work" shall mean the work of authorship, whether in Source or Object 78 | form, made available under the License, as indicated by a copyright 79 | notice that is included in or attached to the work). 80 | 81 | "Derivative Works" shall mean any work, whether in Source or Object 82 | form, that is based on (or derived from) the Work and for which the 83 | editorial revisions, annotations, elaborations, or other 84 | modifications represent, as a whole, an original work of authorship. 85 | For the purposes of this License, Derivative Works shall not include 86 | works that remain separable from, or merely link (or bind by name) to 87 | the interfaces of, the Work and Derivative Works thereof. 88 | 89 | "Contribution" shall mean any work of authorship, including the 90 | original version of the Work and any modifications or additions to 91 | that Work or Derivative Works thereof, that is intentionally 92 | submitted to Licensor for inclusion in the Work by the copyright 93 | owner or by an individual or Legal Entity authorized to submit on 94 | behalf of the copyright owner. For the purposes of this definition, 95 | "submitted" means any form of electronic, verbal, or written 96 | communication sent to the Licensor or its representatives, including 97 | but not limited to communication on electronic mailing lists, source 98 | code control systems, and issue tracking systems that are managed by, 99 | or on behalf of, the Licensor for the purpose of discussing and 100 | improving the Work, but excluding communication that is conspicuously 101 | marked or otherwise designated in writing by the copyright owner as 102 | "Not a Contribution." 103 | 104 | "Contributor" shall mean Licensor and any individual or Legal Entity 105 | on behalf of whom a Contribution has been received by Licensor and 106 | subsequently incorporated within the Work. 107 | 108 | 2. Grant of Copyright License 109 | Subject to the terms and conditions of this License, each Contributor 110 | hereby grants to You a perpetual, worldwide, non-exclusive, 111 | no-charge, royalty-free, irrevocable copyright license to reproduce, 112 | prepare Derivative Works of, publicly display, publicly perform, 113 | sublicense, and distribute the Work and such Derivative Works in 114 | Source or Object form. 115 | 116 | 3. Grant of Patent License 117 | Subject to the terms and conditions of this License, each Contributor 118 | hereby grants to You a perpetual, worldwide, non-exclusive, 119 | no-charge, royalty-free, irrevocable (except as stated in this 120 | section) patent license to make, have made, use, offer to sell, sell, 121 | import, and otherwise transfer the Work, where such license applies 122 | only to those patent claims licensable by such Contributor that are 123 | necessarily infringed by their Contribution(s) alone or by 124 | combination of their Contribution(s) with the Work to which such 125 | Contribution(s) was submitted. If You institute patent litigation 126 | against any entity (including a cross-claim or counterclaim in a 127 | lawsuit) alleging that the Work or a Contribution incorporated within 128 | the Work constitutes direct or contributory patent infringement, then 129 | any patent licenses granted to You under this License for that Work 130 | shall terminate as of the date such litigation is filed. 131 | 132 | 4. Redistribution 133 | You may reproduce and distribute copies of the Work or Derivative 134 | Works thereof in any medium, with or without modifications, and in 135 | Source or Object form, provided that You meet the following 136 | conditions: 137 | 138 | (a) You must give any other recipients of the Work or Derivative 139 | Works a copy of this License; and 140 | (b) You must cause any modified files to carry prominent notices 141 | stating that You changed the files; and 142 | (c) You must retain, in the Source form of any Derivative Works that 143 | You distribute, all copyright, patent, trademark, and attribution 144 | notices from the Source form of the Work, excluding those notices 145 | that do not pertain to any part of the Derivative Works; and 146 | (d) If the Work includes a "NOTICE" text file as part of its 147 | distribution, then any Derivative Works that You distribute must 148 | include a readable copy of the attribution notices contained within 149 | such NOTICE file, excluding those notices that do not pertain to any 150 | part of the Derivative Works, in at least one of the following 151 | places: within a NOTICE text file distributed as part of the 152 | Derivative Works; within the Source form or documentation, if 153 | provided along with the Derivative Works; or, within a display 154 | generated by the Derivative Works, if and wherever such third-party 155 | notices normally appear. The contents of the NOTICE file are for 156 | informational purposes only and do not modify the License. You may 157 | add Your own attribution notices within Derivative Works that You 158 | distribute, alongside or as an addendum to the NOTICE text from the 159 | Work, provided that such additional attribution notices cannot be 160 | construed as modifying the License. 161 | You may add Your own copyright statement to Your modifications and 162 | may provide additional or different license terms and conditions for 163 | use, reproduction, or distribution of Your modifications, or for any 164 | such Derivative Works as a whole, provided Your use, reproduction, 165 | and distribution of the Work otherwise complies with the conditions 166 | stated in this License. 167 | 168 | 5. Submission of Contributions 169 | Unless You explicitly state otherwise, any Contribution intentionally 170 | submitted for inclusion in the Work by You to the Licensor shall be 171 | under the terms and conditions of this License, without any 172 | additional terms or conditions. Notwithstanding the above, nothing 173 | herein shall supersede or modify the terms of any separate license 174 | agreement you may have executed with Licensor regarding such 175 | Contributions. 176 | 177 | 6. Trademarks 178 | This License does not grant permission to use the trade names, 179 | trademarks, service marks, or product names of the Licensor, except 180 | as required for reasonable and customary use in describing the origin 181 | of the Work and reproducing the content of the NOTICE file. 182 | 183 | 7. Disclaimer of Warranty 184 | Unless required by applicable law or agreed to in writing, Licensor 185 | provides the Work (and each Contributor provides its Contributions) 186 | on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, 187 | either express or implied, including, without limitation, any 188 | warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, 189 | or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for 190 | determining the appropriateness of using or redistributing the Work 191 | and assume any risks associated with Your exercise of permissions 192 | under this License. 193 | 194 | 8. Limitation of Liability 195 | In no event and under no legal theory, whether in tort (including 196 | negligence), contract, or otherwise, unless required by applicable 197 | law (such as deliberate and grossly negligent acts) or agreed to in 198 | writing, shall any Contributor be liable to You for damages, 199 | including any direct, indirect, special, incidental, or consequential 200 | damages of any character arising as a result of this License or out 201 | of the use or inability to use the Work (including but not limited to 202 | damages for loss of goodwill, work stoppage, computer failure or 203 | malfunction, or any and all other commercial damages or losses), even 204 | if such Contributor has been advised of the possibility of such 205 | damages. 206 | 207 | 9. Accepting Warranty or Additional Liability 208 | While redistributing the Work or Derivative Works thereof, You may 209 | choose to offer, and charge a fee for, acceptance of support, 210 | warranty, indemnity, or other liability obligations and/or rights 211 | consistent with this License. However, in accepting such obligations, 212 | You may act only on Your own behalf and on Your sole responsibility, 213 | not on behalf of any other Contributor, and only if You agree to 214 | indemnify, defend, and hold each Contributor harmless for any 215 | liability incurred by, or claims asserted against, such Contributor 216 | by reason of your accepting any such warranty or additional 217 | liability. 218 | -------------------------------------------------------------------------------- /preprocessor/Edit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms, ViewPatterns #-} 2 | 3 | module Edit(recordDotPreprocessor, recordDotPreprocessorOnFragment) where 4 | 5 | import Lexer 6 | import Paren 7 | import Data.Maybe 8 | import Data.Char 9 | import Data.List.Extra 10 | import Control.Monad.Extra 11 | 12 | recordDotPreprocessor :: FilePath -> String -> String 13 | recordDotPreprocessor original = unlexerFile (Just original) . unparens . edit . parens . lexer 14 | where 15 | edit :: [PL] -> [PL] 16 | edit = editAddPreamble . editAddInstances . editLoop 17 | 18 | recordDotPreprocessorOnFragment :: String -> String 19 | recordDotPreprocessorOnFragment = unlexerFile Nothing . unparens . editLoop . parens . lexer 20 | 21 | 22 | --------------------------------------------------------------------- 23 | -- HELPERS 24 | 25 | -- Projecting in on the 'lexeme' inside 26 | type L = Lexeme 27 | unL = lexeme 28 | mkL x = Lexeme 0 0 x "" 29 | pattern L x <- (unL -> x) 30 | 31 | -- Projecting in on the lexeme inside an Item 32 | type PL = Paren L 33 | unPL (Item (L x)) = Just x 34 | unPL _ = Nothing 35 | isPL x y = unPL y == Just x 36 | pattern PL x <- (unPL -> Just x) 37 | mkPL = Item . mkL 38 | 39 | -- Whitespace 40 | pattern NoW x <- (\v -> if null $ getWhite v then Just v else Nothing -> Just x) 41 | 42 | 43 | paren [x] = x 44 | paren xs = case unsnoc xs of 45 | Just (xs,x) -> Paren (mkL "(") (xs `snoc` setWhite "" x) (mkL ")"){whitespace = getWhite x} 46 | _ -> Paren (mkL "(") xs (mkL ")") 47 | 48 | spc = addWhite " " 49 | nl = addWhite "\n" 50 | 51 | addWhite w x = setWhite (getWhite x ++ w) x 52 | 53 | getWhite (Item x) = whitespace x 54 | getWhite (Paren _ _ x) = whitespace x 55 | 56 | setWhite w (Item x) = Item x{whitespace=w} 57 | setWhite w (Paren x y z) = Paren x y z{whitespace=w} 58 | 59 | isCtor (Item x) = any isUpper $ take 1 $ lexeme x 60 | isCtor _ = False 61 | 62 | -- | This test does not check that the @quoter@ name is a qualified identifier, 63 | -- instead relying on lack of whitespace in the opener and existence of a paired 64 | -- closed (@|]@) 65 | isQuasiQuotation :: PL -> Bool 66 | isQuasiQuotation (Paren open@(L "[") inner@(_:_) (L "]")) 67 | | null (whitespace open) 68 | , qname inner 69 | , Item close@(L op) <- last inner 70 | , "|" `isSuffixOf` op 71 | , null (whitespace close) 72 | = True 73 | where 74 | -- a (potentially) qualified name with no whitespace near it, ending with | 75 | qname (Item a@(L _) : Item b@(L ".") : c) | null (whitespace a), null (whitespace b) = qname c 76 | qname (Item a@(L _) : Item (L x):_) = "|" `isPrefixOf` x 77 | qname _ = False 78 | isQuasiQuotation _ = False 79 | 80 | isField (x:_) = x == '_' || isLower x 81 | isField _ = False 82 | 83 | makeField :: [String] -> String 84 | makeField [x] = "@" ++ show x 85 | makeField xs = "@'(" ++ intercalate "," (map show xs) ++ ")" 86 | 87 | 88 | --------------------------------------------------------------------- 89 | -- PREAMBLE 90 | 91 | -- | Add the necessary extensions, imports and local definitions 92 | editAddPreamble :: [PL] -> [PL] 93 | editAddPreamble o@xs 94 | | (premodu, modu:modname@xs) <- break (isPL "module") xs 95 | , (prewhr, whr:xs) <- break (isPL "where") xs 96 | = nl (mkPL prefix) : premodu ++ modu : prewhr ++ whr : nl (mkPL "") : nl (mkPL imports) : xs ++ [nl $ mkPL "", nl $ mkPL $ trailing modname] 97 | | otherwise = blanks ++ nl (mkPL prefix) : nl (mkPL imports) : rest ++ [nl $ mkPL "", nl $ mkPL $ trailing []] 98 | where 99 | (blanks, rest) = span (isPL "") o 100 | 101 | prefix = "{-# LANGUAGE DuplicateRecordFields, DataKinds, FlexibleInstances, TypeApplications, FlexibleContexts, MultiParamTypeClasses, TypeFamilies, TypeOperators, GADTs, UndecidableInstances #-}\n" ++ 102 | -- it's too hard to avoid generating excessive brackets, so just ignore the code 103 | -- only really applies to people using it through Haskell Language Server (see #37) 104 | "{- HLINT ignore \"Redundant bracket\" -}" 105 | imports = "import qualified GHC.Records.Extra as Z" 106 | -- if you import two things that have preprocessor_unused, and export them as modules, you don't want them to clash 107 | trailing modName = "_recordDotPreprocessorUnused" ++ uniq ++ " :: Z.HasField \"\" r a => r -> a;" ++ 108 | "_recordDotPreprocessorUnused" ++ uniq ++ " = Z.getField @\"\"" 109 | where uniq = concatMap (filter isAlphaNum) $ take 19 $ takeWhile modPart $ map lexeme $ unparens modName 110 | modPart x = x == "." || all isUpper (take 1 x) 111 | 112 | 113 | --------------------------------------------------------------------- 114 | -- SELECTORS 115 | 116 | -- given .lbl1.lbl2 return ([lbl1,lbl2], whitespace, rest) 117 | spanFields :: [PL] -> ([String], String, [PL]) 118 | spanFields (NoW (PL "."):x@(PL fld):xs) | isField fld = (\(a,b,c) -> (fld:a,b,c)) $ 119 | case x of NoW{} -> spanFields xs; _ -> ([], getWhite x, xs) 120 | spanFields xs = ([], "", xs) 121 | 122 | 123 | editLoop :: [PL] -> [PL] 124 | 125 | -- Leave quasiquotations alone 126 | editLoop (p : ps) | isQuasiQuotation p = p : editLoop ps 127 | 128 | -- | a.b.c ==> getField @'(b,c) a 129 | editLoop (NoW e : (spanFields -> (fields@(_:_), whitespace, rest))) 130 | | not $ isCtor e 131 | = editLoop $ addWhite whitespace (paren [spc $ mkPL "Z.getField", spc $ mkPL $ makeField fields, e]) : rest 132 | 133 | -- (.a.b) ==> (getField @'(a,b)) 134 | editLoop (Paren start@(L "(") (spanFields -> (fields@(_:_), whitespace, [])) end:xs) 135 | = editLoop $ Paren start [spc $ mkPL "Z.getField", addWhite whitespace $ mkPL $ makeField fields] end : xs 136 | 137 | -- e{b.c=d, ...} ==> setField @'(b,c) d 138 | editLoop (e:Paren (L "{") inner end:xs) 139 | | not $ isCtor e 140 | , not $ isPL "::" e 141 | , getWhite e == "" 142 | , Just updates <- mapM f $ split (isPL ",") inner 143 | , let end2 = [Item end{lexeme=""} | whitespace end /= ""] 144 | = editLoop $ renderUpdate (Update e updates) : end2 ++ xs 145 | where 146 | f (NoW (PL field1) : (spanFields -> (fields, whitespace, xs))) 147 | | isField field1 148 | = g (field1:fields) xs 149 | f (x@(PL field1):xs) 150 | | isField field1 151 | = g [field1] xs 152 | f _ = Nothing 153 | 154 | g fields (op:xs) = Just (fields, if isPL "=" op then Nothing else Just op, Just $ paren xs) 155 | g fields [] = Just (fields, Nothing, Nothing) 156 | 157 | 158 | editLoop (Paren a b c:xs) = Paren a (editLoop b) c : editLoop xs 159 | editLoop (x:xs) = x : editLoop xs 160 | editLoop [] = [] 161 | 162 | 163 | --------------------------------------------------------------------- 164 | -- UPDATES 165 | 166 | data Update = Update 167 | PL -- The expression being updated 168 | [([String], Maybe PL, Maybe PL)] -- (fields, operator, body) 169 | 170 | renderUpdate :: Update -> PL 171 | renderUpdate (Update e upd) = case unsnoc upd of 172 | Nothing -> e 173 | Just (rest, (field, operator, body)) -> paren 174 | [spc $ mkPL $ if isNothing operator then "Z.setField" else "Z.modifyField" 175 | ,spc $ mkPL $ makeField $ if isNothing body then [last field] else field 176 | ,spc (renderUpdate (Update e rest)) 177 | ,case (operator, body) of 178 | (Just o, Just b) -> paren [spc $ if isPL "-" o then mkPL "subtract" else o, b] 179 | (Nothing, Just b) -> b 180 | (Nothing, Nothing) 181 | | [field] <- field -> mkPL field 182 | | f1:fs <- field -> paren [spc $ mkPL "Z.getField", spc $ mkPL $ makeField fs, mkPL f1] 183 | _ -> error "renderUpdate, internal error" 184 | ] 185 | 186 | 187 | --------------------------------------------------------------------- 188 | -- INSTANCES 189 | 190 | editAddInstances :: [PL] -> [PL] 191 | editAddInstances xs = xs ++ concatMap (\x -> [nl $ mkPL "", mkPL x]) 192 | [ "instance (aplg ~ (" ++ ftyp ++ ")) => Z.HasField \"" ++ fname ++ "\" " ++ rtyp ++ " aplg " ++ 193 | "where hasField _r = (\\_x -> case _r of {" ++ intercalate " ; " 194 | [ if fname `elem` map fst fields then 195 | "(" ++ cname ++ " " ++ 196 | unwords [if fst field == fname then "_" else "_x" ++ show i | (i, field) <- zipFrom 1 fields] ++ 197 | ") -> " ++ cname ++ " " ++ 198 | unwords [if fst field == fname then "_x" else "_x" ++ show i | (i, field) <- zipFrom 1 fields] 199 | else 200 | cname ++ "{} -> Prelude.error " ++ show ("Cannot update " ++ msg cname) 201 | | Ctor cname fields <- ctors] ++ 202 | "}, case _r of {" ++ intercalate " ; " 203 | [ if fname `elem` map fst fields then 204 | "(" ++ cname ++ " " ++ 205 | unwords [if fst field == fname then "_x1" else "_" | field <- fields] ++ 206 | ") -> _x1" 207 | else 208 | cname ++ "{} -> Prelude.error " ++ show ("Cannot get " ++ msg cname) 209 | | Ctor cname fields <- ctors] ++ 210 | "})" 211 | | Record rname rargs ctors <- parseRecords xs 212 | , let rtyp = "(" ++ unwords (rname : rargs) ++ ")" 213 | , (fname, ftyp) <- nubOrd $ concatMap ctorFields ctors 214 | , let msg cname = "field " ++ show fname ++ " of type " ++ show rname ++ " with constructor " ++ show cname 215 | ] 216 | 217 | -- | Represent a record, ignoring constructors. For example: 218 | -- 219 | -- > data Type a b = Ctor1 {field1 :: Int, field2 :: String} | Ctor2 {field1 :: Int, field3 :: [Bool]} 220 | -- 221 | -- Gets parsed as: 222 | -- 223 | -- > Record "Type" ["a","b"] 224 | -- > [Ctor "Ctor1" [("field1","Int"), ("field2","String")] 225 | -- > [Ctor "Ctor2" [("field1","Int"), ("field3","[Bool]")] 226 | data Record = Record 227 | {recordName :: String -- Name of the type (not constructor) 228 | ,recordTyArgs :: [String] -- Type arguments 229 | ,recordCtors :: [Ctor] 230 | } 231 | deriving Show 232 | 233 | data Ctor = Ctor 234 | {ctorName :: String -- Name of constructor 235 | ,ctorFields :: [(String, String)] -- (field, type) 236 | } 237 | deriving Show 238 | 239 | 240 | 241 | -- | Find all the records and parse them 242 | parseRecords :: [PL] -> [Record] 243 | parseRecords = mapMaybe whole . drop1 . split (isPL "data" ||^ isPL "newtype") 244 | where 245 | whole :: [PL] -> Maybe Record 246 | whole xs 247 | | PL typeName : xs <- xs 248 | , (typeArgs, _:xs) <- break (isPL "=" ||^ isPL "where") xs 249 | = Just $ Record typeName (mapMaybe typeArg typeArgs) $ ctor xs 250 | whole _ = Nothing 251 | 252 | -- some types are raw, some are in brackets (with a kind signature) 253 | typeArg (PL x) = Just x 254 | typeArg (Paren _ (x:_) _) = typeArg x 255 | typeArg _ = Nothing 256 | 257 | ctor xs 258 | | xs <- dropContext xs 259 | , PL ctorName : xs <- xs 260 | , xs <- dropWhile (isPL "::") xs 261 | , xs <- dropContext xs 262 | , Paren (L "{") inner _ : xs <- xs 263 | = Ctor ctorName (fields $ map (break (isPL "::")) $ split (isPL ",") inner) : 264 | case xs of 265 | PL "|":xs -> ctor xs 266 | _ -> [] 267 | ctor _ = [] 268 | 269 | -- we don't use a full parser so dealing with context like 270 | -- Num a => V3 { xx, yy, zz :: a } 271 | -- is hard. Fake it as best we can 272 | dropContext (Paren (L "(") _ _ : PL "=>" : xs) = xs 273 | dropContext (_ : _ : PL "=>": xs) = xs 274 | dropContext xs = xs 275 | 276 | fields ((x,[]):(y,z):rest) = fields $ (x++y,z):rest 277 | fields ((names, _:typ):rest) = [(name, dropWhile (== '!') $ trim $ unlexer $ unparens typ) | PL name <- names] ++ fields rest 278 | fields _ = [] 279 | 280 | -- if the user has a trailing comment want to rip it out so our brackets still work 281 | unlexer = concatMap $ \x -> lexeme x ++ [' ' | whitespace x /= ""] 282 | -------------------------------------------------------------------------------- /proposal/0000-record-dot-syntax.md: -------------------------------------------------------------------------------- 1 | --- 2 | author: Neil Mitchell and Shayne Fletcher 3 | date-accepted: "" 4 | proposal-number: "" 5 | ticket-url: "" 6 | implemented: "" 7 | --- 8 | 9 | This proposal is [discussed at this pull request](https://github.com/ghc-proposals/ghc-proposals/pull/0>). 10 | **After creating the pull request, edit this file again, update the number in 11 | the link, and delete this bold sentence.** 12 | 13 | # Record Dot Syntax 14 | 15 | Records in Haskell are [widely recognised](https://www.yesodweb.com/blog/2011/09/limitations-of-haskell) as being under-powered, with duplicate field names being particularly troublesome. We propose a new language extension `RecordDotSyntax` that provides syntactic sugar to make the features introduced in [the `HasField` proposal](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0158-record-set-field.rst) more accessible, improving the user experience. 16 | 17 | ## Motivation 18 | 19 | In almost every programming language we write `a.b` to mean the `b` field of the `a` record expression. In Haskell that becomes `b a`, and even then, only works if there is only one `b` in scope. Haskell programmers have struggled with this weakness, variously putting each record in a separate module and using qualified imports, or prefixing record fields with the type name. We propose bringing `a.b` to Haskell, which works regardless of how many `b` fields are in scope. Here's a simple example of what is on offer: 20 | 21 | ```haskell 22 | {-# LANGUAGE RecordDotSyntax #-} 23 | 24 | data Company = Company {name :: String, owner :: Person} 25 | data Person = Person {name :: String, age :: Int} 26 | 27 | display :: Company -> String 28 | display c = c.name ++ " is run by " ++ c.owner.name 29 | 30 | nameAfterOwner :: Company -> Company 31 | nameAfterOwner c = c{name = c.owner.name ++ "'s Company"} 32 | ``` 33 | 34 | We declare two records both having `name` as a field label. The user may then write `c.name` and `c.owner.name` to access those fields. We can also write `c{name = x}` as a record update, which works even though `name` is no longer unique. Under the hood, we make use of `getField` and `setField` from [the `HasField` proposal](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0158-record-set-field.rst). 35 | 36 | An implementation of this proposal has been battle tested and hardened over 18 months in the enterprise environment as part of [Digital Asset](https://digitalasset.com/)'s [DAML](https://daml.com/) smart contract language (a Haskell derivative utilizing GHC in its implementation), and also in a [Haskell preprocessor and a GHC plugin](https://github.com/ndmitchell/record-dot-preprocessor/). When initially considering Haskell as a basis for DAML, the inadequacy of records was considered the most severe problem, and without devising the scheme presented here, we wouldn't be using Haskell. The feature enjoys universal popularity with users. 37 | 38 | ## Proposed Change Specification 39 | 40 | For the specification we focus on the changes to the parsing rules, and the desugaring, with the belief the type checking and renamer changes required are an unambiguous consequences of those. To confirm these changes integrate as expected we have written [a prototype implementation](https://gitlab.haskell.org/shayne-fletcher-da/ghc/commits/record-dot-syntax) that parses and desugars the forms directly in the parser. For confirmation, we _do not_ view desugaring in the parser as the correct implementation choice, but it provides a simple mechanism to pin down the changes without going as far as adding additional AST nodes or type checker rules. 41 | 42 | ### `RecordDotSyntax` language extension 43 | 44 | This change adds a new language extension (enabled at source via `{-# LANGUAGE RecordDotSyntax #-}` or on the command line via the flag `-XRecordDotSyntax`). 45 | 46 | When `RecordDotSyntax` is in effect, the use of '.' to denote record field access is disambiguated from function composition by the absence of whitespace trailing the '.'. 47 | 48 | Suppose the following datatype declarations. 49 | 50 | ```haskell 51 | data Foo = Foo {foo :: Bar} 52 | data Bar = Bar {bar :: Baz} 53 | data Baz = Baz {baz :: Quux} 54 | data Quux = Quux {quux :: Int} 55 | ``` 56 | 57 | The existence of the builtin `HasField` typeclass means that it is possible to write code for getting and setting record fields like this: 58 | 59 | ```haskell 60 | getQuux :: Foo -> Int 61 | getQuux a = getField @"quux" (getField @"baz" (getField @"bar" (getField @"foo" a))) 62 | 63 | setQuux :: Foo -> Int -> Foo 64 | setQuux a i = setField@"foo" a (setField@"bar" (getField @"foo" a) (setField@"baz" (getField @"bar" (getField @"foo" a)) (setField@"quux" (getField @"baz" (getField @"bar" (getField @"foo" a))) i))) 65 | ``` 66 | 67 | `RecordDotSyntax` enables new concrete syntax so that the following program is equivalent. 68 | 69 | ```haskell 70 | getQuux a = a.foo.bar.baz.quux 71 | setQuux a i = a{foo.bar.baz.quux = i} 72 | ``` 73 | 74 | In the event the language extension is enabled: 75 | 76 | | Expression | Equivalent | 77 | | -- | -- | 78 | | `e.lbl` | `getField @"lbl" e` the `.` cannot have whitespace after | 79 | | `e{lbl = val}` | `setField @"lbl" e val` | 80 | | `(.lbl)` | `(\x -> x.lbl)` the `.` cannot have whitespace after | 81 | | `e{lbl1.lbl2 = val}` | `e{lbl1 = (e.lbl1){lbl2 = val}}` performing a nested update | 82 | | `e{lbl * val}` | `e{lbl = e.lbl * val}` where `*` can be any operator | 83 | | `e{lbl1.lbl2}` | `e{lbl1.lbl2 = lbl2}` when punning is enabled | 84 | 85 | The above forms combine to provide these identities: 86 | 87 | | Expression | Identity 88 | | -- | -- | 89 | | `e.lbl1.lbl2` | `(e.lbl1).lbl2` | 90 | | `(.lbl1.lbl2)` | `(\x -> x.lbl1.lbl2)` | 91 | | `e.lbl1{lbl2 = val}` | `(e.lbl1){lbl2 = val}` | 92 | | `e{lbl1 = val}.lbl2` | `(e{lbl1 = val}).lbl2` | 93 | | `e{lbl1.lbl2 * val}` | `e{lbl1.lbl2 = e.lbl1.lbl2 * val}` | 94 | | `e{lbl1 = val1, lbl2 = val2}` | `(e{lbl1 = val1}){lbl2 = val2}` | 95 | | `e{lbl1.lbl2, ..}` | `e{lbl2=lbl1.lbl2, ..}` when record wild cards are enabled | 96 | 97 | ### Lexer 98 | 99 | A new lexeme *fieldid* is introduced. 100 |
101 |
*lexeme* → *qvarid* | *qconid* | *qvarsym* | *qconsym* 102 | | *literal* | *special* | *reservedop* | *reservedid* | *fieldid* 103 |
*fieldid* → *.varid* 104 | 105 | This specification results in the following. 106 | 107 | ```haskell 108 | -- Regular expressions 109 | @fieldid = (\. @varid) 110 | ... 111 | <0,option_prags> { 112 | ... 113 | @fieldid / {ifExtension RecordDotSyntaxBit} { idtoken fieldid } 114 | } 115 | ... 116 | 117 | -- Token type 118 | data Token 119 | = ITas 120 | | ... 121 | | ITfieldid FastString 122 | ... 123 | 124 | -- Lexer actions 125 | fieldid :: StringBuffer -> Int -> Token 126 | fieldid buf len = let (_dot, buf') = nextChar buf in ITfieldid $! lexemeToFastString buf' (len - 1) 127 | ``` 128 | 129 | Tokens of case `ITfieldid` may not be issued if `RecordDotSyntax` is not enabled. 130 | 131 | ### Parser 132 | 133 | #### Field selections 134 | 135 | To support '.' field selection the *fexp* production is extended. 136 |
137 |
*fexp* → [ *fexp* ] *aexp* | *fexp* *fieldid* 138 | 139 | The specification expresses like this. 140 | 141 | ```haskell 142 | %token 143 | ... 144 | FIELDID { L _ (ITfieldid _) } 145 | %% 146 | 147 | ... 148 | 149 | fexp :: { ECP } 150 | : fexp aexp { ...} 151 | | fexp FIELDID { ...} -- <- here 152 | | ... 153 | ``` 154 | 155 | #### Field updates 156 | 157 | To support the new forms of '.' field update, the *aexp* production is extended. 158 |
159 |
*aexp* → *aexp⟨qcon⟩* { *pbind* , … , *pbind* } 160 |
*pbind* -> *qvar*=*exp* | *var* *fieldids*=*exp* | *var* *fieldids* *qop* *exp* | *var* [*fieldids*] 161 |
*fieldids* -> *fieldids* *fieldid* 162 | 163 | In this table, the newly added cases are shown next to an example expression they enable: 164 | 165 | | Production | Example | Commentary | 166 | | -- | -- | -- | 167 | |*var* *fieldids*=*exp* | `a{foo.bar=2}` | the *var* is `foo`, `.bar` is a fieldid | 168 | |*var* *fieldids* *qop* *exp* | `a{foo.bar * 12}` | update `a`'s `foo.bar` field to 12 times its initial value | 169 | |*var* [*fieldids*] | `a{foo.bar}` | means `a{foo.bar = bar}` when punning is enabled | 170 | 171 | For example, support for expressions like `a{foo.bar.baz.quux=i}` can be had with one additional case: 172 | 173 | ```haskell 174 | aexp1 :: { ECP } 175 | : aexp1 '{' fbinds '}' { ... } 176 | | aexp1 '{' VARID fieldids '=' texp '}' {...} -- <- here 177 | 178 | fieldids :: {[FastString]} 179 | fieldids 180 | : fieldids FIELDID { getFIELDID $2 : $1 } 181 | | FIELDID { [getFIELDID $1] } 182 | 183 | { 184 | getFIELDID (dL->L _ (ITfieldid x)) = x 185 | } 186 | ``` 187 | 188 | An implementation of `RecordDotSyntax` will have to do more than this to incorporate all alternatives. 189 | 190 | #### Sections 191 | 192 | To support '.' sections (e.g. `(.foo.bar.baz)`), we generalize *aexp*. 193 |
194 |
*aexp* → ( *infixexp* *qop* ) (left section) 195 | | ( *qop* *infixexp* ) (right section) 196 | | ( *fieldids* ) (projection (right) section) 197 | 198 | This specification implies the following additional case to `aexp2`. 199 | 200 | ```haskell 201 | aexp2 :: { ECP } 202 | ... 203 | | '(' texp ')' {...} 204 | | '(' fieldids ')' {...} -- <- here 205 | ``` 206 | 207 | ## Examples 208 | 209 | This is a record type with functions describing a study `Class` (*Oh! Pascal, 2nd ed. Cooper & Clancy, 1985*). 210 | 211 | ```haskell 212 | data Grade = A | B | C | D | E | F 213 | data Quarter = Fall | Winter | Spring 214 | data Status = Passed | Failed | Incomplete | Withdrawn 215 | 216 | data Taken = 217 | Taken { year : Int 218 | , term : Quarter 219 | } 220 | 221 | data Class = 222 | Class { hours : Int 223 | , units : Int 224 | , grade : Grade 225 | , result : Status 226 | , taken : Taken 227 | } 228 | 229 | getResult :: Class -> Status 230 | getResult c = c.result -- get 231 | 232 | setResult :: Class -> Status -> Class 233 | setResult c r = c{result = r} -- update 234 | 235 | setYearTaken :: Class -> Int -> Class 236 | setYearTaken c y = c{taken.year = y} -- nested update 237 | 238 | addYears :: Class -> Int -> Class 239 | addYears c n = c{taken.year + n} -- update via op 240 | 241 | squareUnits :: Class -> Class 242 | squareUnits c = c{units & (\x -> x * x)} -- update via function 243 | 244 | getResults :: [Class] -> [Status] 245 | getResults = map (.result) -- section 246 | 247 | getTerms :: [Class] -> [Quarter] 248 | getTerms = map (.taken.term) -- nested section 249 | ``` 250 | 251 | A full, rigorous set of examples (as tests) are available in the examples directory of [this repository](https://github.com/ndmitchell/record-dot-preprocessor). Those tests include infix applications, polymorphic data types, interoperation with other extensions and more. They follow the [specifications given earlier](#proposed-change-specification). 252 | 253 | ## Effect and Interactions 254 | 255 | **Polymorphic updates:** When enabled, this extension takes the `a{b=c}` syntax and uses it to mean `setField`. The biggest difference a user is likely to experience is that the resulting type of `a{b=c}` is the same as the type `a` - you _cannot_ change the type of the record by updating its fields. The removal of polymorphism is considered essential to preserve decent type inference, and is the only option supported by [the `HasField` proposal](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0158-record-set-field.rst). 256 | 257 | **Stealing a.b syntax:** The `a.b` syntax is commonly used in conjunction with the `lens` library, e.g. `expr^.field1.field2`. Treating `a.b` without spaces as a record projection would break such code. The alternatives would be to use a library with a different lens composition operator (e.g. `optics`), introduce an alias in `lens` for `.` (perhaps `%`), write such expressions with spaces, or not enable this extension when also using lenses. While unfortunate, we consider that people who are heavy users of lens don't feel the problems of inadequate records as strongly, so the problems are lessened. 258 | 259 | **Rebindable syntax:** When `RebindableSyntax` is enabled the `getField`, `setField` and `modifyField` functions are those in scope, rather than those in `GHC.Records`. 260 | 261 | **Enabled extensions:** When `RecordDotSyntax` is enabled it should imply the `NoFieldSelectors` extension and allow duplicate record field labels. It would be possible for `RecordDotSyntax` to imply `DuplicateRecordFields`, but we suspect that if people become comfortable with `RecordDotSyntax` then there will be a desire to remove the `DuplicateRecordFields` extension, so we don't want to build on top of it. 262 | 263 | ## Costs and Drawbacks 264 | 265 | The implementation of this proposal adds code to the compiler, but not a huge amount. Our [prototype implementation](https://gitlab.haskell.org/shayne-fletcher-da/ghc/commits/record-dot-syntax) shows the essence of the parsing changes, which is the most complex part. 266 | 267 | If this proposal becomes widely used then it is likely that all Haskell users would have to learn that `a.b` is a record field selection. Fortunately, given how popular this syntax is elsewhere, that is unlikely to surprise new users. 268 | 269 | This proposal advocates a different style of writing Haskell records, which is distinct from the existing style. As such, it may lead to the bifurcation of Haskell styles, with some people preferring the lens approach, and some people preferring the syntax presented here. That is no doubt unfortunate, but hard to avoid - `a.b` really is ubiquitous in programming languages. We consider that any solution to the records problem _must_ cause some level of divergence, but note that this mechanism (as distinct from some proposals) localises that divergence in the implementation of a module - users of the module will not know whether its internals used this extension or not. 270 | 271 | ## Alternatives 272 | 273 | The primary alternatives to the problem of records are: 274 | 275 | * Using the [`lens` library](https://hackage.haskell.org/package/lens). The concept of lenses is very powerful, but that power can be [complex to use](https://twitter.com/fylwind/status/549342595940237312?lang=en). In many ways lenses let you abstract over record fields, but Haskell has neglected the "unabstracted" case of concrete fields. 276 | * The [`DuplicateRecordFields` extension](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#duplicate-record-fields) is designed to solve similar problems. We evaluated this extension as the basis for DAML, but found it lacking. The rules about what types must be inferred by what point are cumbersome and tricky to work with, requiring a clear understanding of at what stage a type is inferred by the compiler. 277 | * Some style guidelines mandate that each record should be in a separate module. That works, but then requires qualified modules to access fields - e.g. `Person.name (Company.owner c)`. Forcing the structure of the module system to follow the records also makes circular dependencies vastly more likely, leading to complications such as boot files that are ideally avoided. 278 | * Some style guidelines suggest prefixing each record field with the type name, e.g. `personName (companyOwner c)`. While it works, it isn't pleasant, and many libraries then abbreviate the types to lead to code such as `prsnName (coOwner c)`, which can increase confusion. 279 | * There is a [GHC plugin and preprocessor](https://github.com/ndmitchell/record-dot-preprocessor) that both implement much of this proposal. While both have seen light use, their ergonomics are not ideal. The preprocessor struggles to give good location information given the necessary expansion of substrings. The plugin cannot support the full proposal and leads to error messages mentioning `getField`. Suggesting either a preprocessor or plugin to beginners is not an adequate answer. One of the huge benefits to the `a.b` style in other languages is support for completion in IDE's, which is quite hard to give for something not actually in the language. 280 | * Continue to [vent](https://www.reddit.com/r/haskell/comments/vdg55/haskells_record_system_is_a_cruel_joke/) [about](https://bitcheese.net/haskell-sucks) [records](https://medium.com/@snoyjerk/least-favorite-thing-about-haskal-ef8f80f30733) [on](https://www.quora.com/What-are-the-worst-parts-about-using-Haskell) [social](http://www.stephendiehl.com/posts/production.html) [media](https://www.drmaciver.com/2008/02/tell-us-why-your-language-sucks/). 281 | 282 | All these approaches are currently used, and represent the "status quo", where Haskell records are considered not fit for purpose. 283 | 284 | ## Unresolved Questions 285 | 286 | Below are some possible variations on this plan, but we advocate the choices made above: 287 | 288 | * Should `RecordDotSyntax` imply `NoFieldSelectors`? They are often likely to be used in conjunction, but they aren't inseparable. 289 | * It seems appealing that `a{field += 1}` would be the syntax for incrementing a field. However, `+=` is a valid operator (would that be `a{field +== 1}`?) and for infix operators like `div` would that be \`div\`=? 290 | * We do not extend pattern matching, although it would be possible for `P{foo.bar=Just x}` to be defined. 291 | 292 | ## Implementation Plan 293 | 294 | If accepted, the proposal authors would be delighted to provide an implementation. Implementation depends on the implementation of [the `HasField` proposal](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0158-record-set-field.rst) and [the `NoFieldSelectors` proposal](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0160-no-toplevel-field-selectors.rst). 295 | -------------------------------------------------------------------------------- /plugin/RecordDotPreprocessor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RecordWildCards, ViewPatterns, NamedFieldPuns, OverloadedStrings, LambdaCase #-} 3 | {-# LANGUAGE ImplicitParams, ScopedTypeVariables #-} 4 | {- HLINT ignore "Use camelCase" -} 5 | 6 | -- | Module containing the plugin. 7 | module RecordDotPreprocessor(plugin) where 8 | 9 | import Data.Generics.Uniplate.Data 10 | import Data.List.Extra 11 | import Data.Tuple.Extra 12 | import Compat 13 | import qualified GHC 14 | #if __GLASGOW_HASKELL__ > 901 15 | import qualified GHC.Types.SourceText as GHC 16 | #elif __GLASGOW_HASKELL__ >= 900 17 | import qualified GHC.Driver.Types as GHC 18 | #endif 19 | #if __GLASGOW_HASKELL__ < 900 20 | import Bag 21 | import qualified GhcPlugins as GHC 22 | import qualified HscMain 23 | import qualified PrelNames as GHC 24 | import SrcLoc 25 | #else 26 | import GHC.Data.Bag 27 | import qualified GHC.Driver.Plugins as GHC 28 | 29 | import qualified GHC.Driver.Main as HscMain 30 | import qualified GHC.Builtin.Names as GHC 31 | import qualified GHC.Plugins as GHC 32 | import GHC.Types.SrcLoc 33 | #endif 34 | #if __GLASGOW_HASKELL__ >= 906 35 | import qualified Data.List.NonEmpty as NE 36 | #endif 37 | 38 | --------------------------------------------------------------------- 39 | -- PLUGIN WRAPPER 40 | 41 | -- | GHC plugin. 42 | plugin :: GHC.Plugin 43 | plugin = GHC.defaultPlugin 44 | { GHC.parsedResultAction = \_cliOptions _modSummary -> ignoreMessages parsedResultAction 45 | , GHC.pluginRecompile = GHC.purePlugin 46 | } 47 | where 48 | #if __GLASGOW_HASKELL__ >= 904 49 | ignoreMessages :: (HsParsedModule -> GHC.Hsc HsParsedModule) -> GHC.ParsedResult -> GHC.Hsc GHC.ParsedResult 50 | ignoreMessages f (GHC.ParsedResult modl msgs) = 51 | (`GHC.ParsedResult` msgs) <$> f modl 52 | #else 53 | ignoreMessages = id 54 | #endif 55 | 56 | parsedResultAction x = do 57 | hscenv <- dropRnTraceFlags <$> HscMain.getHscEnv 58 | uniqSupply <- GHC.liftIO (GHC.mkSplitUniqSupply '0') 59 | uniqSupplyRef <- GHC.liftIO $ newIORef uniqSupply 60 | let ?hscenv = hscenv 61 | let ?uniqSupply = uniqSupplyRef 62 | pure x{GHC.hpm_module = onModule <$> GHC.hpm_module x} 63 | 64 | --------------------------------------------------------------------- 65 | -- PLUGIN GUTS 66 | 67 | setL :: SrcSpan -> GenLocated SrcSpan e -> GenLocated SrcSpan e 68 | setL l (L _ x) = L l x 69 | 70 | mod_records :: GHC.ModuleName 71 | mod_records = GHC.mkModuleName "GHC.Records.Extra" 72 | 73 | var_HasField, var_hasField, var_getField, var_setField, var_dot :: GHC.RdrName 74 | var_HasField = GHC.mkRdrQual mod_records $ GHC.mkClsOcc "HasField" 75 | var_hasField = GHC.mkRdrUnqual $ GHC.mkVarOcc "hasField" 76 | var_getField = GHC.mkRdrQual mod_records $ GHC.mkVarOcc "getField" 77 | var_setField = GHC.mkRdrQual mod_records $ GHC.mkVarOcc "setField" 78 | var_dot = GHC.mkRdrUnqual $ GHC.mkVarOcc "." 79 | 80 | #if __GLASGOW_HASKELL__ >= 904 81 | mod_base_records :: GHC.ModuleName 82 | mod_base_records = GHC.mkModuleName "GHC.Records" 83 | 84 | -- | GHC.Records.getField (as opposed to GHC.Records.Extra.getField) 85 | var_base_getField :: GHC.RdrName 86 | var_base_getField = GHC.mkRdrQual mod_base_records $ GHC.mkVarOcc "getField" 87 | #endif 88 | 89 | onModule :: PluginEnv => Module -> Module 90 | onModule x = x { hsmodImports = onImports $ hsmodImports x 91 | , hsmodDecls = concatMap (onDecl (unLoc <$> hsmodName x)) $ hsmodDecls x 92 | } 93 | 94 | 95 | onImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs] 96 | onImports = (++) [ 97 | qualifiedImplicitImport mod_records 98 | #if __GLASGOW_HASKELL__ >= 904 99 | , qualifiedImplicitImport mod_base_records 100 | #endif 101 | ] 102 | 103 | {- 104 | instance Z.HasField "name" (Company) (String) where hasField _r = (\_x -> _r{name=_x}, (name:: (Company) -> String) _r) 105 | 106 | instance HasField "selector" Record Field where 107 | hasField r = (\x -> r{selector=x}, (name :: Record -> Field) r) 108 | -} 109 | instanceTemplate :: FieldOcc GhcPs -> HsType GhcPs -> HsType GhcPs -> InstDecl GhcPs 110 | instanceTemplate selector record field = ClsInstD noE $ ClsInstDecl 111 | #if __GLASGOW_HASKELL__ >= 902 112 | (noE, mempty) (hsTypeToHsSigType $ reLocA typ) 113 | #else 114 | noE (HsIB noE typ) 115 | #endif 116 | (unitBag has) [] [] [] Nothing 117 | where 118 | typ' :: HsType GhcPs -> LHsType GhcPs 119 | typ' a = mkHsAppTys 120 | (noL (HsTyVar noE GHC.NotPromoted (noL var_HasField))) 121 | [fieldNameAsType 122 | ,noL record 123 | ,noL a 124 | ] 125 | 126 | typ = noL $ makeEqQualTy field (unLoc . typ') 127 | 128 | fieldNameAsType :: LHsType GhcPs 129 | fieldNameAsType = noL (HsTyLit noE (HsStrTy GHC.NoSourceText (GHC.occNameFS $ GHC.occName $ unLoc $ rdrNameFieldOcc selector))) 130 | 131 | has :: LHsBindLR GhcPs GhcPs 132 | has = noL $ newFunBind (noL var_hasField) (mg1 eqn) 133 | where 134 | eqn :: Match GhcPs (LHsExpr GhcPs) 135 | eqn = Match 136 | { m_ext = noE 137 | , m_ctxt = FunRhs (noL var_hasField) GHC.Prefix NoSrcStrict 138 | , m_pats = compat_m_pats [VarPat noE $ noL vR] 139 | , m_grhss = GRHSs noE [noL $ GRHS noE [] $ noL $ ExplicitTuple noE [ noL $ Present noE set, noL $ Present noE get] GHC.Boxed] (noL $ EmptyLocalBinds noE) 140 | } 141 | set = noL $ HsLam noE $ mg1 Match 142 | { m_ext = noE 143 | , m_ctxt = LambdaExpr 144 | , m_pats = compat_m_pats [VarPat noE $ noL vX] 145 | , m_grhss = GRHSs noE [noL $ GRHS noE [] $ noL update] (noL $ EmptyLocalBinds noE) 146 | } 147 | update :: HsExpr GhcPs 148 | update = RecordUpd noE (noL $ GHC.HsVar noE $ noL vR) 149 | #if __GLASGOW_HASKELL__ >= 908 150 | $ RegularRecUpdFields noE 151 | #elif __GLASGOW_HASKELL__ >= 902 152 | $ Left 153 | #endif 154 | #if __GLASGOW_HASKELL__ >= 904 155 | [noL $ HsFieldBind 156 | #else 157 | [noL $ HsRecField 158 | #endif 159 | #if __GLASGOW_HASKELL__ >= 902 160 | noE 161 | #endif 162 | (noL (Unambiguous noE (rdrNameFieldOcc selector))) (noL $ GHC.HsVar noE $ noL vX) False] 163 | #if __GLASGOW_HASKELL__ >= 904 164 | get :: LHsExpr GhcPs 165 | get = 166 | noL (GHC.HsVar noE $ noL var_base_getField) 167 | `mkAppType` 168 | fieldNameAsType 169 | `mkApp` 170 | noL (GHC.HsVar noE $ noL vR) 171 | #else 172 | get = mkApp 173 | (mkParen $ mkTypeAnn (noL $ GHC.HsVar noE $ rdrNameFieldOcc selector) (mkFunTy (noL record) (noL field))) 174 | (noL $ GHC.HsVar noE $ noL vR) 175 | #endif 176 | 177 | mg1 :: Match GhcPs (LHsExpr GhcPs) -> MatchGroup GhcPs (LHsExpr GhcPs) 178 | #if __GLASGOW_HASKELL__ >= 906 179 | mg1 x = MG noE (noL [noL x]) 180 | #else 181 | mg1 x = MG noE (noL [noL x]) GHC.Generated 182 | #endif 183 | 184 | vR = GHC.mkRdrUnqual $ GHC.mkVarOcc "r" 185 | vX = GHC.mkRdrUnqual $ GHC.mkVarOcc "x" 186 | 187 | 188 | onDecl :: PluginEnv => Maybe GHC.ModuleName -> LHsDecl GhcPs -> [LHsDecl GhcPs] 189 | onDecl modName o@(L _ (GHC.TyClD _ x)) = o : 190 | [ noL $ InstD noE $ instanceTemplate field (unLoc record) (unbang typ) 191 | | let fields = nubOrdOn (\(_,_,x,_) -> mkNonDetFastString $ GHC.occNameFS $ GHC.rdrNameOcc $ unLoc $ rdrNameFieldOcc x) $ getFields modName x 192 | , (record, _, field, typ) <- fields] 193 | onDecl _ x = [descendBi onExp x] 194 | 195 | unbang :: HsType GhcPs -> HsType GhcPs 196 | unbang (HsBangTy _ _ x) = unLoc x 197 | unbang x = x 198 | 199 | getFields :: PluginEnv => Maybe GHC.ModuleName -> TyClDecl GhcPs -> [(LHsType GhcPs, IdP GhcPs, FieldOcc GhcPs, HsType GhcPs)] 200 | getFields modName DataDecl{tcdDataDefn=HsDataDefn{..}, ..} = concatMap ctor dd_cons 201 | where 202 | ctor :: LConDecl GhcPs -> [(LHsType GhcPs, GHC.RdrName, FieldOcc GhcPs, HsType GhcPs)] 203 | ctor (L _ con) = [(reLocA result, name, fld, ty) | (name, fld, ty) <- conClosedFields (defVars tcdTyVars) con] 204 | 205 | defVars :: LHsQTyVars GhcPs -> [GHC.RdrName] 206 | defVars vars = [v | L _ v <- hsLTyVarLocNames vars] 207 | 208 | -- A value of this data declaration will have this type. 209 | result = foldl (\x y -> noL $ HsAppTy noE (reLocA x) $ hsLTyVarBndrToType y) (noL $ HsTyVar noE GHC.NotPromoted tyName) $ hsq_explicit tcdTyVars 210 | tyName = case (tcdLName, modName) of 211 | (L l (GHC.Unqual name), Just modName') -> L l (GHC.Qual modName' name) 212 | _ -> tcdLName 213 | getFields _ _ = [] 214 | 215 | -- Extract filed and its type from declaration, omitting fields with existential/higher-kind types. 216 | conClosedFields :: PluginEnv => [GHC.RdrName] -> ConDecl GhcPs -> [(IdP GhcPs, FieldOcc GhcPs, HsType GhcPs)] 217 | conClosedFields resultVars = \case 218 | ConDeclH98 {con_args = RecCon (L _ args), con_name, con_ex_tvs} -> 219 | [ (unLoc con_name, unLoc name, unLoc ty) 220 | | ConDeclField {cd_fld_names, cd_fld_type = ty} <- universeBi args, 221 | null (freeTyVars' ty \\ resultVars), 222 | not $ isLHsForAllTy ty, 223 | name <- cd_fld_names 224 | ] 225 | #if __GLASGOW_HASKELL__ >= 904 226 | ConDeclGADT {con_g_args = RecConGADT (L _ args) _, con_res_ty, con_names} -> 227 | #elif __GLASGOW_HASKELL__ >= 901 228 | ConDeclGADT {con_g_args = RecConGADT (L _ args), con_res_ty, con_names} -> 229 | #else 230 | ConDeclGADT {con_args = RecCon (L _ args), con_res_ty, con_names} -> 231 | #endif 232 | [ (unLoc con_name, unLoc name, unLoc ty) 233 | | ConDeclField {cd_fld_names, cd_fld_type = ty} <- universeBi args, 234 | null (freeTyVars ty \\ freeTyVars con_res_ty), 235 | not $ isLHsForAllTy ty, 236 | name <- cd_fld_names, 237 | #if __GLASGOW_HASKELL__ >= 906 238 | con_name <- NE.toList con_names 239 | #else 240 | con_name <- con_names 241 | #endif 242 | ] 243 | _ -> [] 244 | where 245 | freeTyVars' ty = unLoc <$> freeTyVars ty 246 | 247 | -- At this point infix expressions have not had associativity/fixity applied, so they are bracketed 248 | -- a + b + c ==> (a + b) + c 249 | -- Therefore we need to deal with, in general: 250 | -- x.y, where 251 | -- x := a | a b | a.b | a + b 252 | -- y := a | a b | a{b=1} 253 | onExp :: LHsExpr GhcPs -> LHsExpr GhcPs 254 | onExp (reLoc -> L o (OpApp _ lhs mid@(isDot -> True) rhs)) 255 | | adjacent lhs mid, adjacent mid rhs 256 | , (lhsOp, lhs) <- getOpRHS $ onExp lhs 257 | , (lhsApp, lhs) <- getAppRHS lhs 258 | , (rhsApp, rhs) <- getAppLHS rhs 259 | , (rhsRec, rhs) <- getRec rhs 260 | , Just sel <- getSelector rhs 261 | = onExp $ reLocA $ setL o $ reLoc $ lhsOp $ rhsApp $ lhsApp $ rhsRec $ mkParen $ mkVar var_getField `mkAppType` sel `mkApp` lhs 262 | 263 | -- Turn (.foo.bar) into getField calls 264 | onExp (reLoc -> L o (SectionR _ mid@(isDot -> True) rhs)) 265 | | adjacent mid rhs 266 | , srcSpanStart o == srcSpanStart (getLoc $ reLoc mid) 267 | , srcSpanEnd o == srcSpanEnd (getLoc $ reLoc rhs) 268 | , Just sels <- getSelectors rhs 269 | -- Don't bracket here. The argument came in as a section so it's 270 | -- already enclosed in brackets. 271 | = reLocA $ setL o $ foldl1 (\x y -> noL $ OpApp noE (reLocA x) (mkVar var_dot) (reLocA y)) 272 | $ map ( \ sel -> reLoc $ mkVar var_getField `mkAppType` sel) $ reverse sels 273 | 274 | -- Turn a{b=c, ...} into setField calls 275 | #if __GLASGOW_HASKELL__ >= 908 276 | onExp (L o upd@RecordUpd{rupd_expr,rupd_flds= RegularRecUpdFields _ (fld:flds)}) 277 | #elif __GLASGOW_HASKELL__ >= 902 278 | onExp (L o upd@RecordUpd{rupd_expr,rupd_flds= Left (fld:flds)}) 279 | #else 280 | onExp (L o upd@RecordUpd{rupd_expr,rupd_flds= fld:flds}) 281 | #endif 282 | | adjacentBy 1 rupd_expr fld 283 | = onExp $ f rupd_expr $ map unLoc $ fld:flds 284 | where 285 | #if __GLASGOW_HASKELL__ >= 908 286 | f :: LHsExpr GhcPs -> [HsRecUpdField GhcPs GhcPs] -> LHsExpr GhcPs 287 | #else 288 | f :: LHsExpr GhcPs -> [HsRecUpdField GhcPs] -> LHsExpr GhcPs 289 | #endif 290 | f expr [] = expr 291 | #if __GLASGOW_HASKELL__ >= 908 292 | f expr (HsFieldBind { hfbLHS = fmap ambiguousFieldOccRdrName . reLoc -> lbl 293 | , hfbRHS = arg 294 | , hfbPun = pun 295 | } : flds) 296 | #elif __GLASGOW_HASKELL__ >= 904 297 | f expr (HsFieldBind { hfbLHS = fmap rdrNameAmbiguousFieldOcc . reLoc -> lbl 298 | , hfbRHS = arg 299 | , hfbPun = pun 300 | } : flds) 301 | #else 302 | f expr (HsRecField { hsRecFieldLbl = fmap rdrNameAmbiguousFieldOcc -> lbl 303 | , hsRecFieldArg = arg 304 | , hsRecPun = pun 305 | } : flds) 306 | #endif 307 | | let sel = mkSelector lbl 308 | , let arg2 = if pun then noL $ HsVar noE (reLocA lbl) else arg 309 | , let expr2 = mkParen $ mkVar var_setField `mkAppType` sel `mkApp` expr `mkApp` arg2 -- 'expr' never needs bracketing. 310 | = f expr2 flds 311 | 312 | onExp x = descend onExp x 313 | 314 | mkSelector :: Located GHC.RdrName -> LHsType GhcPs 315 | mkSelector (L o x) = reLocA $ L o $ HsTyLit noE $ HsStrTy GHC.NoSourceText $ GHC.occNameFS $ GHC.rdrNameOcc x 316 | 317 | getSelector :: LHsExpr GhcPs -> Maybe (LHsType GhcPs) 318 | getSelector (L _ (HsVar _ (reLoc -> L o sym))) 319 | | not $ GHC.isQual sym 320 | = Just $ mkSelector $ L o sym 321 | getSelector _ = Nothing 322 | 323 | -- | Turn a.b.c into Just [a,b,c] 324 | getSelectors :: LHsExpr GhcPs -> Maybe [LHsType GhcPs] 325 | getSelectors (L _ (OpApp _ lhs mid@(isDot -> True) rhs)) 326 | | adjacent lhs mid, adjacent mid rhs 327 | , Just post <- getSelector rhs 328 | , Just pre <- getSelectors lhs 329 | = Just $ pre ++ [post] 330 | getSelectors x = (:[]) <$> getSelector x 331 | 332 | -- | Lens on: f [x] 333 | getAppRHS :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs) 334 | getAppRHS (L l (HsApp e x y)) = (L l . HsApp e x, y) 335 | getAppRHS x = (id, x) 336 | 337 | -- | Lens on: [f] x y z 338 | getAppLHS :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs) 339 | getAppLHS (L l (HsApp e x y)) = first (\c -> L l . (\x -> HsApp e x y) . c) $ getAppLHS x 340 | getAppLHS x = (id, x) 341 | 342 | -- | Lens on: a + [b] 343 | getOpRHS :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs) 344 | getOpRHS (L l (OpApp x y p z)) = (L l . OpApp x y p, z) 345 | getOpRHS x = (id, x) 346 | 347 | -- | Lens on: [r]{f1=x1}{f2=x2} 348 | getRec :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs) 349 | -- important to copy the location back over, since we check the whitespace hasn't changed 350 | getRec (L l r@RecordUpd{}) = first (\c x -> L l r{rupd_expr=reLocA $ setL (getLoc $ reLoc $ rupd_expr r) $ reLoc $ c x }) $ getRec $ rupd_expr r 351 | getRec x = (id, x) 352 | 353 | -- | Is it equal to: . 354 | isDot :: LHsExpr GhcPs -> Bool 355 | isDot (L _ (HsVar _ (L _ op))) = op == var_dot 356 | isDot _ = False 357 | 358 | mkVar :: GHC.RdrName -> LHsExpr GhcPs 359 | mkVar = noL . HsVar noE . noL 360 | 361 | mkParen :: LHsExpr GhcPs -> LHsExpr GhcPs 362 | mkParen = mkHsPar 363 | 364 | mkApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs 365 | mkApp x y = noL $ HsApp noE x y 366 | 367 | #if __GLASGOW_HASKELL__ >= 902 368 | -- | Are the end of a and the start of b next to each other, no white space 369 | adjacent :: GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool 370 | 371 | -- | Are the end of a and the start of b next to each other, no white space 372 | adjacentBy :: Int -> GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool 373 | #else 374 | adjacent :: Located a -> Located b -> Bool 375 | adjacentBy :: Int -> Located a -> Located b -> Bool 376 | 377 | #endif 378 | adjacent = adjacentBy 0 379 | 380 | adjacentBy i (reLoc -> L (realSrcLoc . srcSpanEnd -> Just a) _) (reLoc -> L (realSrcLoc . srcSpanStart -> Just b) _) = 381 | srcLocFile a == srcLocFile b && 382 | srcLocLine a == srcLocLine b && 383 | srcLocCol a + i == srcLocCol b 384 | adjacentBy _ _ _ = False 385 | 386 | 387 | -- Given: 388 | -- C f Int and \x -> HasField "field" Entity x 389 | -- Returns: 390 | -- ((C f Int) ~ aplg) => HasField "field" Entity aplg 391 | makeEqQualTy :: HsType GhcPs -> (HsType GhcPs -> HsType GhcPs) -> HsType GhcPs 392 | makeEqQualTy rArg fAbs 393 | = HsQualTy noE 394 | ( 395 | #if __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 904 396 | Just $ 397 | #endif 398 | noL qualCtx 399 | ) 400 | (noL (fAbs tyVar)) 401 | where 402 | var = GHC.nameRdrName $ GHC.mkUnboundName $ GHC.mkTyVarOcc "aplg" 403 | 404 | tyVar :: HsType GhcPs 405 | tyVar = HsTyVar noE GHC.NotPromoted (noL var) 406 | 407 | var_tilde = GHC.mkOrig GHC.gHC_TYPES $ GHC.mkClsOcc "~" 408 | 409 | eqQual :: HsType GhcPs 410 | eqQual = 411 | HsOpTy 412 | #if __GLASGOW_HASKELL__ >= 904 413 | EpAnnNotUsed 414 | GHC.NotPromoted -- TODO: Is this right? 415 | #else 416 | noE 417 | #endif 418 | (noL (HsParTy noE (noL rArg))) 419 | (noL var_tilde) 420 | (noL tyVar) 421 | 422 | qualCtx :: HsContext GhcPs 423 | qualCtx = [noL (HsParTy noE (noL eqQual))] 424 | --------------------------------------------------------------------------------