record-dot-preprocessor 0.2.5 → 0.2.6

raw patch · 6 files changed

+90/−15 lines, 6 files

Files

• CHANGES.txt +3/−0
• examples/Both.hs +22/−2
• examples/Both2.hs +22/−0
• preprocessor/Edit.hs +38/−9
• preprocessor/Lexer.hs +2/−2
• record-dot-preprocessor.cabal +3/−2

@@ -1,5 +1,8 @@ Changelog for record-dot-preprocessor +0.2.6, released 2020-08-12+    #30, don't warn about incomplete record updates+    #31, allow fields to have names that clash with functions 0.2.5, released 2020-05-06     #28, deal with kind signatures on data types 0.2.4, released 2020-05-04

@@ -1,6 +1,6 @@ -- 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+{-# OPTIONS_GHC -Werror -Wall -Wno-type-defaults -Wno-partial-type-signatures -Wincomplete-record-updates -Wno-unused-top-binds #-} -- can we produce -Wall clean code {-# LANGUAGE PartialTypeSignatures, GADTs, StandaloneDeriving, DataKinds, KindSignatures #-} -- also tests we put language extensions before imports  import Control.Exception@@ -8,7 +8,7 @@ import Data.Proxy  main :: IO ()-main = test1 >> test2 >> test3 >> test4 >> test5 >> test6 >> test7 >> putStrLn "All worked"+main = test1 >> test2 >> test3 >> test4 >> test5 >> test6 >> test7 >> test8 >> putStrLn "All worked"  (===) :: (Show a, Eq a) => a -> a -> IO () a === b = if a == b then pure () else fail $ "Mismatch, " ++ show a ++ " /= " ++ show b@@ -182,3 +182,23 @@ test7 :: IO () test7 = do     (UserF "test").userf_name === "test"+++-- ---------------------------------------------------------------------+-- Deal with incomplete types with no warning++data Foo8 = Foo8 {+  bar8 :: Int,+  baz8 :: Float+  } | Quux8 {+  quux8 :: String+  } deriving Show++test8 :: IO ()+test8 = do+    let foo = Foo8 1 2+    let quux = Quux8 "test"+    (foo.bar8, foo.baz8) === (1, 2)+    quux.quux8 === "test"+    fails $ foo.quux8+    fails $ length $ show $ quux{bar8=1}

@@ -0,0 +1,22 @@+-- Test DuplicateRecordFields extension++{-# OPTIONS_GHC -Werror -Wall -Wno-type-defaults -Wno-partial-type-signatures #-} -- can we produce -Wall clean code+{-# LANGUAGE DuplicateRecordFields #-}++main :: IO ()+main = test1 >> putStrLn "All worked"++(===) :: (Show a, Eq a) => a -> a -> IO ()+a === b = if a == b then pure () else fail $ "Mismatch, " ++ show a ++ " /= " ++ show b+++---------------------------------------------------------------------+-- CHECK DUPLICATE NAMES WORK++data Foo = Foo {id :: String} deriving (Show, Eq)++test1 :: IO ()+test1 = do+    (Foo "test").id === "test"+    (Foo "test"){id = "bar"} === Foo "bar"+    map (.id) [Foo "test"] === ["test"]

@@ -161,10 +161,28 @@ 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+      "where hasField _r = (\\_x -> case _r of {" ++ intercalate " ; "+        [ if fname `elem` map fst fields then+            "(" ++ cname ++ " " +++                unwords [if fst field == fname then "_" else "_x" ++ show i | (i, field) <- zipFrom 1 fields] +++            ") -> " ++ cname ++ " " +++                unwords [if fst field == fname then "_x" else "_x" ++ show i | (i, field) <- zipFrom 1 fields]+          else+            cname ++ "{} -> Prelude.error " ++ show ("Cannot update " ++ msg cname)+        | Ctor cname fields <- ctors] +++        "}, case _r of {" ++ intercalate " ; "+        [ if fname `elem` map fst fields then+            "(" ++ cname ++ " " +++                unwords [if fst field == fname then "_x1" else "_" | field <- fields] +++            ") -> _x1"+          else+            cname ++ "{} -> Prelude.error " ++ show ("Cannot get " ++ msg cname)+        | Ctor cname fields <- ctors] +++      "})"+    | Record rname rargs ctors <- parseRecords xs     , let rtyp = "(" ++ unwords (rname : rargs) ++ ")"-    , (fname, ftyp) <- fields+    , (fname, ftyp) <- nubOrd $ concatMap ctorFields ctors+    , let msg cname = "field " ++ show fname ++ " of type " ++ show rname ++ " with constructor " ++ show cname     ]  -- | Represent a record, ignoring constructors. For example:@@ -173,13 +191,24 @@ -- --   Gets parsed as: ----- > Record "Type"] ["a","b"] [("field1","Int"), ("field2","String"), ("field3","[Bool]")]+-- > Record "Type" ["a","b"]+-- >   [Ctor "Ctor1" [("field1","Int"), ("field2","String")]+-- >   [Ctor "Ctor2" [("field1","Int"), ("field3","[Bool]")] data Record = Record-    String -- Name of the type (not constructor)-    [String] -- Type arguments-    [(String, String)] -- (field, type) - nub'd+    {recordName :: String -- Name of the type (not constructor)+    ,recordTyArgs :: [String] -- Type arguments+    ,recordCtors :: [Ctor]+    }     deriving Show +data Ctor = Ctor+    {ctorName :: String -- Name of constructor+    ,ctorFields :: [(String, String)] -- (field, type)+    }+    deriving Show+++ -- | Find all the records and parse them parseRecords :: [PL] -> [Record] parseRecords = mapMaybe whole . drop1 . split (isPL "data" ||^ isPL "newtype")@@ -188,7 +217,7 @@         whole xs             | PL typeName : xs <- xs             , (typeArgs, _:xs) <- break (isPL "=" ||^ isPL "where") xs-            = Just $ Record typeName (mapMaybe typeArg typeArgs) $ nubOrd $ ctor xs+            = Just $ Record typeName (mapMaybe typeArg typeArgs) $ ctor xs         whole _ = Nothing          -- some types are raw, some are in brackets (with a kind signature)@@ -202,7 +231,7 @@             , xs <- dropWhile (isPL "::") xs             , xs <- dropContext xs             , Paren (L "{") inner _ : xs <- xs-            = fields (map (break (isPL "::")) $ split (isPL ",") inner) +++            = Ctor ctorName (fields $ map (break (isPL "::")) $ split (isPL ",") inner) :               case xs of                 PL "|":xs -> ctor xs                 _ -> []

@@ -4,7 +4,7 @@ module Lexer(Lexeme(..), lexer, unlexerFile) where  import Data.Char-import Data.List+import Data.List.Extra import Data.Tuple.Extra  -- | A lexeme of text, approx some letters followed by some space.@@ -103,7 +103,7 @@     -- pretty ugly code...     go 1 True (concat         [ [(line, lexeme ++ w1 ++ take 1 w2)-          ,(if line == 0 then 0 else line + length (filter (== '\n') (lexeme ++ w1 ++ take 1 w2)), drop 1 w2)]+          ,(if line == 0 then 0 else line + length (filter (== '\n') (lexeme ++ w1 ++ take 1 w2)), drop1 w2)]         | Lexeme{..} <- xs, let (w1,w2) = break (== '\n') whitespace])     where         go

@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               record-dot-preprocessor-version:            0.2.5+version:            0.2.6 license:            BSD3 x-license:          BSD-3-Clause OR Apache-2.0 license-file:       LICENSE@@ -19,9 +19,10 @@ extra-doc-files:     README.md     CHANGES.txt-tested-with:        GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2+tested-with:        GHC==8.10, GHC==8.8, GHC==8.6, GHC==8.4 extra-source-files:     examples/Both.hs+    examples/Both2.hs     examples/Preprocessor.hs     examples/Readme.hs