record-dot-preprocessor 0.1.5 → 0.2
raw patch · 19 files changed
+962/−363 lines, 19 filesdep +ghcdep +record-dot-preprocessordep +record-hasfielddep ~base
Dependencies added: ghc, record-dot-preprocessor, record-hasfield, uniplate
Dependency ranges changed: base
Files
- CHANGES.txt +5/−0
- README.md +26/−9
- examples/Both.hs +77/−0
- examples/Preprocessor.hs +79/−0
- examples/Readme.hs +13/−0
- plugin/Compat.hs +50/−0
- plugin/RecordDotPreprocessor.hs +215/−0
- preprocessor/Edit.hs +205/−0
- preprocessor/Lexer.hs +109/−0
- preprocessor/Paren.hs +35/−0
- preprocessor/Preprocessor.hs +28/−0
- record-dot-preprocessor.cabal +47/−7
- src/Edit.hs +0/−165
- src/Lexer.hs +0/−84
- src/Main.hs +0/−46
- src/Paren.hs +0/−31
- src/Unlexer.hs +0/−21
- test/PluginExample.hs +24/−0
- test/Test.hs +49/−0
CHANGES.txt view
@@ -1,5 +1,10 @@ Changelog for record-dot-preprocessor +0.2, released 2019-03-29+ Add a GHC source plugin+ Support for e{foo.bar}+ Support for (.foo.bar)+ a.b{c=d} now equivalent to (a.b){c=d}, previously was a{b.c=d} 0.1.5, released 2019-02-09 #10, support fields named 'x' 0.1.4, released 2018-09-07
README.md view
@@ -1,4 +1,4 @@-# record-dot-preprocessor [](https://hackage.haskell.org/package/record-dot-preprocessor) [](https://www.stackage.org/package/record-dot-preprocessor) [](https://travis-ci.org/ndmitchell/record-dot-preprocessor)+# record-dot-preprocessor [](https://hackage.haskell.org/package/record-dot-preprocessor) [](https://www.stackage.org/package/record-dot-preprocessor) [](https://travis-ci.org/ndmitchell/record-dot-preprocessor) 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 Haskell. Some examples: @@ -17,20 +17,37 @@ ## How do I use this magic? -First install `record-dot-preprocessor` with either `stack install record-dot-preprocessor` or `cabal update && cabal install record-dot-preprocessor`. Then add `{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-}` to the top of the file. Suddenly your records will work. You must make sure that the preprocessor is applied both to the file where your records are defined, and where the record syntax is used.+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: -The resulting program will require GHC 8.2 or above and the [`lens` library](https://hackage.haskell.org/package/lens), or a module called `Control.Lens` exporting the contents of [`Lens.Micro` from `microlens`](https://hackage.haskell.org/package/microlens/docs/Lens-Micro.html) (which has significantly less dependencies).+* Either: `{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-}` for the preprocessor.+* Or: `{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}` and `{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}` for the GHC plugin. +The GHC plugin only runs on GHC 8.6 or higher, [doesn't work 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.++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).+ ## What magic is available, precisely? -* `e.b`, where `e` is an expression (not a constructor) and there are no whitespace on either side of the `.`, is translated to a record lookup. If you want to use the standard `.` function composition operator, insert a space. If you want to use a qualfied module name, then `e` will look like a constructor, so it won't clash.-* `e{b = c}` is a record update. Provided the record was defined in a module where `record-dot-preprocessor` was used, the meaning will be equivalent to before. If you want to use a normal unchanged record update, insert a space before the `{`.-* `e{b * c}`, where `*` is an arbitrary operator, is equivalent to `e{b = e.b * c}`. If you want to apply an arbitrary function as `c`, use the `&` operator. Think `e.b *= c` in C-style languages.-* `e.b.c{d.e * 1, f.g = 2}` also works and all variants along those lines.+Using the preprocessor or the GHC plugin you can write: -## I don't believe in magic, what's the underlying science?+* `expr.lbl` is equivalent to `getField @"lbl" expr` (the `.` cannot have whitespace on either side).+* `expr{lbl = val}` is equivalent to `setField @"lbl" expr val`.+* `(.lbl)` is equivalent to `(\x -> x.lbl)` (the `.` cannot have whitespace after). -On the way back from [ZuriHac 2017](https://2017.zurihac.info/) [Neil Mitchell](https://ndmitchell.com) and [Mathieu Boespflug](https://www.tweag.io/contact) were discussing lenses and the sad state of records in Haskell. We both agreed that overloaded labels should be defined such that they resolve to lenses. With the right instances, you could define `a ^. #foo` to get the `foo` field from the expression `a`. This preprocessor just turns `a.foo` into `a ^. #foo`, and generates the right instances. If you really want to see the magic under the hood simply run `record-dot-preprocessor yourfile.hs` and it will print out what it generates.+Using the preprocessor, but _not_ the GHC plugin:++* `expr{lbl1.lbl2 = val}` is equivalent to `expr{lbl1 = (expr.lbl1){lbl2 = val}}`, performing a nested update.+* `expr{lbl * val}` is equivalent to `expr{lbl = expr.lbl * val}`, where `*` can be any operator.+* `expr{lbl1.lbl2}` is equivalent to `expr{lbl1.lbl2 = lbl2}`.++These forms combine to offer the identities:++* `expr.lbl1.lbl2` is equivalent to `(expr.lbl1).lbl2`.+* `(.lbl1.lbl2)` is equivalent to `(\x -> x.lbl1.lbl2)`.+* `expr.lbl1{lbl2 = val}` is equivalent to `(expr.lbl1){lbl2 = val}`.+* `expr{lbl1 = val}.lbl2` is equivalent to `(expr{lbl1 = val}).lbl2`.+* `expr{lbl1.lbl2 * val}` is equivalent to `expr{lbl1.lbl2 = expr.lbl1.lbl2 * val}`.+* `expr{lbl1 = val1, lbl2 = val2}` is equivalent to `(expr{lbl1 = val1}){lbl2 = val2}`. ## How does this magic compare to other magic?
+ examples/Both.hs view
@@ -0,0 +1,77 @@+-- Test for everything that is supported by both the plugin and the preprocessor++{-# OPTIONS_GHC -Werror -Wall -Wno-type-defaults -Wno-partial-type-signatures #-} -- can we produce -Wall clean code+{-# LANGUAGE PartialTypeSignatures #-} -- also tests we put language extensions before imports++main :: IO ()+main = test1 >> test2 >> putStrLn "Both worked"++(===) :: (Show a, Eq a) => a -> a -> IO ()+a === b = if a == b then return () else fail $ "Mismatch, " ++ show a ++ " /= " ++ show b+++---------------------------------------------------------------------+-- CHECK THE BASICS WORK++data Foo a = Foo {foo1 :: !a, _foo2 :: Int} deriving (Show,Eq)++test1 :: IO ()+test1 = do+ -- test expr.lbl+ (Foo "test" 1).foo1 === "test"+ let foo = Foo "test" 2+ foo.foo1 === "test"+ foo._foo2 === 2+ (Foo (1,2) 3).foo1._1 === 1+ let foo2 = Foo (1,2) 3+ foo2.foo1._2 === 2+ (foo2.foo1)._2 === 2++ -- test expr{lbl = val}+ foo {foo1 = "a"} === Foo "a" 2+ foo {foo1 = "a", foo1 = "b"} === foo{foo1 = "b"}+ null (foo{foo1 = []}.foo1) === True+ foo{foo1 = "a"}.foo1 === "a"+ let _foo2 = 8 in foo{_foo2} === Foo "test" 8++ -- (.lbl)+ map (.foo1) [foo, foo{foo1="q"}] === ["test", "q"]+ ( .foo1._foo2 ) (Foo foo 3) === 2+++---------------------------------------------------------------------+-- DEAL WITH INFIX APPLICATIONS AND ASSOCIATIVITY++data Company = Company {name :: String, owner :: Person -- trailing comment+ }+data Person = Person {name :: String, age :: Int}++test2 :: IO ()+test2 = do+ let c = Company "A" $ Person "B" 3+ let x = True+ (===) "A" $ f c.name x+ (===) "B" $ f c.owner.name x+ (===) "A" $ gL $ 1 @+ c.name @+ True+ (===) "B" $ gL $ 1 @+ c.owner.name @+ True+ (===) "A" $ gL $ 1 @+ f c.name x @+ True+ (===) "B" $ gL $ 1 @+ f c.owner.name x @+ True+ (===) "A" $ gR $ 1 +@ c.name +@ True+ (===) "B" $ gR $ 1 +@ c.owner.name +@ True+ (===) "A" $ gR $ 1 +@ f c.name x +@ True+ (===) "B" $ gR $ 1 +@ f c.owner.name x +@ True++f :: String -> Bool -> String+f x _ = x++infixl 9 @++infixr 9 +@+(@+), (+@) :: _+(@+) = (,)+(+@) = (,)++gL :: ((Int, String), Bool) -> String+gL ((_,x),_) = x++gR :: (Int, (String, Bool)) -> String+gR (_,(x,_)) = x
+ examples/Preprocessor.hs view
@@ -0,0 +1,79 @@+-- Test for things only supported by the preprocessor++{-# OPTIONS_GHC -Werror -Wall -Wno-type-defaults #-} -- can we produce -Wall clean code+{-# LANGUAGE ScopedTypeVariables #-}++-- can you deal with modules and existing extensions+module Main(main) where++import Control.Exception+import Data.Function+import Data.Char+import Data.List+++fails :: a -> IO ()+fails val = do+ res <- try $ evaluate val+ case res of+ Left (_ :: SomeException) -> return ()+ Right _ -> fail "Expected an exception"++(===) :: (Show a, Eq a) => a -> a -> IO ()+a === b = if a == b then return () else fail $ "Mismatch, " ++ show a ++ " /= " ++ show b+++-- can you deal with multiple alternatives+data Animal = Human {name :: !String, job :: Prelude.String}+ | Nonhuman {name :: String}+ deriving (Show,Eq)++test1 :: IO ()+test1 = do+ (Human "a" "b").name === "a" -- comment here+ (Nonhuman "x").name === "x"+ fails (Nonhuman "x").job++-- can you deal with polymorphism+data Foo a b = Foo {name :: (a, Maybe b), the_b :: b, x :: Int}+ deriving (Show,Eq)++data Person = Person {age :: Int, address :: String}+ deriving (Show,Eq)++test2 :: IO ()+test2 = do+ let foo1 = Foo{name=(1, Nothing), the_b=Human "a" "b", x=1}+ let foo2 = Foo (19, Just 2) 2 1+ foo1.the_b.job === "b"+ foo2.name._1 === 19+ foo2.x === 1++ -- check complex updates+ foo2{the_b = 8}.the_b === 8+ foo1{the_b.job = "c"} === foo1{the_b = foo1.the_b{job = "c"}}+ foo1.the_b{job ++ "b"} === (foo1.the_b){job = "bb"}+ foo1{the_b.job ++ "b", the_b.name = "q"} === foo1{the_b = Human "q" "bb"}+ foo1{the_b.job `union` "qbz"} === foo1{the_b = Human "a" "bqz"}++ -- check updates are ordered correctly+ foo1{the_b = Human "x" "y", the_b.job="z"} === foo1{the_b = Human "x" "z"}++ -- check for nesting+ (foo1.the_b).job === "b"+ foo1{the_b = foo1.the_b{job="r"}}.the_b.job === "r"+ (foo1{the_b.job="n"}){the_b.name="m"}.the_b === Human "m" "n"+ let foo11 = (foo1, foo1)+ foo11._1.the_b{job="n"} === Human "a" "n"++ let person = Person 10 "Home"+ (person{age - 3}){age * 2} === person{age = 14}++ -- check for puns+ let human = Human "x" "y"+ human{foo1.the_b.job} === Human "x" "b"+ human{foo1.the_b.job, name & map toUpper} === Human "X" "b"+++main :: IO ()+main = test1 >> test2 >> putStrLn "Preprocessor worked"
+ examples/Readme.hs view
@@ -0,0 +1,13 @@+-- This is the example from README.md to test++data Company = Company {name :: String, owner :: Person}+data Person = Person {name :: String, age :: Int}++display :: Company -> String+display c = c.name ++ " is run by " ++ c.owner.name++nameAfterOwner :: Company -> Company+nameAfterOwner c = c{name = c.owner.name ++ "'s Company"}++main = putStrLn $ display $ nameAfterOwner c+ where c = Company "A" $ Person "B" 3
+ plugin/Compat.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-}+{- HLINT ignore "Use camelCase" -}++-- | Module containing the plugin.+module Compat(module Compat) where++import qualified GHC+import HsSyn+import SrcLoc++---------------------------------------------------------------------+-- UTILITIES++noL :: e -> GenLocated SrcSpan e+noL = noLoc++noE :: GHC.NoExt+noE = GHC.NoExt+++---------------------------------------------------------------------+-- COMMON SIGNATURES++mkAppType :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs+mkTypeAnn :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs+++#if __GLASGOW_HASKELL__ < 807++---------------------------------------------------------------------+-- GHC 8.6++mkAppType expr typ = noL $ HsAppType (HsWC noE typ) expr+mkTypeAnn expr typ = noL $ ExprWithTySig (HsWC noE (HsIB noE typ)) expr++compat_m_pats :: [Pat GhcPs] -> [LPat GhcPs]+compat_m_pats = map noL++#else++---------------------------------------------------------------------+-- GHC HEAD++mkAppType expr typ = noL $ HsAppType noE expr (HsWC noE typ)+mkTypeAnn expr typ = noL $ ExprWithTySig noE expr (HsWC noE (HsIB noE typ))++compat_m_pats :: [Pat GhcPs] -> [Pat GhcPs]+compat_m_pats = id++#endif
+ plugin/RecordDotPreprocessor.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE RecordWildCards, ViewPatterns, NamedFieldPuns #-}+{- HLINT ignore "Use camelCase" -}++-- | Module containing the plugin.+module RecordDotPreprocessor(plugin) where++import Data.Generics.Uniplate.Data+import Data.List.Extra+import Data.Tuple.Extra+import Compat+import Bag+import qualified GHC+import qualified GhcPlugins as GHC+import HsSyn+import SrcLoc+import TcEvidence+++---------------------------------------------------------------------+-- PLUGIN WRAPPER++-- | GHC plugin.+plugin :: GHC.Plugin+plugin = GHC.defaultPlugin+ { GHC.parsedResultAction = \_cliOptions _modSummary x -> return x{GHC.hpm_module = onModule <$> GHC.hpm_module x}+ , GHC.pluginRecompile = GHC.purePlugin+ }+++---------------------------------------------------------------------+-- PLUGIN GUTS++setL :: SrcSpan -> GenLocated SrcSpan e -> GenLocated SrcSpan e+setL l (L _ x) = L l x++mod_records :: GHC.ModuleName+mod_records = GHC.mkModuleName "GHC.Records.Extra"++var_HasField, var_hasField, var_getField, var_setField, var_dot :: GHC.RdrName+var_HasField = GHC.mkRdrQual mod_records $ GHC.mkClsOcc "HasField"+var_hasField = GHC.mkRdrUnqual $ GHC.mkVarOcc "hasField"+var_getField = GHC.mkRdrQual mod_records $ GHC.mkVarOcc "getField"+var_setField = GHC.mkRdrQual mod_records $ GHC.mkVarOcc "setField"+var_dot = GHC.mkRdrUnqual $ GHC.mkVarOcc "."+++onModule :: HsModule GhcPs -> HsModule GhcPs+onModule x = x { hsmodImports = onImports $ hsmodImports x+ , hsmodDecls = concatMap onDecl $ hsmodDecls x+ }+++onImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]+onImports = (:) $ noL $ GHC.ImportDecl GHC.NoExt GHC.NoSourceText (noL mod_records)+ Nothing False False True {- qualified -} True {- implicit -} Nothing Nothing+++{-+instance Z.HasField "name" (Company) (String) where hasField _r = (\_x -> _r{name=_x}, (name:: (Company) -> String) _r)++instance HasField "selector" Record Field where+ hasField r = (\x -> r{selector=x}, (name :: Record -> Field) r)+-}+instanceTemplate :: FieldOcc GhcPs -> HsType GhcPs -> HsType GhcPs -> InstDecl GhcPs+instanceTemplate selector record field = ClsInstD noE $ ClsInstDecl noE (HsIB noE typ) (unitBag has) [] [] [] Nothing+ where+ typ = mkHsAppTys+ (noL (HsTyVar noE GHC.NotPromoted (noL var_HasField)))+ [noL (HsTyLit noE (HsStrTy GHC.NoSourceText (GHC.occNameFS $ GHC.occName $ unLoc $ rdrNameFieldOcc selector)))+ ,noL record+ ,noL field+ ]++ has :: LHsBindLR GhcPs GhcPs+ has = noL $ FunBind noE (noL var_hasField) (mg1 eqn) WpHole []+ where+ eqn = Match+ { m_ext = noE+ , m_ctxt = FunRhs (noL var_hasField) GHC.Prefix NoSrcStrict+ , m_pats = compat_m_pats [VarPat noE $ noL vR]+ , m_grhss = GRHSs noE [noL $ GRHS noE [] $ noL $ ExplicitTuple noE [noL $ Present noE set, noL $ Present noE get] GHC.Boxed] (noL $ EmptyLocalBinds noE)+ }+ set = noL $ HsLam noE $ mg1 Match+ { m_ext = noE+ , m_ctxt = LambdaExpr+ , m_pats = compat_m_pats [VarPat noE $ noL vX]+ , m_grhss = GRHSs noE [noL $ GRHS noE [] $ noL update] (noL $ EmptyLocalBinds noE)+ }+ update = RecordUpd noE (noL $ GHC.HsVar noE $ noL vR)+ [noL $ HsRecField (noL (Unambiguous noE (rdrNameFieldOcc selector))) (noL $ GHC.HsVar noE $ noL vX) False]+ get = mkApp+ (mkParen $ mkTypeAnn (noL $ GHC.HsVar noE $ rdrNameFieldOcc selector) (noL $ HsFunTy noE (noL record) (noL field)))+ (noL $ GHC.HsVar noE $ noL vR)++ mg1 :: Match GhcPs (LHsExpr GhcPs) -> MatchGroup GhcPs (LHsExpr GhcPs)+ mg1 x = MG noE (noL [noL x]) GHC.Generated++ vR = GHC.mkRdrUnqual $ GHC.mkVarOcc "r"+ vX = GHC.mkRdrUnqual $ GHC.mkVarOcc "x"+++onDecl :: LHsDecl GhcPs -> [LHsDecl GhcPs]+onDecl o@(L _ (GHC.TyClD _ x)) = o :+ [ noL $ InstD noE $ instanceTemplate field (unLoc record) (unbang typ)+ | let fields = nubOrdOn (\(_,_,x,_) -> GHC.occNameFS $ GHC.rdrNameOcc $ unLoc $ rdrNameFieldOcc x) $ getFields x+ , (record, _, field, typ) <- fields]+onDecl x = [descendBi onExp x]++unbang :: HsType GhcPs -> HsType GhcPs+unbang (HsBangTy _ _ x) = unLoc x+unbang x = x++getFields :: TyClDecl GhcPs -> [(LHsType GhcPs, IdP GhcPs, FieldOcc GhcPs, HsType GhcPs)]+getFields DataDecl{tcdDataDefn=HsDataDefn{..}, ..} = concatMap ctor dd_cons+ where+ ctor (L _ ConDeclH98{con_args=RecCon (L _ fields),con_name=L _ name}) = concatMap (field name) fields+ ctor _ = []++ field name (L _ ConDeclField{cd_fld_type=L _ ty, ..}) = [(result, name, fld, ty) | L _ fld <- cd_fld_names]+ field _ _ = error "unknown field declaration in getFields"++ result = noL $ HsParTy noE $ foldl (\x y -> noL $ HsAppTy noE x $ hsLTyVarBndrToType y) (noL $ HsTyVar noE GHC.NotPromoted tcdLName) $ hsq_explicit tcdTyVars+getFields _ = []+++-- At this point infix expressions have not had associativity/fixity applied, so they are bracketed+-- a + b + c ==> (a + b) + c+-- Therefore we need to deal with, in general:+-- x.y, where+-- x := a | a b | a.b | a + b+-- y := a | a b | a{b=1}+onExp :: LHsExpr GhcPs -> LHsExpr GhcPs+onExp (L o (OpApp _ lhs mid@(isDot -> True) rhs))+ | adjacent lhs mid, adjacent mid rhs+ , (lhsOp, lhs) <- getOpRHS $ onExp lhs+ , (lhsApp, lhs) <- getAppRHS lhs+ , (rhsApp, rhs) <- getAppLHS rhs+ , (rhsRec, rhs) <- getRec rhs+ , Just sel <- getSelector rhs+ = onExp $ lhsOp $ rhsApp $ lhsApp $ rhsRec $ mkParen $ setL o $ mkVar var_getField `mkAppType` sel `mkApp` lhs++-- Turn (.foo.bar) into getField calls+onExp (L o (SectionR _ mid@(isDot -> True) rhs))+ | adjacent mid rhs+ , srcSpanStart o == srcSpanStart (getLoc mid)+ , srcSpanEnd o == srcSpanEnd (getLoc rhs)+ , Just sels <- getSelectors rhs+ = setL o $ mkParen $ foldl1 (\x y -> noL $ OpApp noE x (mkVar var_dot) y) $ map (mkVar var_getField `mkAppType`) $ reverse sels++-- Turn a{b=c, d=e, ...} into successive setField calls+onExp (L _ RecordUpd{rupd_expr,rupd_flds=[]}) = onExp rupd_expr+onExp (L o upd@RecordUpd{rupd_expr,rupd_flds=L _ (HsRecField (fmap rdrNameAmbiguousFieldOcc -> lbl) arg pun):flds})+ | let sel = mkSelector lbl+ , let arg2 = if pun then noL $ HsVar noE lbl else arg+ , let expr = mkParen $ mkVar var_setField `mkAppType` sel `mkApp` mkParen rupd_expr `mkApp` arg2+ = onExp $ L o upd{rupd_expr=expr,rupd_flds=flds}++onExp x = descend onExp x+++mkSelector :: Located GHC.RdrName -> LHsType GhcPs+mkSelector (L o x) = L o $ HsTyLit noE $ HsStrTy GHC.NoSourceText $ GHC.occNameFS $ GHC.rdrNameOcc x++getSelector :: LHsExpr GhcPs -> Maybe (LHsType GhcPs)+getSelector (L _ (HsVar _ (L o sym)))+ | not $ GHC.isQual sym+ = Just $ mkSelector $ L o sym+getSelector _ = Nothing++-- | Turn a.b.c into Just [a,b,c]+getSelectors :: LHsExpr GhcPs -> Maybe [LHsType GhcPs]+getSelectors (L _ (OpApp _ lhs mid@(isDot -> True) rhs))+ | adjacent lhs mid, adjacent mid rhs+ , Just post <- getSelector rhs+ , Just pre <- getSelectors lhs+ = Just $ pre ++ [post]+getSelectors x = (:[]) <$> getSelector x++-- | Lens on: f [x]+getAppRHS :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)+getAppRHS (L l (HsApp e x y)) = (L l . HsApp e x, y)+getAppRHS x = (id, x)++-- | Lens on: [f] x y z+getAppLHS :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)+getAppLHS (L l (HsApp e x y)) = first (\c -> L l . (\x -> HsApp e x y) . c) $ getAppLHS x+getAppLHS x = (id, x)++-- | Lens on: a + [b]+getOpRHS :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)+getOpRHS (L l (OpApp x y p z)) = (L l . OpApp x y p, z)+getOpRHS x = (id, x)++-- | Lens on: [r]{f1=x1}{f2=x2}+getRec :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)+getRec (L l r@RecordUpd{}) = first (\c x -> L l r{rupd_expr=c x}) $ getRec $ rupd_expr r+getRec x = (id, x)++-- | Is it equal to: .+isDot :: LHsExpr GhcPs -> Bool+isDot (L _ (HsVar _ (L _ op))) = op == var_dot+isDot _ = False++mkVar :: GHC.RdrName -> LHsExpr GhcPs+mkVar = noL . HsVar noE . noL++mkParen :: LHsExpr GhcPs -> LHsExpr GhcPs+mkParen = noL . HsPar noE++mkApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+mkApp x y = noL $ HsApp noE x y++-- | Are the end of a and the start of b next to each other, no white space+adjacent :: Located a -> Located b -> Bool+adjacent (L a _) (L b _) = isGoodSrcSpan a && srcSpanEnd a == srcSpanStart b
+ preprocessor/Edit.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}++module Edit(edit) where++import Lexer+import Paren+import Data.Maybe+import Data.Char+import Data.List.Extra+import Control.Monad.Extra+++edit :: [PL] -> [PL]+edit = editAddPreamble . editAddInstances . editLoop+++---------------------------------------------------------------------+-- HELPERS++-- Projecting in on the 'lexeme' inside+type L = Lexeme+unL = lexeme+mkL x = Lexeme 0 0 x ""+pattern L x <- (unL -> x)++-- Projecting in on the lexeme inside an Item+type PL = Paren L+unPL (Item (L x)) = Just x+unPL _ = Nothing+isPL x y = unPL y == Just x+pattern PL x <- (unPL -> Just x)+mkPL = Item . mkL++-- Whitespace+pattern NoW x <- (\v -> if null $ getWhite v then Just v else Nothing -> Just x)+++paren [x] = x+paren xs = case unsnoc xs of+ Just (xs,x) -> Paren (mkL "(") (xs `snoc` setWhite "" x) (mkL ")"){whitespace = getWhite x}+ _ -> Paren (mkL "(") xs (mkL ")")++spc = addWhite " "+nl = addWhite "\n"++addWhite w x = setWhite (getWhite x ++ w) x++getWhite (Item x) = whitespace x+getWhite (Paren _ _ x) = whitespace x++setWhite w (Item x) = Item x{whitespace=w}+setWhite w (Paren x y z) = Paren x y z{whitespace=w}++isCtor (Item x) = any isUpper $ take 1 $ lexeme x+isCtor _ = False++isField (x:_) = x == '_' || isLower x+isField _ = False++makeField :: [String] -> String+makeField [x] = "@" ++ show x+makeField xs = "@'(" ++ intercalate "," (map show xs) ++ ")"+++---------------------------------------------------------------------+-- PREAMBLE++-- | Add the necessary extensions, imports and local definitions+editAddPreamble :: [PL] -> [PL]+editAddPreamble o@xs+ | (premodu, modu:modname@xs) <- break (isPL "module") xs+ , (prewhr, whr:xs) <- break (isPL "where") xs+ = nl (mkPL prefix) : premodu ++ modu : prewhr ++ whr : nl (mkPL "") : nl (mkPL imports) : xs ++ [nl $ mkPL "", nl $ mkPL $ trailing modname]+ | otherwise = blanks ++ nl (mkPL prefix) : nl (mkPL imports) : rest ++ [nl $ mkPL "", nl $ mkPL $ trailing []]+ where+ (blanks, rest) = span (isPL "") o++ prefix = "{-# LANGUAGE DuplicateRecordFields, DataKinds, FlexibleInstances, TypeApplications, FlexibleContexts, MultiParamTypeClasses, OverloadedLabels #-}"+ imports = "import qualified GHC.Records.Extra as Z"+ -- if you import two things that have preprocessor_unused, and export them as modules, you don't want them to clash+ trailing modName = "_preprocessor_unused_" ++ uniq ++ " :: Z.HasField \"\" r a => r -> a;" +++ "_preprocessor_unused_" ++ uniq ++ " = Z.getField @\"\""+ where uniq = map (\x -> if isAlphaNum x then x else '_') $ concat $ take 19 $ takeWhile modPart $ map lexeme $ unparens modName+ modPart x = x == "." || all isUpper (take 1 x)+++---------------------------------------------------------------------+-- SELECTORS++-- given .lbl1.lbl2 return ([lbl1,lbl2], whitespace, rest)+spanFields :: [PL] -> ([String], String, [PL])+spanFields (NoW (PL "."):x@(PL fld):xs) | isField fld = (\(a,b,c) -> (fld:a,b,c)) $+ case x of NoW{} -> spanFields xs; _ -> ([], getWhite x, xs)+spanFields xs = ([], "", xs)+++editLoop :: [PL] -> [PL]++-- | a.b.c ==> getField @'(b,c) a+editLoop (NoW e : (spanFields -> (fields@(_:_), whitespace, rest)))+ | not $ isCtor e+ = editLoop $ addWhite whitespace (paren [spc $ mkPL "Z.getField", spc $ mkPL $ makeField fields, e]) : rest++-- (.a.b) ==> (getField @'(a,b))+editLoop (Paren start@(L "(") (spanFields -> (fields@(_:_), whitespace, [])) end:xs)+ = editLoop $ Paren start [spc $ mkPL "Z.getField", addWhite whitespace $ mkPL $ makeField fields] end : xs++-- e{b.c=d, ...} ==> setField @'(b,c) d+editLoop (e:Paren (L "{") inner end:xs)+ | not $ isCtor e+ , Just updates <- mapM f $ split (isPL ",") inner+ , let end2 = [Item end{lexeme=""} | whitespace end /= ""]+ = editLoop $ renderUpdate (Update e updates) : end2 ++ xs+ where+ f (NoW (PL field1) : (spanFields -> (fields, whitespace, xs)))+ | isField field1+ = g (field1:fields) xs+ f (x@(PL field1):xs)+ | isField field1+ = g [field1] xs+ f _ = Nothing++ g fields (op:xs) = Just (fields, if isPL "=" op then Nothing else Just op, Just $ paren xs)+ g fields [] = Just (fields, Nothing, Nothing)+++editLoop (Paren a b c:xs) = Paren a (editLoop b) c : editLoop xs+editLoop (x:xs) = x : editLoop xs+editLoop [] = []+++---------------------------------------------------------------------+-- UPDATES++data Update = Update+ PL -- The expression being updated+ [([String], Maybe PL, Maybe PL)] -- (fields, operator, body)++renderUpdate :: Update -> PL+renderUpdate (Update e upd) = case unsnoc upd of+ Nothing -> e+ Just (rest, (field, operator, body)) -> paren+ [spc $ mkPL $ if isNothing operator then "Z.setField" else "Z.modifyField"+ ,spc $ mkPL $ makeField $ if isNothing body then [last field] else field+ ,spc (renderUpdate (Update e rest))+ ,case (operator, body) of+ (Just o, Just b) -> paren [spc $ if isPL "-" o then mkPL "subtract" else o, b]+ (Nothing, Just b) -> b+ (Nothing, Nothing)+ | [field] <- field -> mkPL field+ | f1:fs <- field -> paren [spc $ mkPL "Z.getField", spc $ mkPL $ makeField fs, mkPL f1]+ _ -> error "renderUpdate, internal error"+ ]+++---------------------------------------------------------------------+-- INSTANCES++editAddInstances :: [PL] -> [PL]+editAddInstances xs = xs ++ concatMap (\x -> [nl $ mkPL "", mkPL x])+ [ "instance Z.HasField \"" ++ fname ++ "\" " ++ rtyp ++ " (" ++ ftyp ++ ") " +++ "where hasField _r = (\\_x -> _r{" ++ fname ++ "=_x}, (" ++ fname ++ " :: " ++ rtyp ++ " -> " ++ ftyp ++ ") _r)"+ | Record rname rargs fields <- parseRecords xs+ , let rtyp = "(" ++ unwords (rname : rargs) ++ ")"+ , (fname, ftyp) <- fields+ ]++-- | Represent a record, ignoring constructors. For example:+--+-- > data Type a b = Ctor1 {field1 :: Int, field2 :: String} | Ctor2 {field1 :: Int, field3 :: [Bool]}+--+-- Gets parsed as:+--+-- > Record "Type"] ["a","b"] [("field1","Int"), ("field2","String"), ("field3","[Bool]")]+data Record = Record+ String -- Name of the type (not constructor)+ [String] -- Type arguments+ [(String, String)] -- (field, type) - nub'd+ deriving Show++-- | Find all the records and parse them+parseRecords :: [PL] -> [Record]+parseRecords = mapMaybe whole . drop 1 . split (isPL "data" ||^ isPL "newtype")+ where+ whole :: [PL] -> Maybe Record+ whole xs+ | PL typeName : xs <- xs+ , (typeArgs, _:xs) <- break (isPL "=") xs+ = Just $ Record typeName [x | PL x <- typeArgs] $ nubOrd $ ctor xs+ whole _ = Nothing++ ctor xs+ | PL ctorName : Paren (L "{") inner _ : xs <- xs+ = fields (map (break (isPL "::")) $ split (isPL ",") inner) +++ case xs of+ PL "|":xs -> ctor xs+ _ -> []+ ctor _ = []++ fields ((x,[]):(y,z):rest) = fields $ (x++y,z):rest+ fields ((names, _:typ):rest) = [(name, dropWhile (== '!') $ trim $ unlexer $ unparens typ) | PL name <- names] ++ fields rest+ fields _ = []++ -- if the user has a trailing comment want to rip it out so our brackets still work+ unlexer = concatMap $ \x -> lexeme x ++ [' ' | whitespace x /= ""]
+ preprocessor/Lexer.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE RecordWildCards, BangPatterns #-}++-- Most of this module follows the Haskell report, https://www.haskell.org/onlinereport/lexemes.html+module Lexer(Lexeme(..), lexer, unlexerFile) where++import Data.Char+import Data.List+import Data.Tuple.Extra++-- | A lexeme of text, approx some letters followed by some space.+data Lexeme = Lexeme+ {line :: {-# UNPACK #-} !Int -- ^ 1-based line number (0 = generated)+ ,col :: {-# UNPACK #-} !Int -- ^ 1-based col number (0 = generated)+ ,lexeme :: String -- ^ Actual text of the item+ ,whitespace :: String -- ^ Suffix spaces and comments+ } deriving Show+++charNewline x = x == '\r' || x == '\n' || x == '\f'+charSpecial x = x `elem` "(),;[]`{}"+charAscSymbol x = x `elem` "!#$%&*+./<=>?@\\^|-~" || x == ':' -- special case for me+charSymbol x = charAscSymbol x || (isSymbol x && not (charSpecial x) && x `notElem` "_\"\'")++charIdentStart x = isAlpha x || x == '_'+charIdentCont x = isAlphaNum x || x == '_' || x == '\''+++lexer :: String -> [Lexeme]+lexer = go1 1 1+ where+ -- we might start with whitespace, before any lexemes+ go1 line col xs+ | (whitespace, xs) <- lexerWhitespace xs+ , whitespace /= ""+ , (line2, col2) <- reposition line col whitespace+ = Lexeme{lexeme="", ..} : go line2 col2 xs+ go1 line col xs = go line col xs++ go line col "" = []+ go line col xs+ | (lexeme, xs) <- lexerLexeme xs+ , (whitespace, xs) <- lexerWhitespace xs+ , (line2, col2) <- reposition line col $ whitespace ++ lexeme+ = Lexeme{..} : go line2 col2 xs+++reposition :: Int -> Int -> String -> (Int, Int)+reposition = go+ where+ go !line !col [] = (line, col)+ go line col (x:xs)+ | x == '\n' = go (line+1) 1 xs+ | x == '\t' = go line (col+8) xs -- technically not totally correct, but please, don't use tabs+ | otherwise = go line (col+1) xs+++-- We take a lot of liberties with lexemes around module qualification, because we want to make fields magic+-- we ignore numbers entirely because they don't have any impact on what we want to do+lexerLexeme :: String -> (String, String)+lexerLexeme (open:xs) | open == '\'' || open == '\"' = seen [open] $ go xs+ where+ go (x:xs) | x == open = ([x], xs)+ | x == '\\', x2:xs <- xs = seen [x,x2] $ go xs+ | otherwise = seen [x] $ go xs+ go [] = ([], [])+lexerLexeme (x:xs)+ | charSymbol x+ , (a, xs) <- span charSymbol xs+ = (x:a, xs)+lexerLexeme (x:xs)+ | charIdentStart x+ , (a, xs) <- span charIdentCont xs+ = (x:a, xs)+lexerLexeme (x:xs) = ([x], xs)+lexerLexeme [] = ([], [])+++lexerWhitespace :: String -> (String, String)+lexerWhitespace (x:xs) | isSpace x = seen [x] $ lexerWhitespace xs+lexerWhitespace ('-':'-':xs)+ | (a, xs) <- span (== '-') xs+ , not $ any charSymbol $ take 1 xs+ , (b, xs) <- break charNewline xs+ , (c, xs) <- splitAt 1 xs+ = seen "--" $ seen a $ seen b $ seen c $ lexerWhitespace xs+lexerWhitespace ('{':'-':xs) = seen "{-" $ f 1 xs+ where+ f 1 ('-':'}':xs) = seen "-}" $ lexerWhitespace xs+ f i ('{':'-':xs) = seen "{-" $ f (i+1) xs+ f i (x:xs) = seen [x] $ f i xs+ f i [] = ([], [])+lexerWhitespace xs = ([], xs)++seen xs = first (xs++)+++unlexerFile :: FilePath -> [Lexeme] -> String+unlexerFile src xs =+ dropping 1 +++ go 1 True [(line, lexeme ++ whitespace) | Lexeme{..} <- xs]+ where+ go :: Int -> Bool -> [(Int, String)] -> String+ go doc drp ((i, x):xs) =+ (if doc /= i && i /= 0 && drp then dropping i else "") +++ x +++ go ((if i == 0 then doc else i) + length (filter (== '\n') x)) ("\n" `isSuffixOf` x) xs+ go _ _ [] = ""++ dropping n = "{-# LINE " ++ show n ++ " " ++ show src ++ " #-}\n"
+ preprocessor/Paren.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE ScopedTypeVariables, DeriveFunctor #-}++-- Most of this module follows the Haskell report, https://www.haskell.org/onlinereport/lexemes.html+module Paren(Paren(..), parenOn, unparen, unparens) where++import Data.Tuple.Extra++-- | A list of items which are paranthesised.+data Paren a+ = Item a -- Indiviaaul item+ | Paren a [Paren a] a -- parenthesise, open, inner, close+ deriving (Show,Eq,Functor)++parenOn :: forall a b . Eq b => (a -> b) -> [(b, b)] -> [a] -> [Paren a]+parenOn proj pairs = fst . go Nothing+ where+ -- invariant: if first argument is Nothing, second component of result will be Nothing+ go :: Maybe b -> [a] -> ([Paren a], Maybe (a, [a]))+ go (Just close) (x:xs) | close == proj x = ([], Just (x, xs))+ go close (start:xs)+ | Just end <- lookup (proj start) pairs+ , (inner, res) <- go (Just end) xs+ = case res of+ Nothing -> (Item start : inner, Nothing)+ Just (end, xs) -> first (Paren start inner end :) $ go close xs+ go close (x:xs) = first (Item x :) $ go close xs+ go close [] = ([], Nothing)+++unparens :: [Paren a] -> [a]+unparens = concatMap unparen++unparen :: Paren a -> [a]+unparen (Item x) = [x]+unparen (Paren a b c) = [a] ++ unparens b ++ [c]
+ preprocessor/Preprocessor.hs view
@@ -0,0 +1,28 @@++module Preprocessor(main) where++import Lexer+import Paren+import Edit+import System.IO.Extra+import System.Environment+++-- GHC calls me with: original input output <any extra arguments>+-- Test calls me with: --test directory+-- Users call me with: input+main :: IO ()+main = do+ args <- getArgs+ case args of+ original:input:output:_ -> runConvert original input output+ input:output:_ -> runConvert input input output+ input:_ -> runConvert input input "-"+ [] -> putStrLn "record-dot-preprocess [FILE-TO-CONVERT]"+++runConvert :: FilePath -> FilePath -> FilePath -> IO ()+runConvert original input output = do+ res <- unlexerFile original . unparens . edit . paren . lexer <$> readFileUTF8' input+ if output == "-" then putStrLn res else writeFileUTF8 output res+ where paren = parenOn lexeme [("(",")"),("[","]"),("{","}"),("`","`")]
record-dot-preprocessor.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: record-dot-preprocessor-version: 0.1.5+version: 0.2 license: BSD3 x-license: BSD-3-Clause OR Apache-2.0 license-file: LICENSE@@ -19,22 +19,62 @@ extra-doc-files: README.md CHANGES.txt-tested-with: GHC==8.6.3, GHC==8.4.4, GHC==8.2.2+tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2+extra-source-files:+ examples/Both.hs+ examples/Preprocessor.hs+ examples/Readme.hs source-repository head type: git location: https://github.com/ndmitchell/record-dot-preprocessor.git +library+ default-language: Haskell2010+ hs-source-dirs: plugin+ build-depends:+ base >= 4.8 && < 5,+ uniplate,+ ghc,+ extra+ if impl(ghc < 8.6)+ buildable: False+ exposed-modules:+ RecordDotPreprocessor+ other-modules:+ Compat+ executable record-dot-preprocessor default-language: Haskell2010- hs-source-dirs: src- main-is: Main.hs+ hs-source-dirs: preprocessor+ main-is: Preprocessor.hs+ ghc-options: -main-is Preprocessor build-depends:- base >= 4.6 && < 5,- filepath,+ base >= 4.8 && < 5, extra other-modules: Edit Lexer Paren- Unlexer++test-suite record-dot-preprocessor-test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Test.hs+ hs-source-dirs: preprocessor, test+ ghc-options: -main-is Test.main++ build-depends:+ base == 4.*,+ extra,+ record-hasfield,+ filepath+ if impl(ghc >= 8.6)+ build-depends:+ record-dot-preprocessor+ other-modules:+ PluginExample+ Preprocessor+ Edit+ Lexer+ Paren
− src/Edit.hs
@@ -1,165 +0,0 @@--module Edit(edit) where--import Lexer-import Paren-import Data.Maybe-import Data.Char-import Data.List.Extra-import Data.Tuple.Extra-import Control.Monad.Extra---edit :: [Paren Lexeme] -> [Paren Lexeme]-edit = editAddPreamble . editAddInstances . editSelectors . editUpdates---nl = Item $ Lexeme 0 0 "" "\n"-spc = Item $ Lexeme 0 0 "" " "-gen = Item . gen_-gen_ x = Lexeme 0 0 x ""--paren xs = case unsnoc xs of- Just (xs,Item x) -> Paren (gen_ "(") (xs `snoc` Item x{whitespace=""}) (gen_ ")"){whitespace=whitespace x}- _ -> Paren (gen_ "(") xs (gen_ ")")--is x (Item y) = lexeme y == x-is x _ = False--noWhitespace (Item x) = null $ whitespace x-noWhitespace (Paren _ _ x) = null $ whitespace x--isCtor (Item x) = any isUpper $ take 1 $ lexeme x-isCtor _ = False--isField (Item x) = all (isLower ||^ (== '_')) $ take 1 $ lexeme x-isField _ = False--hashField (Item x)- | c1:cs <- lexeme x- , c1 == '_' && all isDigit cs -- tuple projection- = Item x{lexeme = "Z." ++ lexeme x}-hashField (Item x) = Item x{lexeme = '#' : lexeme x}-hashField x = x----- Add the necessary extensions, imports and local definitions-editAddPreamble :: [Paren Lexeme] -> [Paren Lexeme]-editAddPreamble o@xs- | (premodu, modu:modname@xs) <- break (is "module") xs- , (prewhr, whr:xs) <- break (is "where") xs- = if isControlLens modname then o else gen prefix : nl : premodu ++ modu : prewhr ++ whr : nl : gen imports : nl : xs ++ [nl, gen $ trailing modname, nl]- | otherwise = gen prefix : nl : gen imports : nl : xs ++ [nl, gen $ trailing [], nl]- where- -- don't want to create a circular reference if they fake Control.Lens with microlens- isControlLens (a:b:c:_) = is "Control" a && is "." b && is "Lens" c- isControlLens _ = False-- prefix = "{-# LANGUAGE DuplicateRecordFields, DataKinds, FlexibleInstances, MultiParamTypeClasses, GADTs, OverloadedLabels #-}"- imports = "import qualified GHC.OverloadedLabels as Z; import qualified Control.Lens as Z"- -- if you import two things that have preprocessor_unused, and export them as modules, you don't want them to clash- trailing modName = "_preprocessor_unused_" ++ uniq ++ " :: (label ~ \"_unused\", Z.IsLabel label a) => a -> a;" ++- "_preprocessor_unused_" ++ uniq ++ " _x = let _undef = _undef; _use _ = _x in _use (_undef Z.^. _undef)"- where uniq = map (\x -> if isAlphaNum x then x else '_') $ concat $ take 19 $ takeWhile modPart $ map lexeme $ unparen modName- modPart x = x == "." || all isUpper (take 1 x)---continue op (Paren a b c:xs) = Paren a (op b) c : op xs-continue op (x:xs) = x : op xs-continue op [] = []----- a.b.c ==> ((a ^. #b) ^. #c)-editSelectors :: [Paren Lexeme] -> [Paren Lexeme]-editSelectors (x:dot:field:rest)- | noWhitespace x, noWhitespace dot- , is "." dot- , isField field- , not $ isCtor x- = editSelectors $ paren (editSelectors [x] ++ [spc, gen "Z.^.", spc, hashField field]) : rest-editSelectors xs = continue editSelectors xs---type Field = Paren Lexeme -- passes isField, has had hashField applied-data Update = Update (Paren Lexeme) [Field] [([Field], Maybe (Paren Lexeme), Paren Lexeme)]- -- expression, fields, then (fields, operator, body)--renderUpdate :: Update -> [Paren Lexeme]-renderUpdate (Update e fields upd) =- e : spc : gen "Z.&" : spc :- concat [[x, spc, gen "Z.%~", spc] | x <- fields] ++- [paren (intercalate [spc, gen ".", spc] $ map (pure . paren)- [ concat [ [x, spc, gen "Z.%~", spc] | x <- fields] ++ [paren [operator op, body]]- | (fields, op, body) <- reverse upd]- )]- where- operator Nothing = gen "const"- operator (Just x) | is "-" x = gen "subtract"- operator (Just x) = x----- e.a{b.c=d, ...} ==> e . #a & #b . #c .~ d & ...-editUpdates :: [Paren Lexeme] -> [Paren Lexeme]-editUpdates (e:xs)- | noWhitespace e, not $ isCtor e- , (fields, xs) <- spanFields xs- , Paren brace inner end:xs <- xs- , lexeme brace == "{"- , Just updates <- mapM f $ split (is ",") inner- , let end2 = [Item end{lexeme=""} | whitespace end /= ""]- = paren (renderUpdate (Update (paren $ editUpdates [e]) fields updates)) : end2 ++ editUpdates xs- where- spanFields (x:y:xs)- | noWhitespace x, is "." x- , isField y- = first (hashField y:) $ spanFields xs- spanFields xs = ([], xs)-- f (field1:xs)- | isField field1- , (fields, xs) <- spanFields xs- , op:xs <- xs- = Just (hashField field1:fields, if is "=" op then Nothing else Just op, paren xs)- f xs = Nothing-editUpdates xs = continue editUpdates xs---editAddInstances :: [Paren Lexeme] -> [Paren Lexeme]-editAddInstances xs = xs ++ concatMap (\x -> [nl, gen x])- [ "instance (" ++ intercalate ", " context ++ ") => Z.IsLabel \"" ++ fname ++ "\" " ++- "((t1 -> f t2) -> " ++ rtyp ++ " -> f t3) " ++- "where fromLabel = Z.lens (" ++ fname ++ " :: (" ++ rtyp ++ ") -> (" ++ ftyp ++ ")) (\\_c _x -> _c{" ++ fname ++ "=_x} :: " ++ rtyp ++ ")"- | Record rname rargs fields <- parseRecords $ map (fmap lexeme) xs- , let rtyp = "(" ++ unwords (rname : rargs) ++ ")"- , (fname, ftyp) <- fields- , let context = ["Functor f", "t1 ~ " ++ ftyp, "t2 ~ t1", "t3 ~ " ++ rtyp]- ]--unwordsDot (x:".":y:zs) = unwordsDot $ (x ++ "." ++ y) : zs-unwordsDot (x:y:zs) = unwordsDot $ (x ++ " " ++ y) : zs-unwordsDot [x] = x-unwordsDot [] = ""---data Record = Record String [String] [(String, String)] -- TypeName TypeArgs [(FieldName, FieldType)]- deriving Show--parseRecords :: [Paren String] -> [Record]-parseRecords = mapMaybe whole . drop 1 . split (`elem` [Item "data", Item "newtype"])- where- whole :: [Paren String] -> Maybe Record- whole xs- | Item typeName : xs <- xs- , (typeArgs, _:xs) <- break (== Item "=") xs- = Just $ Record typeName [x | Item x <- typeArgs] $ nubOrd $ ctor xs- whole _ = Nothing-- ctor xs- | Item ctorName : Paren "{" inner _ : xs <- xs- = fields (map (break (== Item "::")) $ split (== Item ",") inner) ++- maybe [] ctor (stripPrefix [Item "|"] xs)- ctor _ = []-- fields ((x,[]):(y,z):rest) = fields $ (x++y,z):rest- fields ((names, _:typ):rest) = [(name, trim $ dropWhile (== '!') $ unwordsDot $ unparen typ) | Item name <- names] ++ fields rest- fields _ = []
− src/Lexer.hs
@@ -1,84 +0,0 @@-{-# LANGUAGE RecordWildCards, BangPatterns #-}---- Most of this module follows the Haskell report, https://www.haskell.org/onlinereport/lexemes.html-module Lexer(Lexeme(..), lexer) where--import Data.Char-import Data.Tuple.Extra--data Lexeme = Lexeme- {line :: {-# UNPACK #-} !Int -- ^ 1-based line number (0 = generated)- ,col :: {-# UNPACK #-} !Int -- ^ 1-based col number (0 = generated)- ,lexeme :: String -- ^ Actual text of the item- ,whitespace :: String -- ^ Suffix spaces and comments- } deriving Show---charNewline x = x == '\r' || x == '\n' || x == '\f'-charSpecial x = x `elem` "(),;[]`{}"-charAscSymbol x = x `elem` "!#$%&*+./<=>?@\\^|-~" || x == ':' -- special case for me-charSymbol x = charAscSymbol x || (isSymbol x && not (charSpecial x) && x `notElem` "_\"\'")--charIdentStart x = isAlpha x || x == '_'-charIdentCont x = isAlphaNum x || x == '_' || x == '\''---lexer :: String -> [Lexeme]-lexer = go 1 1- where- go line col "" = []- go line col xs- | (lexeme, xs) <- lexerLexeme xs- , (whitespace, xs) <- lexerWhitespace xs- , (line2, col2) <- reposition line col $ whitespace ++ lexeme- = Lexeme{..} : go line2 col2 xs---reposition :: Int -> Int -> String -> (Int, Int)-reposition = go- where- go !line !col [] = (line, col)- go line col (x:xs)- | x == '\n' = go (line+1) 1 xs- | x == '\t' = go line (col+8) xs -- technically not totally correct, but please, don't use tabs- | otherwise = go line (col+1) xs----- We take a lot of liberties with lexemes around module qualification, because we want to make fields magic--- we ignore numbers entirely because they don't have any impact on what we want to do-lexerLexeme :: String -> (String, String)-lexerLexeme (open:xs) | open == '\'' || open == '\"' = seen [open] $ go xs- where- go (x:xs) | x == open = ([x], xs)- | x == '\\', x2:xs <- xs = seen [x,x2] $ go xs- | otherwise = seen [x] $ go xs- go [] = ([], [])-lexerLexeme (x:xs)- | charSymbol x- , (a, xs) <- span charSymbol xs- = (x:a, xs)-lexerLexeme (x:xs)- | charIdentStart x- , (a, xs) <- span charIdentCont xs- = (x:a, xs)-lexerLexeme (x:xs) = ([x], xs)-lexerLexeme [] = ([], [])---lexerWhitespace :: String -> (String, String)-lexerWhitespace (x:xs) | isSpace x = seen [x] $ lexerWhitespace xs-lexerWhitespace ('-':'-':xs)- | (a, xs) <- span (== '-') xs- , not $ any charSymbol $ take 1 xs- , (b, xs) <- break charNewline xs- , (c, xs) <- splitAt 1 xs- = seen "--" $ seen a $ seen b $ seen c $ lexerWhitespace xs-lexerWhitespace ('{':'-':xs) = seen "{-" $ f 1 xs- where- f 1 ('-':'}':xs) = seen "-}" $ lexerWhitespace xs- f i ('{':'-':xs) = seen "{-" $ f (i+1) xs- f i (x:xs) = seen [x] $ f i xs- f i [] = ([], [])-lexerWhitespace xs = ([], xs)--seen xs = first (xs++)
− src/Main.hs
@@ -1,46 +0,0 @@--module Main(main) where--import Lexer-import Paren-import Unlexer-import Edit-import Control.Monad.Extra-import System.Directory.Extra-import System.Process.Extra-import System.FilePath-import System.IO.Extra-import System.Environment----- GHC calls me with: original input output <any extra arguments>--- Test calls me with: --test directory--- Users call me with: input-main :: IO ()-main = do- args <- getArgs- case args of- "--test":xs -> runTest $ xs ++ ["." | null xs]- original:input:output:_ -> runConvert original input output- input:output:_ -> runConvert input input output- input:_ -> runConvert input input "-"- [] -> putStrLn "record-dot-preprocess [FILE-TO-CONVERT]"---runConvert :: FilePath -> FilePath -> FilePath -> IO ()-runConvert original input output = do- res <- unlexer original . unparen . edit . paren . lexer <$> readFileUTF8' input- if output == "-" then putStrLn res else writeFileUTF8 output res- where paren = parenOn lexeme [("(",")"),("[","]"),("{","}")]---runTest :: [FilePath] -> IO ()-runTest dirs = withTempDir $ \tdir -> do- createDirectory $ tdir </> "Control"- writeFile (tdir </> "Control/Lens.hs") "module Control.Lens(module X) where import Lens.Micro as X"- forM_ dirs $ \dir -> do- files <- ifM (doesDirectoryExist dir) (listFilesRecursive dir) (return [dir])- forM_ files $ \file -> when (takeExtension file `elem` [".hs",".lhs"]) $ do- let out = tdir </> takeFileName file- runConvert file file out- system_ $ "runhaskell -i" ++ tdir ++ " \"" ++ out ++ "\""
− src/Paren.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, DeriveFunctor #-}---- Most of this module follows the Haskell report, https://www.haskell.org/onlinereport/lexemes.html-module Paren(Paren(..), parenOn, unparen) where--import Data.Tuple.Extra--data Paren a = Item a | Paren a [Paren a] a- deriving (Show,Eq,Functor)--parenOn :: forall a b . Eq b => (a -> b) -> [(b, b)] -> [a] -> [Paren a]-parenOn proj pairs = fst . go Nothing- where- -- invariant: if first argument is Nothing, second component of result will be Nothing- go :: Maybe b -> [a] -> ([Paren a], Maybe (a, [a]))- go (Just close) (x:xs) | close == proj x = ([], Just (x, xs))- go close (start:xs)- | Just end <- lookup (proj start) pairs- , (inner, res) <- go (Just end) xs- = case res of- Nothing -> (Item start : inner, Nothing)- Just (end, xs) -> first (Paren start inner end :) $ go close xs- go close (x:xs) = first (Item x :) $ go close xs- go close [] = ([], Nothing)---unparen :: [Paren a] -> [a]-unparen = concatMap f- where- f (Item x) = [x]- f (Paren a b c) = [a] ++ unparen b ++ [c]
− src/Unlexer.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- Most of this module follows the Haskell report, https://www.haskell.org/onlinereport/lexemes.html-module Unlexer(unlexer) where--import Lexer-import Data.List--unlexer :: FilePath -> [Lexeme] -> String-unlexer src xs =- dropping 1 ++- go 1 True [(line, lexeme ++ whitespace) | Lexeme{..} <- xs]- where- go :: Int -> Bool -> [(Int, String)] -> String- go doc drp ((i, x):xs) =- (if doc /= i && i /= 0 && drp then dropping i else "") ++- x ++- go ((if i == 0 then doc else i) + length (filter (== '\n') x)) ("\n" `isSuffixOf` x) xs- go _ _ [] = ""-- dropping n = "{-# LINE " ++ show n ++ " " ++ show src ++ " #-}\n"
+ test/PluginExample.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ < 806++module PluginExample where+main :: IO ()+main = return ()++#elif mingw32_HOST_OS++module PluginExample where+import RecordDotPreprocessor() -- To check the plugin compiles+main :: IO ()+main = return ()++#else++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -w #-}+{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE PartialTypeSignatures #-} -- because it's now treated as a comment+module PluginExample where+#include "../examples/Both.hs"++#endif
+ test/Test.hs view
@@ -0,0 +1,49 @@++module Test(main) where++import qualified Preprocessor+import qualified PluginExample -- To test the plugin+import GHC.Records.Extra() -- To ensure the runtime dependency is present++import System.Directory.Extra+import System.Environment+import System.FilePath+import Control.Monad+import System.IO.Extra+import System.Info+import System.Process.Extra+import Data.List+import Data.Version+++main :: IO ()+main = do+ -- TODO: If you pass `--installed` should create temp files with the magic string in front+ args <- getArgs+ files <- listFiles "examples"+ let installed = "--installed" `elem` args+ unless installed $ do+ putStrLn "# Plugin Example.hs"+ PluginExample.main+ forM_ (reverse files) $ \file ->+ when (takeExtension file == ".hs" && not ("_out.hs" `isSuffixOf` file)) $+ if installed then do+ src <- readFile' file+ forM_ [("Preprocessor", "{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-}")+ ,("Plugin", "{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}\n" +++ "{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}")] $+ \(name,prefix) -> withTempDir $ \dir ->+ when (compilerVersion >= makeVersion [8,6] && not (blacklist name (takeBaseName file))) $ do+ putStrLn $ "# " ++ name ++ " " ++ takeFileName file+ writeFile (dir </> takeFileName file) $ prefix ++ "\n" ++ src+ system_ $ "runhaskell -package=record-dot-preprocessor " ++ dir </> takeFileName file+ else do+ let out = dropExtension file ++ "_out.hs"+ putStrLn $ "# Preprocessor " ++ takeFileName file+ withArgs [file,file,out] Preprocessor.main+ system_ $ "runhaskell " ++ out+ putStrLn "Success"++-- Blacklist tests we know aren't compatible+blacklist "Plugin" "Preprocessor" = True+blacklist _ _ = False