diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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} diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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? diff --git a/examples/Both.hs b/examples/Both.hs --- a/examples/Both.hs +++ b/examples/Both.hs @@ -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 diff --git a/examples/Preprocessor.hs b/examples/Preprocessor.hs --- a/examples/Preprocessor.hs +++ b/examples/Preprocessor.hs @@ -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" diff --git a/plugin/RecordDotPreprocessor.hs b/plugin/RecordDotPreprocessor.hs --- a/plugin/RecordDotPreprocessor.hs +++ b/plugin/RecordDotPreprocessor.hs @@ -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 diff --git a/preprocessor/Edit.hs b/preprocessor/Edit.hs --- a/preprocessor/Edit.hs +++ b/preprocessor/Edit.hs @@ -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 diff --git a/preprocessor/Lexer.hs b/preprocessor/Lexer.hs --- a/preprocessor/Lexer.hs +++ b/preprocessor/Lexer.hs @@ -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) diff --git a/record-dot-preprocessor.cabal b/record-dot-preprocessor.cabal --- a/record-dot-preprocessor.cabal +++ b/record-dot-preprocessor.cabal @@ -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 diff --git a/test/PluginExample.hs b/test/PluginExample.hs --- a/test/PluginExample.hs +++ b/test/PluginExample.hs @@ -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"