record-dot-preprocessor 0.2 → 0.2.1
raw patch · 9 files changed
+113/−31 lines, 9 files
Files
- CHANGES.txt +4/−0
- README.md +1/−1
- examples/Both.hs +77/−2
- examples/Preprocessor.hs +3/−17
- plugin/RecordDotPreprocessor.hs +9/−6
- preprocessor/Edit.hs +14/−2
- preprocessor/Lexer.hs +2/−0
- record-dot-preprocessor.cabal +2/−2
- test/PluginExample.hs +1/−1
CHANGES.txt view
@@ -1,5 +1,9 @@ Changelog for record-dot-preprocessor +0.2.1, released 2019-11-02+ #25, support promoted data kinds, e.g. 'Int+ #12, support more things around GADTs+ Make sure the plugin errors on update{} 0.2, released 2019-03-29 Add a GHC source plugin Support for e{foo.bar}
README.md view
@@ -24,7 +24,7 @@ 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).+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?
examples/Both.hs view
@@ -1,20 +1,35 @@ -- 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+{-# LANGUAGE PartialTypeSignatures, GADTs, StandaloneDeriving, DataKinds #-} -- also tests we put language extensions before imports +import Control.Exception+ main :: IO ()-main = test1 >> test2 >> putStrLn "Both worked"+main = test1 >> test2 >> test3 >> test4 >> putStrLn "All worked" (===) :: (Show a, Eq a) => a -> a -> IO () a === b = if a == b then return () else fail $ "Mismatch, " ++ show a ++ " /= " ++ show b +fails :: a -> IO ()+fails val = do+ res <- try $ evaluate val+ case res of+ Left e -> let _ = e :: SomeException in return ()+ Right _ -> fail "Expected an exception" + --------------------------------------------------------------------- -- CHECK THE BASICS WORK data Foo a = Foo {foo1 :: !a, _foo2 :: Int} deriving (Show,Eq) +-- can you deal with multiple alternatives+data Animal = Human {name :: !String, job :: Prelude.String}+ | Nonhuman {name :: String}+ deriving (Show,Eq)++ test1 :: IO () test1 = do -- test expr.lbl@@ -38,7 +53,15 @@ map (.foo1) [foo, foo{foo1="q"}] === ["test", "q"] ( .foo1._foo2 ) (Foo foo 3) === 2 + -- alternatives work+ (Human "a" "b").name === "a" -- comment here+ (Nonhuman "x").name === "x"+ fails (Nonhuman "x").job ++type Type = '[Int]++ --------------------------------------------------------------------- -- DEAL WITH INFIX APPLICATIONS AND ASSOCIATIVITY @@ -75,3 +98,55 @@ gR :: (Int, (String, Bool)) -> String gR (_,(x,_)) = x+++---------------------------------------------------------------------+-- GADTS AND EXISTENTIALS++data GADT where+ GADT :: {gadt :: Int} -> GADT+ deriving (Show,Eq)++data V3 a = Num a => V3 { xx, yy, zz :: a }+deriving instance Show a => Show (V3 a)+deriving instance Eq a => Eq (V3 a)++test3 :: IO ()+test3 = do+ let val = GADT 3+ val.gadt === 3+ val{gadt=5} === GADT 5++ let v3 = V3 1 2 3+ v3.xx === 1+ v3{yy=1, zz=2} === V3 1 1 2++-- ---------------------------------------------------------------------+-- Another volley of tests combining constructions, updates and+-- applications adapted from the DAML test-suite++data AA = AA {xx :: Int} deriving (Eq, Show)+data BB = BB {yy :: AA, zz :: AA} deriving (Eq, Show)+data CC = CC {aa :: Int, bb :: Int} deriving (Eq, Show)++test4 :: IO ()+test4 = do+ f1 CC{aa = 1, bb = 2} 3 4 === CC{aa = 3, bb = 4}+ f2 CC{aa = 1, bb = 2} 1 2 === CC{aa = 3, bb = 2}+ (f3 AA{xx = 1}).xx === 2+ (f4 BB{yy = AA{xx = 1}, zz = AA{xx = 2}}).zz.xx === 4+ let res = f4 BB{yy = AA{xx = 1}, zz = AA{xx = 2}} in res.zz.xx === 4+ (f5 BB{yy = AA{xx = 1}, zz = AA{xx = 2}}).zz.xx === 4+ (f6 BB{yy = AA{xx = 1}, zz = AA{xx = 2}}).yy.xx === 2+ (f6 BB{yy = AA{xx = 1}, zz = AA{xx = 2}}).zz.xx === 4+ f7 [AA 1, AA 2, AA 3] === [1, 2, 3]+ f8 [BB (AA 1) (AA 2), BB (AA 2) (AA 3), BB (AA 3) (AA 4)] === [1, 2, 3]+ where+ f1 :: CC -> Int -> Int -> CC; f1 s t u = s {aa = t, bb = u}+ f2 :: CC -> Int -> Int -> CC; f2 s t u = s {aa = t + u}+ f3 :: AA -> AA; f3 s = s {xx = s.xx + 1}+ f4 :: BB -> BB; f4 s = s {yy = s.yy, zz = s.zz{xx = 4}}+ f5 :: BB -> BB; f5 s = s {yy = s.yy, zz = s.zz{xx = (\ x -> x * x) s.zz.xx}}+ 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}}+ f7 :: [AA] -> [Int]; f7 l = map (.xx) l+ f8 :: [BB] -> [Int]; f8 l = map (.yy.xx) l
examples/Preprocessor.hs view
@@ -6,19 +6,11 @@ -- 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 @@ -28,12 +20,6 @@ | 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)@@ -41,8 +27,8 @@ data Person = Person {age :: Int, address :: String} deriving (Show,Eq) -test2 :: IO ()-test2 = do+test1 :: IO ()+test1 = 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"@@ -76,4 +62,4 @@ main :: IO ()-main = test1 >> test2 >> putStrLn "Preprocessor worked"+main = test1 >> putStrLn "Preprocessor worked"
plugin/RecordDotPreprocessor.hs view
@@ -114,12 +114,14 @@ 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 (L _ ConDeclGADT{con_args=RecCon (L _ fields),con_names=names}) = concat [field name fld | L _ name <- names, fld <- 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+ -- A value of this data declaration will have this type.+ result = foldl (\x y -> noL $ HsAppTy noE x $ hsLTyVarBndrToType y) (noL $ HsTyVar noE GHC.NotPromoted tcdLName) $ hsq_explicit tcdTyVars getFields _ = [] @@ -145,15 +147,16 @@ , 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+ -- Don't bracket here. The argument came in as a section so it's+ -- already enclosed in brackets.+ = setL o $ 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+-- Turn a{b=c, ...} into setField calls 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}+ , let expr = mkParen $ mkVar var_setField `mkAppType` sel `mkApp` rupd_expr `mkApp` arg2 -- 'rupd_expr' never needs bracketing.+ = onExp $ if null flds then expr else L o upd{rupd_expr=expr,rupd_flds=flds} onExp x = descend onExp x
preprocessor/Edit.hs view
@@ -108,6 +108,7 @@ -- e{b.c=d, ...} ==> setField @'(b,c) d editLoop (e:Paren (L "{") inner end:xs) | not $ isCtor e+ , not $ isPL "::" e , Just updates <- mapM f $ split (isPL ",") inner , let end2 = [Item end{lexeme=""} | whitespace end /= ""] = editLoop $ renderUpdate (Update e updates) : end2 ++ xs@@ -185,17 +186,28 @@ whole :: [PL] -> Maybe Record whole xs | PL typeName : xs <- xs- , (typeArgs, _:xs) <- break (isPL "=") xs+ , (typeArgs, _:xs) <- break (isPL "=" ||^ isPL "where") xs = Just $ Record typeName [x | PL x <- typeArgs] $ nubOrd $ ctor xs whole _ = Nothing ctor xs- | PL ctorName : Paren (L "{") inner _ : xs <- xs+ | xs <- dropContext xs+ , PL ctorName : xs <- xs+ , xs <- dropWhile (isPL "::") xs+ , xs <- dropContext xs+ , Paren (L "{") inner _ : xs <- xs = fields (map (break (isPL "::")) $ split (isPL ",") inner) ++ case xs of PL "|":xs -> ctor xs _ -> [] ctor _ = []++ -- we don't use a full parser so dealing with context like+ -- Num a => V3 { xx, yy, zz :: a }+ -- is hard. Fake it as best we can+ dropContext (Paren (L "(") _ _ : PL "=>" : xs) = xs+ dropContext (_ : _ : PL "=>": xs) = xs+ dropContext xs = xs 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
preprocessor/Lexer.hs view
@@ -57,6 +57,8 @@ -- 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 ('\'':x:'\'':xs) = (['\'',x,'\''], xs)+lexerLexeme ('\'':x:xs) | x /= '\'' = ("\'", x:xs) -- might be a data kind, see #25 lexerLexeme (open:xs) | open == '\'' || open == '\"' = seen [open] $ go xs where go (x:xs) | x == open = ([x], xs)
record-dot-preprocessor.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: record-dot-preprocessor-version: 0.2+version: 0.2.1 license: BSD3 x-license: BSD-3-Clause OR Apache-2.0 license-file: LICENSE@@ -19,7 +19,7 @@ extra-doc-files: README.md CHANGES.txt-tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2+tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2 extra-source-files: examples/Both.hs examples/Preprocessor.hs
test/PluginExample.hs view
@@ -17,7 +17,7 @@ {-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -w #-} {-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}-{-# LANGUAGE PartialTypeSignatures #-} -- because it's now treated as a comment+{-# LANGUAGE PartialTypeSignatures, GADTs, StandaloneDeriving #-} -- because it's now treated as a comment module PluginExample where #include "../examples/Both.hs"