hasbolt-extras 0.0.1.4 → 0.0.1.5

raw patch · 3 files changed

+37/−46 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• hasbolt-extras.cabal +1/−1
• src/Database/Bolt/Extras/Template/Internal/Converters.hs +31/−45

@@ -6,6 +6,11 @@  ## [Unreleased] +## [0.0.1.5] - 2020-12-22+### Fixed+- Compatibility of `makeNodeLike` / `makeURelationLike` with `DuplicateRecordFields`, thanks to+  [@oddsome](https://github.com/oddsome), [PR #40](https://github.com/biocad/hasbolt-extras/pull/40).+ ## [0.0.1.4] - 2020-05-27 ### Fixed - Compatibility with GHC-8.10.

@@ -1,5 +1,5 @@ name:           hasbolt-extras-version:        0.0.1.4+version:        0.0.1.5 synopsis:       Extras for hasbolt library description:    Extras for hasbolt library homepage:       https://github.com/biocad/hasbolt-extras#readme

@@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP             #-} {-# LANGUAGE TemplateHaskell #-}  module Database.Bolt.Extras.Template.Internal.Converters@@ -10,8 +10,6 @@   , makeURelationLikeWith   ) where -import           Control.Lens               (view, _1)-import           Control.Monad              ((>=>)) import           Data.Map.Strict            (fromList, member, notMember, (!)) import           Data.Text                  (Text, pack, unpack) import           Database.Bolt (Node (..), URelationship (..), Value (..))@@ -151,18 +149,18 @@   -- nameBase gives object name without package prefix. `label` is the type name here.   let label = nameBase tyName -  -- collects the names of all fields in the type.-  let dataFields = concatMap (snd . getConsFields) constr+  -- collects names and types of all fields in the type.+  let (dataFields, fieldTypes) = unzip $ concatMap (snd . getConsFields) constr    -- gets data constructor name   let (consName, _) = head $ fmap getConsFields constr -  -- Just a fresh variable. It will be used in labmda abstractions in makeToClause and makeFromClause functions.+  -- Just a fresh variable. It will be used in labmda abstractions in makeFromClause function.   fresh <- newName "x"    -- constructs `bijective` class functions (phi and phiInv – toClause and fromClause correspondingly here).-  toClause   <- makeToClause label dataName fresh dataFields fieldLabelModifier-  fromClause <- makeFromClause label consName fresh dataFields fieldLabelModifier+  toClause   <- makeToClause label dataName consName dataFields fieldLabelModifier+  fromClause <- makeFromClause label consName fresh dataFields fieldTypes fieldLabelModifier    -- function declarations themselves.   let bodyDecl = [FunD classToFun [toClause], FunD classFromFun [fromClause]]@@ -170,14 +168,12 @@   -- Instance declaration itself.   pure [InstanceD Nothing [] (AppT (ConT className) (ConT typeCon)) bodyDecl] ----- | Extract information about type: constructor name and field record names.+-- | Extract information about type: constructor name and field record names with corresponding types. ---getConsFields :: Con -> (Name, [Name])-getConsFields (RecC cName decs)           = (cName, fmap (view _1) decs)+getConsFields :: Con -> (Name, [(Name, Type)])+getConsFields (RecC cName decs)           = (cName, fmap (\(fname, _, ftype) -> (fname, ftype)) decs) getConsFields (ForallC _ _ cons)          = getConsFields cons-getConsFields (RecGadtC (cName:_) decs _) = (cName, fmap (view _1) decs)+getConsFields (RecGadtC (cName:_) decs _) = (cName, fmap (\(fname, _, ftype) -> (fname, ftype)) decs) getConsFields (NormalC cName _)           = (cName, []) getConsFields _                           = error $ $currentLoc ++ "unsupported data declaration." @@ -192,20 +188,20 @@ -- | Describes the body of conversion to target type function. -- makeToClause :: String -> Name -> Name -> [Name] -> (String -> String) -> Q Clause-makeToClause label dataCons varName dataFields fieldLabelModifier-  | null dataFields = pure $ Clause [WildP] (NormalB result) []-  | otherwise       = pure $ Clause [VarP varName] (NormalB result) []+makeToClause label dataCons consName dataFields fieldLabelModifier+  | null dataFields = pure $ Clause [WildP] (NormalB $ result []) []+  | otherwise       = do+    fieldVars <- sequenceQ $ newName "_field" <$ dataFields -- var for each field+    pure $ Clause [recPat fieldVars] (NormalB $ result fieldVars) []   where-    -- apply field record to a data.-    getValue :: Name -> Exp-    getValue name = AppE (VarE name) (VarE varName)+    -- construct record pattern: (Rec {f1 = v1, ... })+    recPat :: [Name] -> Pat+    recPat fieldVars = ParensP $ RecP consName $ zip dataFields $ VarP <$> fieldVars      -- List of values which a data holds.-    -- The same in terms of Haskell :: valuesExp = fmap (\field -> toValue (field x))-    -- `x` is a bounded in pattern match variable (e.g. toNode x = ...). If toNode :: a -> Node, then x :: a, i.e. x is data which we want to convert into Node.-    -- `field` is a field record function.-    valuesExp :: [Exp]-    valuesExp = fmap (AppE (VarE 'toValue) . getValue) dataFields+    -- The same in terms of Haskell :: valuesExp = fmap (\field -> toValue fieldVar)+    valuesExp :: [Name] -> [Exp]+    valuesExp = fmap (AppE (VarE 'toValue) . VarE)      -- Retrieve all field record names from the convertible type.     fieldNames :: [String]@@ -214,14 +210,14 @@     -- List of pairs :: [(key, value)]     -- `key` is field record name.     -- `value` is the data that corresponding field holds.-    pairs :: [Exp]-    pairs = zipWith (\fld val -> tupE' [strToTextE $ fieldLabelModifier fld, val]) fieldNames valuesExp+    pairs :: [Name] -> [Exp]+    pairs = zipWith (\fld val -> tupE' [strToTextE $ fieldLabelModifier fld, val]) fieldNames . valuesExp      -- Map representation:     -- mapE = fromList pairs     -- in terms of Haskell.-    mapE :: Exp-    mapE = AppE (VarE 'fromList) (ListE pairs)+    mapE :: [Name] -> Exp+    mapE vars = AppE (VarE 'fromList) (ListE $ pairs vars)      -- A bit of crutches.     -- The difference between Node and URelationship is in the number of labels they hold.@@ -235,20 +231,14 @@     -- In terms of Haskell:     -- dataCons (fromIntegral dummyId) (fieldFun label) mapE     -- Constructs data with three fields.-    result :: Exp-    result = AppE (AppE (AppE (ConE dataCons) (LitE . IntegerL . fromIntegral $ dummyId)) (fieldFun $ strToTextE label)) mapE+    result :: [Name] -> Exp+    result = AppE (AppE (AppE (ConE dataCons) (LitE . IntegerL . fromIntegral $ dummyId)) (fieldFun $ strToTextE label)) . mapE   -- | Describes the body of conversion from target type function. ---makeFromClause :: String -> Name -> Name -> [Name] -> (String -> String) -> Q Clause-makeFromClause label conName varName dataFields fieldLabelModifier = do--  -- Obtain all data field types.-  -- 'reify' returns 'Q Info', and we are interested in its 'VarI' constructur which provides information about variable: name and type.-  -- To obtain field type, one should get the second field record of VarI.-  fieldTypes <- mapM (reify >=> extractVarType) dataFields-+makeFromClause :: String -> Name -> Name -> [Name] -> [Type] -> (String -> String) -> Q Clause+makeFromClause label conName varName dataFields fieldTypes fieldLabelModifier = do   -- Contains 'True' in each position where 'Maybe a' type occured and 'False' everywhere else.   let maybeFields = fmap isMaybe fieldTypes @@ -288,18 +278,14 @@    -- Kind of this function realization in terms of Haskell:   -- fromNode :: Node -> a-  -- fromNode varName | checkLabels varName [dataLabel] && checkProps varName fieldNames = ConName { foo = bar, baz = quux ...}+  -- fromNode varName | checkLabels varName [dataLabel] && checkProps varName fieldNames = ConName (getProp varName "fieldName1") (getProp varName "fieldName2") ...   --                  | otherwise = unpackError varName (unpack dataLabel)-  let successExp = RecConE conName (zipWith (\f fldName -> (fldName, AppE (AppE (VarE 'getProp) (VarE varName)) f)) maybeNamesE dataFields)+  let successExp = foldl (\a f -> AppE a $ AppE (AppE (VarE 'getProp) (VarE varName)) f) (ConE conName) maybeNamesE   let successCase = (guardSuccess, successExp)   let failCase = (guardFail, failExp)    pure $ Clause [VarP varName] (GuardedB [successCase, failCase]) [] --extractVarType :: Info -> Q Type-extractVarType (VarI _ fieldType _) = pure fieldType-extractVarType _                    = error ($currentLoc ++ "this can not happen.")  -- | Check whether given type is '_ -> Maybe _' -- It pattern matches arrow type applied to any argument ant 'T _' and checks if T is ''Maybe