record-dot-preprocessor (empty) → 0.1

raw patch · 10 files changed

+429/−0 lines, 10 filesdep +basedep +extradep +filepathsetup-changed

Dependencies added: base, extra, filepath

Files

• CHANGES.txt +4/−0
• LICENSE +30/−0
• README.md +37/−0
• Setup.hs +2/−0
• record-dot-preprocessor.cabal +39/−0
• src/Edit.hs +147/−0
• src/Lexer.hs +84/−0
• src/Main.hs +46/−0
• src/Paren.hs +31/−0
• src/Unlexer.hs +9/−0

@@ -0,0 +1,4 @@+Changelog for record-dot-preprocessor++0.1, released 2018-05-06+    Initial version

@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2018.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Neil Mitchell nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,37 @@+# 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/lts?label=Stackage)](https://www.stackage.org/package/record-dot-preprocessor) [![Build Status](https://img.shields.io/travis/ndmitchell/record-dot-preprocessor.svg)](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:++```haskell+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"}+```++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.++## 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.++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).++## 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.++## I don't believe in magic, what's the underlying science?++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.++## How does this magic compare to other magic?++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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,39 @@+cabal-version:      >= 1.18+build-type:         Simple+name:               record-dot-preprocessor+version:            0.1+license:            BSD3+license-file:       LICENSE+category:           Development+author:             Neil Mitchell <ndmitchell@gmail.com>+maintainer:         Neil Mitchell <ndmitchell@gmail.com>+copyright:          Neil Mitchell 2018+synopsis:           Preprocessor to allow record.field syntax+description:+    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 - see the README for full details.+homepage:           https://github.com/ndmitchell/record-dot-preprocessor#readme+bug-reports:        https://github.com/ndmitchell/record-dot-preprocessor/issues+extra-doc-files:+    README.md+    CHANGES.txt+tested-with:        GHC==8.4.1, GHC==8.2.2++source-repository head+    type:     git+    location: https://github.com/ndmitchell/record-dot-preprocessor.git++executable record-dot-preprocessor+    default-language:   Haskell2010+    hs-source-dirs:     src+    main-is:            Main.hs+    build-depends:+        base >= 4.6 && < 5,+        filepath,+        extra+    other-modules:+        Edit+        Lexer+        Paren+        Unlexer

@@ -0,0 +1,147 @@++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 xs+    | (premodu, modu:xs) <- break (is "module") xs+    , (prewhr, whr:xs) <- break (is "where") xs+    = gen prefix : nl : premodu ++ modu : prewhr ++ whr : nl : gen imports : nl : xs+    | otherwise = gen prefix : nl : gen imports : nl : xs+    where+        prefix = "{-# LANGUAGE DuplicateRecordFields, DataKinds, FlexibleInstances, MultiParamTypeClasses, GADTs, OverloadedLabels #-}"+        imports = "import qualified GHC.OverloadedLabels as Z; import qualified Control.Lens as Z"+++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+    = 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 [fromMaybe (gen "const") op, body]]+        | (fields, op, body) <- reverse upd]+    )]+++-- 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 (\\x -> " ++ fname ++ " (x :: " ++ rtyp ++ ")) (\\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]+    ]++++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, unwords $ unparen typ) | Item name <- names] ++ fields rest+        fields _ = []

@@ -0,0 +1,84 @@+{-# 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++)

@@ -0,0 +1,46 @@++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 ++ "\""

@@ -0,0 +1,31 @@+{-# 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]

@@ -0,0 +1,9 @@+{-# LANGUAGE RecordWildCards #-}++-- Most of this module follows the Haskell report, https://www.haskell.org/onlinereport/lexemes.html+module Unlexer(unlexer) where++import Lexer++unlexer :: FilePath -> [Lexeme] -> String+unlexer _ xs = concat [lexeme ++ whitespace | Lexeme{..} <- xs]