db-pprint.cabal

name:                db-pprint
version:             0.1.0.0
build-type:          Simple
cabal-version:       >=1.10

library
  exposed-modules:     DbCodeGen
  build-depends:       base >=4 && <4.12
                     , lens
  default-language:    Haskell2010

DbCodeGen.hs

{-# LANGUAGE TemplateHaskell, RankNTypes #-}

module DbCodeGen where

import Data.List (intercalate)
import Control.Lens

type Endo a = a -> a
fix :: Endo a -> a
fix f = f (fix f)

st :: Lens' r x -> ASetter (Endo r) (Endo r) x x
st l = setting $ \f g self -> over l f (g self)

st' :: Lens' r x -> ASetter (Endo r) (Endo r) x (r -> x)
st' l = setting $ \f g self -> let o = g self ; f' = flip f o in over l f' o

slift :: ASetter s t a b -> ASetter s (r -> t) a (r -> b)
slift l = setting (\h s r -> over l (\a -> h a r) s)

data Column = Column { _name :: String, _tpe :: String }
data Table = Table { _tName :: String, _tCols :: [Column] }
data Schema = Schema { _sName :: String, _sTbs :: [Table] }
data Database = Database { _dSchms :: [Schema] }

data ColumnCodeGen = ColumnCodeGen { _col :: Column, _colGen :: String }
data CodeGen a c b = CodeGen { _val :: b , _childGen :: a -> c , _gens :: [String] , _gen :: String }
type TableCodeGen = CodeGen Column (Endo ColumnCodeGen) Table
type SchemaCodeGen = CodeGen Table (Endo TableCodeGen) Schema
type DatabaseCodeGen = CodeGen Schema (Endo SchemaCodeGen) Database
fmap concat $ traverse makeLenses [''ColumnCodeGen, ''CodeGen, ''Column, ''Table, ''Schema]

mkColumnCodeGen :: Column -> Endo ColumnCodeGen
mkColumnCodeGen c self = ColumnCodeGen c (_name c ++ ": " ++ _tpe c)

mkTableCodeGen :: Table -> Endo TableCodeGen
mkTableCodeGen t self = CodeGen {
    _val = t , _childGen = mkColumnCodeGen
  , _gens = fmap (_colGen . fix . _childGen self) (_tCols t)
  , _gen = "case class " ++ _tName t ++ " ( " ++ intercalate ", " (_gens self) ++ ")"
  }

mkSchemaCodeGen :: Schema -> Endo SchemaCodeGen
mkSchemaCodeGen s self = CodeGen {
    _val = s , _childGen = mkTableCodeGen
  , _gens = fmap (_gen . fix . _childGen self) (_sTbs s)
  , _gen = "object " ++ _sName s ++ " {\n   " ++ intercalate "\n   " (_gens self) ++ "\n}"
  }

mkDatabaseCodeGen :: Database -> Endo DatabaseCodeGen
mkDatabaseCodeGen d self = CodeGen {
    _val = d , _childGen = mkSchemaCodeGen
  , _gens = fmap (_gen . fix . _childGen self) (_dSchms d)
  , _gen = intercalate "\n" (_gens self)
  }

myDb = Database
  [ Schema "mydb" [
      Table "mytable1" [ Column "col1" "String", Column "col2" "String" ]
    , Table "mytable2" [ Column "col1" "String", Column "col2" "String" ]]]

dbCodeGen = mkDatabaseCodeGen myDb
dbCodeGen2 =
  st childGen . mapped . st' childGen . slift
    (mapped . st' childGen . slift (mapped . st' colGen)) .~ f $ dbCodeGen
  where f s t c = if t^.val.tName == "mytable2"
                  then s^.val.sName ++ "_" ++ c^.col.name ++ ": " ++ c^.col.tpe
                  else c^.colGen

-- >>> putStrLn $ (fix dbCodeGen)^.gen
-- object mydb {
--    case class mytable1 ( col1: String, col2: String)
--    case class mytable2 ( col1: String, col2: String)
-- }
-- >>> putStrLn $ (fix dbCodeGen2)^.gen
-- object mydb {
--    case class mytable1 ( col1: String, col2: String)
--    case class mytable2 ( mydb_col1: String, mydb_col2: String)
-- }