record 0.3.2.1 → 0.4.0.0
raw patch · 10 files changed
+333/−1030 lines, 10 filesdep +basic-lensdep −attoparsecdep −directorydep −doctestdep ~basedep ~base-preludedep ~template-haskellsetup-changed
Dependencies added: basic-lens
Dependencies removed: attoparsec, directory, doctest, filepath, record, template-haskell-compat-v0208, text, transformers
Dependency ranges changed: base, base-prelude, template-haskell
Files
- CHANGELOG.md +6/−0
- Setup.hs +2/−6
- demo/Main.hs +0/−49
- doctest/Main.hs +0/−13
- library/Record.hs +58/−241
- library/Record/Lens.hs +0/−40
- library/Record/Parser.hs +0/−329
- library/Record/TH.hs +253/−0
- library/Record/Types.hs +0/−272
- record.cabal +14/−80
CHANGELOG.md view
@@ -1,3 +1,9 @@+# 0.4.0+* Drop the quasi-quoters+* Drop the "Lens" module in preference to a dependency on the "basic-lens" library+* Generate strict record types+* Export the types from the root module+ # 0.3.1 * Support for arrow types * Higher arity bugs fix
Setup.hs view
@@ -1,6 +1,2 @@-module Main where--import Distribution.Extra.Doctest ( defaultMainWithDoctests )--main :: IO ()-main = defaultMainWithDoctests "doctest"+import Distribution.Simple+main = defaultMain
− demo/Main.hs
@@ -1,49 +0,0 @@-{-# 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 Person Int Int-personBirthdayYearLens =- [lens|birthday.year|]--personBirthdayYearLens' :: Lens Person Person Int Int-personBirthdayYearLens' =- [lens|birthday|] . [lens|year|]--tupleLens :: Lens (Int, Char, String) (Int, Char, a) String a-tupleLens =- [lens|3|]--mapThirdElement :: (Char -> b) -> (Int, String, Char) -> (Int, String, b)-mapThirdElement =- over [lens|3|]--functionOnARecord :: [record| {name :: String, age :: [Int]}|] -> [Int]-functionOnARecord =- view [lens|age|]
− doctest/Main.hs
@@ -1,13 +0,0 @@-module Main where--import Prelude-import Build_doctests (flags, pkgs, module_sources)-import Data.Foldable (traverse_)-import Test.DocTest--main :: IO ()-main = do- traverse_ putStrLn args- doctest args- where- args = flags ++ pkgs ++ module_sources
library/Record.hs view
@@ -1,257 +1,74 @@-module Record-(- record,- lens,- -- ** Shorthands- r,- l,-)-where+-- |+-- Types and instances of anonymous records.+module Record where -import BasePrelude-import Language.Haskell.TH-import Language.Haskell.TH.Syntax-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+import BasePrelude hiding (Proxy)+import Data.Functor.Identity+import GHC.TypeLits+import Foreign.Storable+import Foreign.Ptr (plusPtr)+import Control.Lens.Basic+import qualified Record.TH as TH --- | 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 specialised version of "Data.Proxy.Proxy".+-- Defined for compatibility with \"base-4.6\",+-- since @Proxy@ was only defined in \"base-4.7\".+data FieldName (t :: Symbol) -- |--- 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:+-- Defines a lens to manipulate some value of a type by a type-level name,+-- using the string type literal functionality.+--+-- Instances are provided for all records and for tuples of arity of up to 24.+--+-- Here's how you can use it with tuples:+--+-- >trd :: Field "3" a a' v v' => a -> v+-- >trd = view (fieldLens (undefined :: FieldName "3")) -- --- >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+-- The function above will get you the third item of any tuple, which has it.+class Field (n :: Symbol) a a' v v' | n a -> v, n a' -> v', n a v' -> a', n a' v -> a where+ fieldLens :: FieldName n -> Lens a a' v v' -renderLens :: Parser.Lens -> Exp-renderLens =- foldl1 composition .- fmap renderSingleLens- where- composition a b = - UInfixE a (VarE '(.)) b+instance Field "1" (Identity v1) (Identity v1') v1 v1' where+ fieldLens = const $ \f -> fmap Identity . f . runIdentity -renderSingleLens :: T.Text -> Exp-renderSingleLens =- AppE (VarE 'Types.fieldLens) .- SigE (VarE 'undefined) .- AppT (ConT ''Types.FieldName) .- LitT . StrTyLit . T.unpack+-- Generate the tuple instances of the Field class:+return $ do+ arity <- [2 .. 24]+ fieldIndex <- [1 .. arity]+ return $ TH.tupleFieldInstanceDec arity fieldIndex -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+-- |+-- A simplified field constraint,+-- which excludes the possibility of type-changing updates.+type Field' n a v =+ Field n a a v v -recordTypeNameByArity :: Int -> Maybe Name-recordTypeNameByArity arity =- if arity > 24 || arity < 1- then Nothing- else Just (Name (OccName ("Record" <> show arity)) ns)- where- ns = case ''Types.Record1 of Name _ x -> x -recordConNameByArity :: Int -> Maybe Name-recordConNameByArity arity =- if arity > 24 || arity < 1- then Nothing- else Just (Name (OccName ("Record" <> show arity)) ns)- where- ns = case 'Types.Record1 of Name _ x -> x+-- * Record types and instances+------------------------- -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+-- Generate the record types and instances:+return $ do+ arity <- [1 .. 24]+ strict <- [False, True]+ let+ recordType =+ TH.recordTypeDec strict arity+ fieldInstances =+ do+ fieldIndex <- [1 .. arity]+ return $ TH.recordFieldInstanceDec strict arity fieldIndex+ storableInstance =+ TH.recordStorableInstanceDec strict arity+ in recordType : storableInstance : fieldInstances -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 (VarE 'undefined) - (AppT (ConT ''Types.FieldName) (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.FieldName n1 -> v1 -> Types.FieldName 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.FieldName) (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)) :- []-+-- * Record construction functions with field names+------------------------- +-- Generate the function declarations:+return $ concat $ TH.recordConFunDecs <$> [False, True] <*> [1 .. 24]
− library/Record/Lens.hs
@@ -1,40 +0,0 @@--- |--- 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 from a datastructure @s@ to its some part @a@,--- which can be used to manipulate that particular part.--- It is possible to change the part to another type @a'@ during updates.--- In such case the whole datastructure will change the type to @s'@ as well.-type Lens s s' a 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 s' a 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 s' a 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 s' a a' -> (a -> a') -> s -> s'-over l f =- runIdentity . l (Identity . f)
− library/Record/Parser.hs
@@ -1,329 +0,0 @@-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 Ident |- Type_Tuple Int |- Type_Arrow |- Type_List |- Type_Record RecordType- deriving (Show)--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 "")---- |--- Run a parser on a given input,--- lifting its errors to the context parser.------ Consider it a subparser.-parser :: Parser a -> Text -> Parser a-parser p t =- either fail return $- run p t--labeled :: String -> Parser a -> Parser a-labeled =- flip (<?>)--qq :: Parser a -> Parser a-qq p =- skipSpace *> p <* skipSpace <* endOfInput---- |--- >>> run type' "(Int, Char)"--- Right (Type_App (Type_App (Type_Tuple 2) (Type_Con "Int")) (Type_Con "Char"))------ >>> run type' "(,) Int Int"--- Right (Type_App (Type_App (Type_Tuple 2) (Type_Con "Int")) (Type_Con "Int"))------ >>> run type' "(,)"--- Right (Type_Tuple 2)------ >>> run type' "()"--- Right (Type_Tuple 0)------ >>> run type' "Int -> Double"--- Right (Type_App (Type_App Type_Arrow (Type_Con "Int")) (Type_Con "Double"))------ >>> run type' "(->) Int Double"--- Right (Type_App (Type_App Type_Arrow (Type_Con "Int")) (Type_Con "Double"))------ >>> run type' "A -> B -> C"--- Right (Type_App (Type_App Type_Arrow (Type_Con "A")) (Type_App (Type_App Type_Arrow (Type_Con "B")) (Type_Con "C")))-type' :: Parser Type-type' =- labeled "type'" $- appArrowType <|> appType- where- -- Matches "appType -> (type)+"- -- Note the right associativity of the arrow operator.- appArrowType = do- t <- appType- skipMany1 space- a <- arrowType- skipMany1 space- t' <- type'- return $ Type_App (Type_App a t) t'- -- Corresponds to GHC's "btype" rule- -- Matches either two or more types and "App"s them,- -- or a single type.- appType =- (foldl1 Type_App <$>- sepBy1 nonAppType (skipMany1 space))- <|> nonAppType- -- Corresponds to GHC's "atype" rule- nonAppType =- arrowTypeCon <|> conType <|> tupleConType <|> tupleType <|> listConType <|> listType <|>- varType <|> (Type_Record <$> recordType) <|> inBraces type'- varType =- fmap Type_Var $ lowerCaseName- conType =- fmap Type_Con $ upperCaseIdent- tupleConType =- Type_Tuple 0 <$ string "()" <|>- Type_Tuple . succ . length <$> (char '(' *> many (char ',') <* char ')')- tupleType =- do- char '('- skipSpace- h <- type' <* skipSpace <* char ',' <* skipSpace- t <- sepBy1 type' (skipSpace *> char ',' <* skipSpace)- skipSpace- char ')'- return $ foldl Type_App (Type_Tuple (1 + length t)) $ h : t- listType =- fmap (Type_App Type_List) $- char '[' *> skipSpace *> type' <* skipSpace <* char ']'- listConType =- Type_List <$ string "[]"- arrowTypeCon =- Type_Arrow <$ 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 Ident =- Text--lowerCaseIdent :: Parser Ident-lowerCaseIdent =- labeled "lowerCaseIdent" $- fmap (T.intercalate ".") $- (<>) <$>- (many (upperCaseName <* char '.')) <*>- (pure <$> (lowerCaseName <|> symbolicIdent))--upperCaseIdent :: Parser Ident-upperCaseIdent =- labeled "upperCaseIdent" $- fmap (T.intercalate ".") $- (<>) <$>- (many (upperCaseName <* char '.')) <*>- (pure <$> (upperCaseName <|> symbolicIdent))---type Lens =- [Text]--lens :: Parser Lens-lens =- labeled "lens" $- sepBy1 (lowerCaseName <|> takeWhile1 isDigit) (char '.')---data Exp =- Exp_Record RecordExp |- Exp_Var Ident |- Exp_Con Ident |- Exp_TupleCon Int |- Exp_Nil |- Exp_Lit Lit |- Exp_App Exp Exp |- Exp_List [Exp] |- Exp_Sig Exp Type- deriving (Show)--type RecordExp =- [(Text, Exp)]--data Lit =- Lit_Char Char |- Lit_String Text |- Lit_Integer Integer |- Lit_Rational Rational- deriving (Show)---- |------ >>> run exp "(,)"--- Right (Exp_TupleCon 2)------ >>> run exp "(1,2)"--- Right (Exp_App (Exp_App (Exp_TupleCon 2) (Exp_Lit (Lit_Integer 1))) (Exp_Lit (Lit_Integer 2)))------ >>> run exp "(1)"--- Right (Exp_Lit (Lit_Integer 1))------ >>> run exp "()"--- Right (Exp_TupleCon 0)-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 <$> lowerCaseIdent- con =- Exp_Con <$> upperCaseIdent- tupleCon =- Exp_TupleCon 0 <$ string "()" <|>- Exp_TupleCon . succ . length <$> (char '(' *> many (char ',') <* char ')')- nil =- Exp_Nil <$ string "[]"- tuple =- do- char '('- skipSpace- h <- exp <* skipSpace <* char ',' <* skipSpace- t <- sepBy1 exp (skipSpace *> char ',' <* skipSpace)- skipSpace- char ')'- return $ foldl Exp_App (Exp_TupleCon (1 + length t)) $ h : t- list =- fmap Exp_List $- char '[' *> skipSpace *>- sepBy1 exp (skipSpace *> char ',' <* skipSpace) <*- skipSpace <* char ']'---- |------ Integers get parsed as integers:------ >>> run lit "2"--- Right (Lit_Integer 2)------ Rationals get parsed as rationals:------ >>> run lit "2.0"--- Right (Lit_Rational (2 % 1))------ >>> run lit "3e2"--- Right (Lit_Rational (300 % 1))-lit :: Parser Lit-lit =- Lit_Char <$> charLit <|>- Lit_String <$> stringLit <|>- Lit_Rational <$> rationalNotDecimal <|>- Lit_Integer <$> decimal- where- rationalNotDecimal =- match rational >>= \(t, r) ->- case run (decimal <* endOfInput) t of- Left _ -> return r- _ -> mzero
+ library/Record/TH.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE CPP #-}+module Record.TH where++import BasePrelude hiding (Proxy)+import GHC.TypeLits+import Language.Haskell.TH hiding (classP)+++classP :: Name -> [Type] -> Pred+#if MIN_VERSION_template_haskell(2,10,0)+classP n tl = foldl AppT (ConT n) tl+#else+classP = ClassP+#endif++recordTypeDec :: Bool -> Int -> Dec+recordTypeDec strict arity =+ DataD [] name varBndrs [NormalC name conTypes] derivingNames+ where+ name =+ recordName strict 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 $ (,) strictness (VarT (mkName ("v" <> show i)))+ where+ strictness =+ if strict then IsStrict else NotStrict+ derivingNames =+#if MIN_VERSION_base(4,7,0)+ [''Show, ''Eq, ''Ord, ''Typeable, ''Generic]+#else+ [''Show, ''Eq, ''Ord, ''Generic]+#endif++recordName :: Bool -> Int -> Name+recordName strict arity =+ mkName $ recordNameString strict arity++recordNameString :: Bool -> Int -> String+recordNameString strict arity =+ prefix <> "Record" <> show arity+ where+ prefix =+ if strict then "Strict" else "Lazy"++recordFieldInstanceDec :: Bool -> Int -> Int -> Dec+recordFieldInstanceDec strict =+ fieldInstanceDec (FieldInstanceDecMode_Record strict)++tupleFieldInstanceDec :: Int -> Int -> Dec+tupleFieldInstanceDec arity fieldIndex =+ fieldInstanceDec FieldInstanceDecMode_Tuple arity fieldIndex++data FieldInstanceDecMode =+ FieldInstanceDecMode_Tuple |+ FieldInstanceDecMode_Record Bool++fieldInstanceDec :: FieldInstanceDecMode -> Int -> Int -> Dec+fieldInstanceDec mode arity fieldIndex =+ InstanceD [] headType decs+ where+ headType =+ foldl1 AppT + [classType, VarT selectedNVarName, recordType, recordPrimeType, VarT selectedVVarName, VarT selectedVPrimeVarName]+ where+ classType =+ ConT (mkName "Field")+ typeName =+ case mode of+ FieldInstanceDecMode_Tuple -> tupleTypeName arity+ FieldInstanceDecMode_Record strict -> recordName strict arity+ conName =+ case mode of+ FieldInstanceDecMode_Tuple -> tupleDataName arity+ FieldInstanceDecMode_Record strict -> recordName strict arity+ selectedNVarName =+ mkName $ "n" <> show fieldIndex+ selectedVVarName =+ mkName $ "v" <> show fieldIndex+ selectedVPrimeVarName =+ mkName $ "v" <> show fieldIndex <> "'"+ recordType =+ foldl (\a i -> AppT (addNVar a i)+ (VarT (mkName ("v" <> show i))))+ (ConT typeName)+ [1 .. arity]+ recordPrimeType =+ foldl (\a i -> AppT (addNVar a i)+ (VarT (if i == fieldIndex then selectedVPrimeVarName+ else mkName ("v" <> show i))))+ (ConT typeName)+ [1 .. arity]+ addNVar =+ case mode of+ FieldInstanceDecMode_Tuple -> \a i -> a+ FieldInstanceDecMode_Record _ -> \a i -> AppT a (VarT (mkName ("n" <> show i)))+ decs =+ [fieldLensDec]+ where+ fieldLensDec =+ FunD (mkName "fieldLens") [Clause patterns (NormalB exp) []]+ where+ patterns =+ [WildP, VarP fVarName, ConP conName (fmap VarP indexedVVarNames)]+ fVarName =+ mkName "f"+ indexedVVarNames =+ fmap (\i -> mkName ("v" <> show i)) [1..arity]+ exp =+ AppE (AppE (VarE 'fmap) (consLambda))+ (AppE (VarE fVarName) (VarE selectedVVarName))+ where+ consLambda =+ LamE [VarP selectedVPrimeVarName] exp+ where+ exp =+ foldl AppE (ConE conName) $+ map VarE $+ map (\(i, n) -> if i == fieldIndex then selectedVPrimeVarName+ else mkName ("v" <> show i)) $+ zip [1 .. arity] indexedVVarNames++recordStorableInstanceDec :: Bool -> Int -> Dec+recordStorableInstanceDec strict arity =+ InstanceD context (AppT (ConT (mkName "Storable")) recordType)+ [sizeOfFun, inlineFun "sizeOf", alignmentFun, inlineFun "alignment"+ , peekFun, inlineFun "peek", pokeFun, inlineFun "poke"]+ where+ name = recordName strict arity+ recordType =+ foldl (\a i -> AppT (AppT a (VarT (mkName ("n" <> show i))))+ (VarT (mkName ("v" <> show i))))+ (ConT name)+ [1 .. arity]+ context = map (\i -> classP (mkName "Storable") [VarT (mkName ("v" <> show i))])+ [1 .. arity]+ nameE = VarE . mkName+ -- The sum of the sizes of all types+ sizeOfFun' n = foldr (\a b -> AppE (AppE (nameE "+") a) b) (LitE (IntegerL 0)) $+ map (\i -> AppE+ (nameE "sizeOf")+ (SigE (nameE "undefined")+ (VarT (mkName ("v" <> show i)))))+ [1..n]+ sizeOfFun = FunD (mkName "sizeOf")+ [Clause [WildP]+ (NormalB (sizeOfFun' arity)) []]+ -- Set the alignment to the maximum alignment of the types+ alignmentFun = FunD (mkName "alignment")+ [(Clause [WildP]+ (NormalB (AppE (nameE "maximum") $ ListE $+ map (\i -> AppE+ (nameE "sizeOf")+ (SigE (nameE "undefined")+ (VarT (mkName ("v" <> show i)))))+ [1..arity])) [])]+ -- Peek every variable, remember to add the size of the elements already seen to the ptr+ peekFun = FunD (mkName "peek")+ [(Clause [VarP (mkName "ptr")]+ (NormalB (DoE $ map (\i -> BindS+ (BangP (VarP (mkName ("x" <> show i))))+ (AppE (nameE "peek")+ (AppE (AppE (nameE "plusPtr")+ (nameE "ptr"))+ (sizeOfFun' (i - 1))))) [1..arity]+ ++ [NoBindS (AppE (nameE "return")+ (foldl (\a i -> AppE a (nameE ("x" <> show i)))+ (ConE name) [1 .. arity]))])) [])]+ typePattern = ConP name (map (\i -> VarP (mkName ("v" <> show i))) [1..arity])+ pokeFun = FunD (mkName "poke")+ [(Clause [VarP (mkName "ptr"), typePattern]+ (NormalB (DoE $ map (\i -> NoBindS+ (AppE+ (AppE (VarE (mkName "poke"))+ (AppE (AppE (nameE "plusPtr")+ (nameE "ptr"))+ (sizeOfFun' (i - 1))))+ (nameE ("v" <> show i)))) [1..arity])) [])]+ inlineFun name = PragmaD $ InlineP (mkName name) Inline FunLike AllPhases++recordConFunDecs :: Bool -> Int -> [Dec]+recordConFunDecs strict arity =+ [inline, fun]+ where+ inline =+ PragmaD (InlineP name Inline FunLike AllPhases)+ fun =+ FunD name [Clause [] (NormalB (recordConLambdaExp strict arity)) []]+ name =+ mkName string+ where+ string =+ onHead toLower (recordNameString strict arity)+ where+ onHead f =+ \case+ a : b -> f a : b+ [] -> []++-- |+-- Allows to specify field names at value-level.+-- Useful for type-inference.+-- +-- E.g., in+-- +-- >(\_ v1 _ v2 -> StrictRecord2 v1 v2) :: Types.FieldName n1 -> v1 -> Types.FieldName n2 -> v2 -> StrictRecord2 n1 v1 n2 v2+-- +-- we can set the name signatures by passing+-- the name-proxies to this lambda.+recordConLambdaExp :: Bool -> Int -> Exp+recordConLambdaExp strict arity =+ SigE exp t+ where+ name =+ recordName strict arity+ exp =+ LamE pats exp+ where+ pats =+ concat $ flip map [1 .. arity] $ \i -> [WildP, VarP (mkName ("v" <> show i))]+ exp =+ foldl AppE (ConE name) (map (\i -> VarE (mkName ("v" <> show i))) [1 .. arity])+ t =+ fnType name+ 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 (mkName "FieldName")) (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)) :+ []+
− library/Record/Types.hs
@@ -1,272 +0,0 @@-{-# 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-import Foreign.Storable-import Foreign.Ptr (plusPtr)-import qualified TemplateHaskell.Compat.V0208 as A----- *------------------------------- |--- Defines a lens to manipulate some value of a type by a type-level name,--- using the string type literal functionality.------ Instances are provided for all records and for tuples of arity of up to 24.------ Here's how you can use it with tuples:------ >trd :: Field "3" v v' a' a => a -> v--- >trd = view . fieldLens (undefined :: FieldName "3")--- The function above will get you the third item of any tuple, which has it.-class Field (n :: Symbol) a a' v v' | n a -> v, n a' -> v', n a v' -> a', n a' v -> a where- -- |- -- A polymorphic lens. E.g.:- --- -- >ageLens :: Field "age" v v' a' a => Lens a a' v v'- -- >ageLens = fieldLens (undefined :: FieldName "age")- fieldLens :: FieldName n -> Lens a a' v v'---- |--- A simplified field constraint,--- which excludes the possibility of type-changing updates.-type Field' n a v =- Field n a a v v---- |--- A specialised version of "Data.Proxy.Proxy".--- Defined for compatibility with \"base-4.6\",--- since @Proxy@ was only defined in \"base-4.7\".-data FieldName (t :: Symbol)----- * 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 $ (,) (A.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- A.dataD [] typeName varBndrs [NormalC typeName conTypes] derivingNames----- Generate instances of Foreign.Storable-return $ flip map [1 .. 24] $ \arity ->- let- typeName = mkName $ "Record" <> show arity- recordType =- foldl (\a i -> AppT (AppT a (VarT (mkName ("n" <> show i))))- (VarT (mkName ("v" <> show i))))- (ConT typeName)- [1 .. arity]-#if MIN_VERSION_template_haskell(2,10,0)- -- In TH with `ConstraintKinds` the context is just simply a type- context = map (\i -> AppT (ConT (mkName "Storable")) (VarT (mkName ("v" <> show i))))- [1 .. arity]-#else- context = map (\i -> ClassP (mkName "Storable") [VarT (mkName ("v" <> show i))])- [1 .. arity]-#endif- nameE = VarE . mkName- -- The sum of the sizes of all types- sizeOfFun' n = foldr (\a b -> AppE (AppE (nameE "+") a) b) (LitE (IntegerL 0)) $- map (\i -> AppE- (nameE "sizeOf")- (SigE (nameE "undefined")- (VarT (mkName ("v" <> show i)))))- [1..n]- sizeOfFun = FunD (mkName "sizeOf")- [Clause [WildP]- (NormalB (sizeOfFun' arity)) []]- -- Set the alignment to the maximum alignment of the types- alignmentFun = FunD (mkName "alignment")- [(Clause [WildP]- (NormalB (AppE (nameE "maximum") $ ListE $- map (\i -> AppE- (nameE "sizeOf")- (SigE (nameE "undefined")- (VarT (mkName ("v" <> show i)))))- [1..arity])) [])]- -- Peek every variable, remember to add the size of the elements already seen to the ptr- peekFun = FunD (mkName "peek")- [(Clause [VarP (mkName "ptr")]- (NormalB (DoE $ map (\i -> BindS- (BangP (VarP (mkName ("x" <> show i))))- (AppE (nameE "peek")- (AppE (AppE (nameE "plusPtr")- (nameE "ptr"))- (sizeOfFun' (i - 1))))) [1..arity]- ++ [NoBindS (AppE (nameE "return")- (foldl (\a i -> AppE a (nameE ("x" <> show i)))- (ConE typeName) [1 .. arity]))])) [])]- typePattern = ConP typeName (map (\i -> VarP (mkName ("v" <> show i))) [1..arity])- pokeFun = FunD (mkName "poke")- [(Clause [VarP (mkName "ptr"), typePattern]- (NormalB (DoE $ map (\i -> NoBindS- (AppE- (AppE (VarE (mkName "poke"))- (AppE (AppE (nameE "plusPtr")- (nameE "ptr"))- (sizeOfFun' (i - 1))))- (nameE ("v" <> show i)))) [1..arity])) [])]- inlineFun name = PragmaD $ InlineP (mkName name) Inline FunLike AllPhases- in- A.instanceD context (AppT (ConT (mkName "Storable")) recordType)- [sizeOfFun, inlineFun "sizeOf", alignmentFun, inlineFun "alignment"- , peekFun, inlineFun "peek", pokeFun, inlineFun "poke"]---- *----------------------------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- selectedV'VarName =- 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]- record'Type =- foldl (\a i -> AppT (AppT a (VarT (mkName ("n" <> show i))))- (VarT (if i == nIndex then selectedV'VarName- else mkName ("v" <> show i))))- (ConT typeName)- [1 .. arity]- fieldLensLambda =- LamE [VarP fVarName, ConP typeName (fmap VarP indexedVVarNames)] exp- where- fVarName =- mkName "f"- indexedVVarNames =- fmap (\i -> mkName ("v" <> show i)) [1..arity]- exp =- AppE (AppE (VarE 'fmap) (consLambda))- (AppE (VarE fVarName) (VarE selectedVVarName))- where- consLambda =- LamE [VarP selectedV'VarName] exp- where- exp =- foldl AppE (ConE typeName) $- map VarE $- map (\(i, n) -> if i == nIndex then selectedV'VarName- else mkName ("v" <> show i)) $- zip [1 .. arity] indexedVVarNames- in- head $ unsafePerformIO $ runQ $- [d|- instance Field $(varT selectedNVarName)- $(pure recordType)- $(pure record'Type)- $(varT selectedVVarName)- $(varT selectedV'VarName)- where- {-# INLINE fieldLens #-}- fieldLens = const $(pure fieldLensLambda)- |]---instance Field "1" (Identity v1) (Identity v1') v1 v1' where- fieldLens = const $ \f -> fmap Identity . f . runIdentity----- Generate Field instances for tuples-return $ do- arity <- [2 .. 24]- nIndex <- [1 .. arity]- return $- let- typeName =- tupleTypeName arity- conName =- tupleDataName arity- selectedVVarName =- mkName $ "v" <> show nIndex- selectedV'VarName =- mkName $ "v" <> show nIndex <> "'"- tupleType =- foldl (\a i -> AppT a (VarT (mkName ("v" <> show i))))- (ConT typeName)- [1 .. arity]- tuple'Type =- foldl (\a i -> AppT a (VarT (if i == nIndex then selectedV'VarName- else mkName ("v" <> show i))))- (ConT typeName)- [1 .. arity]- fieldLensLambda =- LamE [VarP fVarName, ConP conName (fmap VarP indexedVVarNames)] exp- where- fVarName =- mkName "f"- indexedVVarNames =- fmap (\i -> mkName ("v" <> show i)) [1..arity]- exp =- AppE (AppE (VarE 'fmap) (consLambda))- (AppE (VarE fVarName) (VarE selectedVVarName))- where- consLambda =- LamE [VarP selectedV'VarName] exp- where- exp =- foldl AppE (ConE conName) $- map VarE $- map (\(i, n) -> if i == nIndex then selectedV'VarName- else mkName ("v" <> show i)) $- zip [1 .. arity] indexedVVarNames- in- head $ unsafePerformIO $ runQ $- [d|- instance Field $(pure (LitT (StrTyLit (show nIndex))))- $(pure tupleType)- $(pure tuple'Type)- $(varT selectedVVarName)- $(varT selectedV'VarName)- where- {-# INLINE fieldLens #-}- fieldLens = const $(pure fieldLensLambda)- |]
record.cabal view
@@ -1,21 +1,16 @@ name: record version:- 0.3.2.1+ 0.4.0.0 synopsis:- First class records implemented with quasi-quotation+ Anonymous records description:- An API of just two quasi-quoters, - providing a full-scale solution to the notorious records problem of Haskell.- .- Links:- .- * <http://nikita-volkov.github.io/record A comprehensive introduction to the library>.- .- * <https://github.com/nikita-volkov/record/blob/master/demo/Main.hs Demo>.- .+ This library provides the abstractions behind the anonymous record syntax.+ It is intended to be used in conjunction with+ <http://hackage.haskell.org/package/record-preprocessor the "record-preprocessor">,+ which enables a Haskell syntax extension. category:- Control, Data Structures+ Control, Data Structures, Records homepage: https://github.com/nikita-volkov/record bug-reports:@@ -31,7 +26,7 @@ license-file: LICENSE build-type:- Custom+ Simple cabal-version: >=1.10 extra-source-files:@@ -45,82 +40,21 @@ git://github.com/nikita-volkov/record.git -flag doctest- description: Build Doctests- default: True- manual: True-- library hs-source-dirs: library- ghc-options:- -funbox-strict-fields default-extensions:- Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ 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+ Record.TH exposed-modules:- Record.Types- Record.Lens Record build-depends: -- - attoparsec >= 0.12 && < 0.14,- -- - text >= 1 && < 2,- --- template-haskell >= 2.8 && < 3,- template-haskell-compat-v0208 >= 0.1.1.1 && < 0.2,+ template-haskell == 2.*, -- - transformers >= 0.2 && < 0.6,- base-prelude >= 0.1 && < 2,- base >= 4.6 && < 5---test-suite doctest- type:- exitcode-stdio-1.0- hs-source-dirs:- doctest- main-is:- Main.hs- ghc-options:- -threaded- "-with-rtsopts=-N"- -funbox-strict-fields- default-extensions:- Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language:- Haskell2010- if !flag(doctest)- buildable: False- build-depends:- doctest >= 0.13 && < 0.17,- directory >= 1.2 && < 1.5,- filepath >= 1.3 && < 1.5,- base----- Well, it's not a benchmark actually, --- but in Cabal there's no cleaner 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- default-language:- Haskell2010- build-depends:- record,- base-prelude+ basic-lens == 0.0.*,+ base-prelude >= 0.1 && < 0.2,+ base >= 4.6 && < 4.9