From c703293b1725c27ac41dec11fc92143c4b4c092a Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Thu, 20 Oct 2022 21:15:55 -0500 Subject: [PATCH 1/2] Fix bug where the name of the table was used in place of the name of the schema in the generated code. Formerly we were producing stuff like this: foo :: TableSchema (Foo Name) foo = TableSchema{name = "foo", schema = Just "foo", columns = Foo{[...]}} Also remove redundant language pragma. --- exe-rel8-import/Main.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/exe-rel8-import/Main.hs b/exe-rel8-import/Main.hs index f1fb0961..7cda85eb 100644 --- a/exe-rel8-import/Main.hs +++ b/exe-rel8-import/Main.hs @@ -4,7 +4,6 @@ {-# language DeriveGeneric #-} {-# language DerivingStrategies #-} {-# language DuplicateRecordFields #-} -{-# language DisambiguateRecordFields #-} {-# language GeneralizedNewtypeDeriving #-} {-# language LambdaCase #-} {-# language NamedFieldPuns #-} @@ -179,11 +178,11 @@ main = do , .. } - putStrLn $ HS.prettyPrint $ tablesToModule tables + putStrLn $ HS.prettyPrint $ tablesToModule schema tables -tablesToModule :: [Table Result] -> HS.Module () -tablesToModule tables = HS.Module () Nothing pragmas imports allTableDecls +tablesToModule :: Text -> [Table Result] -> HS.Module () +tablesToModule nameOfDatabaseSchema tables = HS.Module () Nothing pragmas imports allTableDecls where pragmas = [ deriveGeneric, deriveAnyClass, derivingStrategies, overloadedStrings ] where @@ -270,7 +269,7 @@ tablesToModule tables = HS.Module () Nothing pragmas imports allTableDecls HS.App () (HS.Con () (HS.UnQual () (HS.Ident () "Just"))) $ HS.Lit () $ HS.String () str str where - str = unpack name + str = unpack nameOfDatabaseSchema columnsField = HS.FieldUpdate () columnsName columnsRecord where From 698dab67c6f5371fb782a7eaf8e5db8859cd6eba Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Thu, 20 Oct 2022 21:34:44 -0500 Subject: [PATCH 2/2] Deduplicate two definitions of the column name to field name mapping. A somewhat awkward refactoring. Perhaps not worth it? This avoids a gotcha, where someone tries to modify the rule for mapping column names to field names, and they need to change it in both places. --- exe-rel8-import/Main.hs | 44 +++++++++++++++++++++-------------------- 1 file changed, 23 insertions(+), 21 deletions(-) diff --git a/exe-rel8-import/Main.hs b/exe-rel8-import/Main.hs index 7cda85eb..b32b67e1 100644 --- a/exe-rel8-import/Main.hs +++ b/exe-rel8-import/Main.hs @@ -210,6 +210,27 @@ tablesToModule nameOfDatabaseSchema tables = HS.Module () Nothing pragmas import where pascalName = HS.Ident () $ pascal $ unpack name + field Attribute{ attribute, typ } = (fieldDecl, fieldColumnMapping) + where + fieldDecl = HS.FieldDecl () [fieldName] $ columnF columnType + + fieldColumnMapping = HS.FieldUpdate () (HS.UnQual () fieldName) columnName + + fieldName = HS.Ident () $ camel $ unpack $ attname attribute + + columnType = + HS.TyCon () $ HS.UnQual () $ HS.Ident () $ + maybe (pascal $ unpack $ typname typ) unpack (lookup (typname typ) typeMapping) + + columnF = HS.TyApp () (HS.TyApp () _Column f) + where + _Column = HS.TyCon () $ HS.UnQual () $ HS.Ident () "Column" + f = HS.TyVar () $ HS.Ident () "f" + + columnName = HS.Lit () $ HS.String () str str + where + str = unpack $ attname attribute + rel8able = HS.DataDecl () (HS.DataType ()) Nothing declHead [constructor] [derivingGeneric, derivingRel8able] where declHead = HS.DHApp () tyName f @@ -219,19 +240,7 @@ tablesToModule nameOfDatabaseSchema tables = HS.Module () Nothing pragmas import constructor = HS.QualConDecl () Nothing Nothing conDecl where - conDecl = HS.RecDecl () pascalName $ map field columns - field Attribute{ attribute, typ } = HS.FieldDecl () [fieldName] $ columnF columnType - where - fieldName = HS.Ident () $ camel $ unpack $ attname attribute - - columnType = - HS.TyCon () $ HS.UnQual () $ HS.Ident () $ - maybe (pascal $ unpack $ typname typ) unpack (lookup (typname typ) typeMapping) - - columnF = HS.TyApp () (HS.TyApp () _Column f) - where - _Column = HS.TyCon () $ HS.UnQual () $ HS.Ident () "Column" - f = HS.TyVar () $ HS.Ident () "f" + conDecl = HS.RecDecl () pascalName $ map (fst . field) columns derivingGeneric = HS.Deriving () (Just (HS.DerivStock ())) [rule] where @@ -274,14 +283,7 @@ tablesToModule nameOfDatabaseSchema tables = HS.Module () Nothing pragmas import columnsField = HS.FieldUpdate () columnsName columnsRecord where columnsName = HS.UnQual () (HS.Ident () "columns") - columnsRecord = HS.RecConstr () (HS.UnQual () pascalName) $ map field columns - - field Attribute{ attribute, typ } = HS.FieldUpdate () (HS.UnQual () fieldName) columnName - where - fieldName = HS.Ident () $ camel $ unpack $ attname attribute - columnName = HS.Lit () $ HS.String () str str - where - str = unpack $ attname attribute + columnsRecord = HS.RecConstr () (HS.UnQual () pascalName) $ map (snd . field) columns typeMapping :: [(Text, Text)]