diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2015, Nikita Volkov + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, DataKinds #-} +module Main where + +import BasePrelude +import Record +import Record.Lens + + +main = + return () + + +type Person = + [record| {name :: String, birthday :: {year :: Int, month :: Int, day :: Int}} |] + +type Event = + [record| {name :: String, date :: {year :: Int, month :: Int, day :: Int}} |] + +person = + [record| {name = "Simon Peyton Jones", + birthday = {year = 1958, month = 1, day = 18}} |] + +getPersonBirthdayYear :: Person -> Int +getPersonBirthdayYear = + view [lens|birthday.year|] + +setPersonBirthdayYear :: Int -> Person -> Person +setPersonBirthdayYear = + set [lens|birthday.year|] + +personBirthdayYearLens :: Lens Person Int +personBirthdayYearLens = + [lens|birthday.year|] + +personBirthdayYearLens' :: Lens Person Int +personBirthdayYearLens' = + [lens|birthday|] . [lens|year|] + +tupleLens :: Lens (Int, Char, String) String +tupleLens = + [lens|3|] + +mapThirdElement :: (Char -> Char) -> (Int, String, Char) -> (Int, String, Char) +mapThirdElement = + over [lens|3|] + +functionOnARecord :: [record| {name :: String, age :: Int}|] -> Int +functionOnARecord = + view [lens|age|] diff --git a/library/Record.hs b/library/Record.hs new file mode 100644 --- /dev/null +++ b/library/Record.hs @@ -0,0 +1,268 @@ +module Record +( + record, + lens, + -- ** Shorthands + r, + l, +) +where + +import BasePrelude +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import qualified Record.Types as Types +import qualified Record.Lens as Lens +import qualified Record.Parser as Parser +import qualified Data.Text as T + + +-- | A shorthand alias to 'record'. +r :: QuasiQuoter +r = record + +-- | A shorthand alias to 'lens'. +l :: QuasiQuoter +l = lens + +-- | +-- A quasiquoter, which generates record expressions and types, +-- depending on the context it's used in. +-- +-- Here is how you can use it to declare types: +-- +-- >type Person = +-- > [record| {name :: String, birthday :: {year :: Int, month :: Int, day :: Int}} |] +-- +-- To declare functions: +-- +-- >getAge :: [record| {name :: String, age :: Int} |] -> Int +-- +-- To declare values: +-- +-- >person :: Person +-- >person = +-- > [record| {name = "Grigori Yakovlevich Perelman", +-- > birthday = {year = 1966, month = 6, day = 13}} |] +-- +record :: QuasiQuoter +record = + QuasiQuoter + (exp) + (const $ fail "Pattern context is not supported") + (type') + (const $ fail "Declaration context is not supported") + where + exp = + join . fmap (either fail return . renderExp) . + either (fail . showString "Parser failure: ") return . + Parser.run (Parser.qq Parser.exp) . fromString + type' = + join . fmap (either fail return . renderType) . + either (fail . showString "Parser failure: ") return . + Parser.run (Parser.qq Parser.type') . fromString + +-- | +-- A quasiquoter, which generates a 'Lens.Lens'. +-- Lens is your interface to accessing and modifying the fields of a record. +-- +-- Here is how you can use it: +-- +-- >getPersonBirthdayYear :: Person -> Int +-- >getPersonBirthdayYear = +-- > Record.Lens.view ([lens|birthday|] . [lens|year|]) +-- +-- For your convenience you can compose lenses from inside of the quotation: +-- +-- >setPersonBirthdayYear :: Int -> Person -> Person +-- >setPersonBirthdayYear = +-- > Record.Lens.set [lens|birthday.year|] +-- +-- You can also use this function to manipulate tuples of arity up to 24: +-- +-- >mapThirdElement :: (Char -> Char) -> (Int, String, Char) -> (Int, String, Char) +-- >mapThirdElement = +-- > Record.Lens.over [lens|3|] +lens :: QuasiQuoter +lens = + QuasiQuoter + (exp) + (const $ fail "Pattern context is not supported") + (const $ fail "Type context is not supported") + (const $ fail "Declaration context is not supported") + where + exp = + either (fail . showString "Parser failure: ") return . + fmap renderLens . + Parser.run (Parser.qq Parser.lens) . fromString + +renderLens :: Parser.Lens -> Exp +renderLens = + foldl1 composition . + fmap renderSingleLens + where + composition a b = + UInfixE a (VarE '(.)) b + +renderSingleLens :: T.Text -> Exp +renderSingleLens = + AppE (VarE 'Types.lens) . + SigE (ConE 'Types.Field) . + AppT (ConT ''Types.Field) . + LitT . StrTyLit . T.unpack + +renderRecordType :: Parser.RecordType -> Either String Type +renderRecordType l = + checkDuplicateLabels >> getRecordTypeName >>= constructType + where + checkDuplicateLabels = + maybe (return ()) (Left . showString "Duplicate labels: " . show) $ + mfilter (not . null) . Just $ + map (fst . head) $ + filter ((> 1) . length) $ + groupWith fst l + getRecordTypeName = + maybe (Left (showString "Record arity " . shows arity . shows " is not supported" $ "")) + (Right) $ + recordTypeNameByArity arity + where + arity = length l + constructType n = + foldl (\a (l, t) -> AppT <$> (AppT <$> a <*> pure (textLitT l)) <*> (renderType t)) + (pure (ConT n)) + (sortWith fst l) + where + textLitT = + LitT . StrTyLit . T.unpack + +recordTypeNameByArity :: Int -> Maybe Name +recordTypeNameByArity arity = + fmap head $ mfilter (not . null) $ Just $ + drop (pred arity) $ + [ + ''Types.Record1, ''Types.Record2, ''Types.Record3, ''Types.Record4, + ''Types.Record5, ''Types.Record6, ''Types.Record7, ''Types.Record8, + ''Types.Record9, ''Types.Record10, ''Types.Record11, ''Types.Record12, + ''Types.Record12, ''Types.Record13, ''Types.Record14, ''Types.Record15, + ''Types.Record16, ''Types.Record17, ''Types.Record18, ''Types.Record19, + ''Types.Record20, ''Types.Record21, ''Types.Record22, ''Types.Record22, + ''Types.Record23, ''Types.Record24 + ] + +recordConNameByArity :: Int -> Maybe Name +recordConNameByArity arity = + fmap head $ mfilter (not . null) $ Just $ + drop (pred arity) $ + [ + 'Types.Record1, 'Types.Record2, 'Types.Record3, 'Types.Record4, + 'Types.Record5, 'Types.Record6, 'Types.Record7, 'Types.Record8, + 'Types.Record9, 'Types.Record10, 'Types.Record11, 'Types.Record12, + 'Types.Record12, 'Types.Record13, 'Types.Record14, 'Types.Record15, + 'Types.Record16, 'Types.Record17, 'Types.Record18, 'Types.Record19, + 'Types.Record20, 'Types.Record21, 'Types.Record22, 'Types.Record22, + 'Types.Record23, 'Types.Record24 + ] + +renderType :: Parser.Type -> Either String Type +renderType = + \case + Parser.Type_App a b -> AppT <$> renderType a <*> renderType b + Parser.Type_Var n -> return $ VarT (mkName (T.unpack n)) + Parser.Type_Con n -> return $ ConT (mkName (T.unpack n)) + Parser.Type_Tuple a -> return $ TupleT a + Parser.Type_Arrow -> return $ ArrowT + Parser.Type_List -> return $ ListT + Parser.Type_Record a -> renderRecordType a + +renderExp :: Parser.Exp -> Either String Exp +renderExp = + \case + Parser.Exp_Record r -> renderRecordExp r + Parser.Exp_Var n -> return $ VarE (mkName (T.unpack n)) + Parser.Exp_Con n -> return $ ConE (mkName (T.unpack n)) + Parser.Exp_TupleCon a -> return $ ConE (tupleDataName a) + Parser.Exp_Nil -> return $ ConE ('[]) + Parser.Exp_Lit l -> return $ LitE (renderLit l) + Parser.Exp_App a b -> AppE <$> renderExp a <*> renderExp b + Parser.Exp_List l -> ListE <$> traverse renderExp l + Parser.Exp_Sig e t -> SigE <$> renderExp e <*> renderType t + +renderRecordExp :: Parser.RecordExp -> Either String Exp +renderRecordExp l = + checkDuplicateLabels >> getConLambda >>= constructExp + where + checkDuplicateLabels = + maybe (return ()) (Left . showString "Duplicate labels: " . show) $ + mfilter (not . null) . Just $ + map (fst . head) $ + filter ((> 1) . length) $ + groupWith fst l + getConLambda = + maybe (Left (showString "Record arity " . shows arity . shows " is not supported" $ "")) + (Right) $ + conLambdaExp arity + where + arity = length l + constructExp lam = + foldl (\a (n, e) -> AppE <$> (AppE <$> a <*> pure (proxy n)) <*> renderExp e) + (pure lam) + (sortWith fst l) + where + proxy n = + SigE (ConE 'Types.Field) + (AppT (ConT ''Types.Field) (LitT (StrTyLit (T.unpack n)))) + +renderLit :: Parser.Lit -> Lit +renderLit = + \case + Parser.Lit_Char c -> CharL c + Parser.Lit_String t -> StringL (T.unpack t) + Parser.Lit_Integer i -> IntegerL i + Parser.Lit_Rational r -> RationalL r + +-- | +-- Allows to specify names in types signatures, +-- leaving the value type resolution to the compiler. +-- +-- E.g., +-- +-- >(\_ v1 _ v2 -> Record2 v1 v2) :: Types.Field n1 -> v1 -> Types.Field n2 -> v2 -> Record2 n1 v1 n2 v2 +-- +-- We can set the name signatures by passing +-- proxies with explicit signatures to this lambda. +conLambdaExp :: Int -> Maybe Exp +conLambdaExp arity = + SigE <$> exp <*> t + where + exp = + LamE <$> pure pats <*> exp + where + pats = + concat $ flip map [1 .. arity] $ \i -> [WildP, VarP (mkName ("v" <> show i))] + exp = + foldl AppE <$> (ConE <$> recordConNameByArity arity) <*> + pure (map (\i -> VarE (mkName ("v" <> show i))) [1 .. arity]) + t = + fnType <$> recordTypeNameByArity arity + where + fnType conName = + ForallT varBndrs [] $ + foldr1 (\l r -> AppT (AppT ArrowT l) r) + (argTypes <> pure (resultType conName)) + varBndrs = + concat $ flip map [1 .. arity] $ \i -> + PlainTV (mkName ("n" <> show i)) : + PlainTV (mkName ("v" <> show i)) : + [] + argTypes = + concat $ flip map [1 .. arity] $ \i -> + AppT (ConT ''Types.Field) (VarT (mkName ("n" <> show i))) : + VarT (mkName ("v" <> show i)) : + [] + resultType conName = + foldl AppT (ConT conName) $ concat $ flip map [1 .. arity] $ \i -> + VarT (mkName ("n" <> show i)) : + VarT (mkName ("v" <> show i)) : + [] + + diff --git a/library/Record/Lens.hs b/library/Record/Lens.hs new file mode 100644 --- /dev/null +++ b/library/Record/Lens.hs @@ -0,0 +1,38 @@ +-- | +-- A minimal subset of the "lens" library functionality, +-- which is completely compatible with it. +-- +-- Unless you use the "lens" library itself, +-- this module is your interface to manipulating the record fields. +module Record.Lens where + +import BasePrelude +import Data.Functor.Identity + + +-- | +-- A reference to from a datastructure @s@ to some part @a@, +-- which can be used to manipulate that particular part. +type Lens s a = + forall f. Functor f => (a -> f a) -> (s -> f s) + +-- | +-- Given a lens to a subpart and a datastructure, +-- produce the value of the referred subpart. +view :: Lens s a -> s -> a +view l = + getConst . l Const + +-- | +-- Given a lens to a subpart, a new value for it and a datastructure, +-- produce an updated datastructure. +set :: Lens s a -> a -> s -> s +set l a = + runIdentity . l (Identity . const a) + +-- | +-- Given a lens to a subpart, and an update function for it, +-- produce a function, which updates the datastructure. +over :: Lens s a -> (a -> a) -> s -> s +over l f = + runIdentity . l (Identity . f) diff --git a/library/Record/Parser.hs b/library/Record/Parser.hs new file mode 100644 --- /dev/null +++ b/library/Record/Parser.hs @@ -0,0 +1,219 @@ +module Record.Parser where + +import BasePrelude hiding (takeWhile, exp) +import Data.Text (Text) +import Data.Attoparsec.Text +import qualified Data.Text as T + + +data Type = + Type_App Type Type | + Type_Var Text | + Type_Con Text | + Type_Tuple Int | + Type_Arrow | + Type_List | + Type_Record RecordType + +type QualifiedName = + [Text] + +type RecordType = + [(Text, Type)] + + +run :: Parser a -> Text -> Either String a +run p t = + onResult $ parse p t + where + onResult = + \case + Fail _ contexts message -> Left $ showString message . showString ". Contexts: " . + shows contexts $ "." + Done _ a -> Right a + Partial c -> onResult (c "") + +labeled :: String -> Parser a -> Parser a +labeled = + flip () + +qq :: Parser a -> Parser a +qq p = + skipSpace *> p <* skipSpace <* endOfInput + +type' :: Parser Type +type' = + labeled "type'" $ + appType <|> nonAppType + where + appType = + fmap (foldl1 Type_App) $ + sepBy1 nonAppType (skipMany1 space) + nonAppType = + varType <|> conType <|> tupleConType <|> tupleType <|> listConType <|> + arrowType <|> (Type_Record <$> recordType) <|> inBraces type' + where + varType = + fmap Type_Var $ lowerCaseName + conType = + fmap Type_Con $ upperCaseName + tupleConType = + fmap Type_Tuple $ + char '(' *> (length <$> many1 (skipSpace *> char ',')) <* skipSpace <* char ')' + tupleType = + fmap (\l -> foldl Type_App (Type_Tuple (length l)) l) $ + char '(' *> skipSpace *> + sepBy1 type' (skipSpace *> char ',' <* skipSpace) + <* skipSpace <* char ')' + listConType = + Type_List <$ string "[]" + arrowType = + Type_Arrow <$ string "->" + +recordType :: Parser RecordType +recordType = + labeled "recordType" $ + char '{' *> skipSpace *> sepBy1' field (skipSpace *> char ',' <* skipSpace) <* skipSpace <* char '}' + where + field = + (,) <$> (lowerCaseName <* skipSpace <* string "::" <* skipSpace) <*> type' + +qualifiedName1 :: Parser QualifiedName +qualifiedName1 = + ((\a b -> a <> pure b) <$> many1 (upperCaseName <* char '.') <*> lowerCaseName) <|> + (pure <$> lowerCaseName) + +inBraces :: Parser a -> Parser a +inBraces p = + char '(' *> skipSpace *> p <* skipSpace <* char ')' + +lowerCaseName :: Parser Text +lowerCaseName = + labeled "lowerCaseName" $ + T.cons <$> + satisfy (\c -> isLower c || c == '_') <*> + takeWhile (\c -> isAlphaNum c || c == '\'' || c == '_') + +upperCaseName :: Parser Text +upperCaseName = + labeled "upperCaseName" $ + T.cons <$> + satisfy (\c -> isUpper c || c == '_') <*> + takeWhile (\c -> isAlphaNum c || c == '\'' || c == '_') + +symbolicIdent :: Parser Text +symbolicIdent = + labeled "symbolicIdent" $ + (\t -> "(" <> t <> ")") <$> (char '(' *> takeWhile1 isSymbol <* char ')') + where + isSymbol = + flip elem ("!#$%&*+./<=>?@\\^|-~" :: [Char]) + +stringLit :: Parser Text +stringLit = + quoted '"' + where + quoted q = + T.pack <$> (char q *> content <* char q) + where + content = + many char' + where + char' = + (char '\\' *> (char q <|> char '\\')) <|> + (notChar q) + +charLit :: Parser Char +charLit = + char '\'' *> ((char '\\' *> (char '\'' <|> char '\\')) <|> notChar '\'') <* char '\'' + + +type Lens = + [Text] + +lens :: Parser Lens +lens = + labeled "lens" $ + sepBy1 (lowerCaseName <|> takeWhile1 isDigit) (char '.') + + +data Exp = + Exp_Record RecordExp | + Exp_Var Text | + Exp_Con Text | + Exp_TupleCon Int | + Exp_Nil | + Exp_Lit Lit | + Exp_App Exp Exp | + Exp_List [Exp] | + Exp_Sig Exp Type + +type RecordExp = + [(Text, Exp)] + +data Lit = + Lit_Char Char | + Lit_String Text | + Lit_Integer Integer | + Lit_Rational Rational + +exp :: Parser Exp +exp = + labeled "exp" $ + sig <|> nonSig + where + sig = + Exp_Sig <$> nonSig <*> (skipSpace *> string "::" *> skipSpace *> type') + nonSig = + app <|> nonApp + where + app = + fmap (foldl1 Exp_App) $ + sepBy1 nonApp (skipMany1 space) + nonApp = + record <|> + var <|> + con <|> + tupleCon <|> + nil <|> + Exp_Lit <$> lit <|> + tuple <|> + list <|> + inBraces exp + where + record = + Exp_Record <$> (char '{' *> skipSpace *> fields <* skipSpace <* char '}') + where + fields = + sepBy1 field (skipSpace *> char ',' <* skipSpace) + where + field = + (,) <$> lowerCaseName <*> (skipSpace *> char '=' *> skipSpace *> exp) + var = + Exp_Var <$> (lowerCaseName <|> symbolicIdent) + con = + Exp_Con <$> (upperCaseName <|> symbolicIdent) + tupleCon = + Exp_TupleCon . length <$> + (char '(' *> many1 (char ',') <* char ')') + nil = + Exp_Nil <$ string "[]" + tuple = + fmap (\l -> foldl Exp_App (Exp_TupleCon (length l)) l) $ + char '(' *> skipSpace *> + sepBy1 exp (skipSpace *> char ',' <* skipSpace) + <* skipSpace <* char ')' + list = + fmap Exp_List $ + char '[' *> skipSpace *> + sepBy1 exp (skipSpace *> char ',' <* skipSpace) <* + skipSpace <* char ']' + +lit :: Parser Lit +lit = + Lit_Char <$> charLit <|> + Lit_String <$> stringLit <|> + Lit_Rational <$> rational <|> + Lit_Integer <$> decimal + + diff --git a/library/Record/Types.hs b/library/Record/Types.hs new file mode 100644 --- /dev/null +++ b/library/Record/Types.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE CPP, UndecidableInstances #-} +-- | +-- The contents of this module may seem a bit overwhelming. +-- Don't worry, +-- all it does is just cover instances and datatypes of records and tuples of +-- huge arities. +-- +-- You don't actually need to ever use this module, +-- since all the functionality you may need is presented +-- by the quasiquoters exported in the root module. +module Record.Types where + +import BasePrelude hiding (Proxy) +import Data.Functor.Identity +import GHC.TypeLits +import Record.Lens (Lens) +import Language.Haskell.TH + + +-- | +-- Defines a way to access some value of a type as field, +-- using the string type literal functionality. +-- +-- Instances are provided to all records and to tuples of arity of up to 24. +-- +-- Here's how you can use it with tuples: +-- +-- >trd :: FieldOwner "3" v a => a -> v +-- >trd = getField (Field :: Field "3") +-- +-- The function above will get you the third item of any tuple, which has it. +class FieldOwner (n :: Symbol) v a | n a -> v where + setField :: Field n -> v -> a -> a + getField :: Field n -> a -> v + +-- | +-- Generate a lens using the 'FieldOwner' instance. +-- +-- >ageLens :: FieldOwner "age" v a => Lens a v +-- >ageLens = lens (Field :: Field "age") +lens :: FieldOwner n v a => Field n -> Lens a v +lens n = + \f a -> fmap (\v -> setField n v a) (f (getField n a)) + +-- | +-- A specialised version of "Data.Proxy.Proxy". +-- Defined for compatibility with \"base-4.6\", +-- since @Proxy@ was only defined in \"base-4.7\". +data Field (t :: Symbol) = Field + +-- * Record Types +------------------------- + +-- Generate Record types +return $ flip map [1 .. 24] $ \arity -> + let + typeName = + mkName $ "Record" <> show arity + varBndrs = + do + i <- [1 .. arity] + let + n = KindedTV (mkName ("n" <> show i)) (ConT ''Symbol) + v = PlainTV (mkName ("v" <> show i)) + in [n, v] + conTypes = + do + i <- [1 .. arity] + return $ (,) (NotStrict) (VarT (mkName ("v" <> show i))) + derivingNames = +#if MIN_VERSION_base(4,7,0) + [''Show, ''Eq, ''Ord, ''Typeable, ''Generic] +#else + [''Show, ''Eq, ''Ord, ''Generic] +#endif + in + DataD [] typeName varBndrs [NormalC typeName conTypes] derivingNames + + +-- Generate Record FieldOwner instances +return $ do + arity <- [1 .. 24] + nIndex <- [1 .. arity] + return $ + let + typeName = + mkName $ "Record" <> show arity + selectedNVarName = + mkName $ "n" <> show nIndex + selectedVVarName = + mkName $ "v" <> show nIndex + recordType = + foldl (\a i -> AppT (AppT a (VarT (mkName ("n" <> show i)))) + (VarT (mkName ("v" <> show i)))) + (ConT typeName) + [1 .. arity] + setFieldLambda = + LamE [VarP vVarName, ConP typeName (fmap VarP indexedVVarNames)] exp + where + vVarName = + mkName "v" + indexedVVarNames = + fmap (\i -> mkName ("v" <> show i)) [1..arity] + exp = + foldl (\a i -> AppE a (VarE (mkName (if i == nIndex then "v" else "v" <> show i)))) + (ConE typeName) + [1 .. arity] + getFieldLambda = + LamE [ConP typeName vPatterns] (VarE (vVarName)) + where + vVarName = + mkName "v" + vPatterns = + flip map [1 .. arity] $ \i -> + if i == nIndex + then VarP vVarName + else WildP + in + head $ unsafePerformIO $ runQ $ + [d| + instance FieldOwner $(varT selectedNVarName) + $(varT selectedVVarName) + $(pure recordType) + where + setField = const $ $(pure setFieldLambda) + getField = const $ $(pure getFieldLambda) + |] + + +instance FieldOwner "1" v1 (Identity v1) where + setField _ v _ = Identity v + getField _ = runIdentity + + +-- Generate FieldOwner instances for tuples +return $ do + arity <- [2 .. 24] + nIndex <- [1 .. arity] + return $ + let + typeName = + tupleTypeName arity + conName = + tupleDataName arity + selectedVVarName = + mkName $ "v" <> show nIndex + tupleType = + foldl (\a i -> AppT a (VarT (mkName ("v" <> show i)))) + (ConT typeName) + [1 .. arity] + setFieldLambda = + LamE [VarP vVarName, ConP conName (fmap VarP indexedVVarNames)] exp + where + vVarName = + mkName "v" + indexedVVarNames = + fmap (\i -> mkName ("v" <> show i)) [1..arity] + exp = + foldl (\a i -> AppE a (VarE (mkName (if i == nIndex then "v" else "v" <> show i)))) + (ConE conName) + [1 .. arity] + getFieldLambda = + LamE [ConP conName vPatterns] (VarE (vVarName)) + where + vVarName = + mkName "v" + vPatterns = + flip map [1 .. arity] $ \i -> + if i == nIndex + then VarP vVarName + else WildP + in + head $ unsafePerformIO $ runQ $ + [d| + instance FieldOwner $(pure (LitT (StrTyLit (show nIndex)))) + $(varT selectedVVarName) + $(pure tupleType) + where + setField = const $ $(pure setFieldLambda) + getField = const $ $(pure getFieldLambda) + |] diff --git a/record.cabal b/record.cabal new file mode 100644 --- /dev/null +++ b/record.cabal @@ -0,0 +1,94 @@ +name: + record +version: + 0.1.0 +synopsis: + First class records implemented with quasi-quotation +description: + An API of just two quasi-quoters, + providing a full-scale solution to the notorious records problem of Haskell. + . + Links: + . + * . + . + * . + . +category: + Control, Data Structures +homepage: + https://github.com/nikita-volkov/record +bug-reports: + https://github.com/nikita-volkov/record/issues +author: + Nikita Volkov +maintainer: + Nikita Volkov +copyright: + (c) 2015, Nikita Volkov +license: + MIT +license-file: + LICENSE +build-type: + Simple +cabal-version: + >=1.10 + + +source-repository head + type: + git + location: + git://github.com/nikita-volkov/record.git + + +library + hs-source-dirs: + library + ghc-options: + -funbox-strict-fields + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: + Haskell2010 + other-modules: + Record.Parser + exposed-modules: + Record.Types + Record.Lens + Record + build-depends: + -- + attoparsec >= 0.10 && < 0.13, + -- + text, + -- + template-haskell, + -- + transformers >= 0.2 && < 0.5, + base-prelude >= 0.1 && < 0.2, + base >= 4.6 && < 4.9 + + +-- Well, it's not a benchmark actually, +-- but in Cabal there's no better way to specify an executable, +-- which is not intended for distribution. +benchmark demo + type: + exitcode-stdio-1.0 + hs-source-dirs: + demo + main-is: + Main.hs + ghc-options: + -O2 + -threaded + "-with-rtsopts=-N" + -funbox-strict-fields + -ddump-splices + default-language: + Haskell2010 + build-depends: + record, + base-prelude