Skip to content

Pr 59 patches #210

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
peterwicksstringfield wants to merge 2 commits into
base: reflect-schema
Choose a base branch
from
Open

Pr 59 patches #210

Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
c703293
Fix bug where the name of the table was used in place of the name of …
peterwicksstringfield Oct 21, 2022
698dab6
Deduplicate two definitions of the column name to field name mapping.
peterwicksstringfield Oct 21, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
53 changes: 27 additions & 26 deletions exe-rel8-import/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,6 @@
{-# language DeriveGeneric #-}
{-# language DerivingStrategies #-}
{-# language DuplicateRecordFields #-}
{-# language DisambiguateRecordFields #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -211,6 +210,27 @@ tablesToModule tables = HS.Module () Nothing pragmas imports allTableDecls
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
Expand All @@ -220,19 +240,7 @@ tablesToModule tables = HS.Module () Nothing pragmas imports allTableDecls

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
Expand Down Expand Up @@ -270,19 +278,12 @@ 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
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)]
Expand Down