Shell.lhs

> module Main where

> import IO
> import Database.HaskellDB hiding (describe, (!))
> import Database.HaskellDB.HDBC.ODBC
> import Database.HaskellDB.DBSpec.DBSpecToDBDirect
> import Database.HaskellDB.BoundedList
> import Database.HaskellDB.Query (tableName, attributeName)
> import Database.HaskellDB.DBLayout hiding (fieldName)
> import Database.HaskellDB.PrimQuery
> import Database.HaskellDB.Database hiding (describe)
> import Control.Monad.Trans

> import Database.HaskellDB.DBSpec.PPHelpers
>   (MakeIdentifiers, moduleName, toType, identifier, checkChars,
>    ppComment, newline, mkIdentCamelCase, )
> import qualified Database.HaskellDB.DBSpec.PPHelpers as PP
> import Data.Char (toLower, )
> import Text.PrettyPrint.HughesPJ
> import System.Directory
> import Data.List (isPrefixOf, (!!))
> import Control.Monad (unless)
> import System.Environment

> lcase :: String -> String
> lcase = map toLower

> imports :: Doc
> imports = text "import Frame"

> header :: Doc
> header = ppComment ["Generated by Frame"]

Main doc

> mainImports :: String -> Doc
> mainImports m = text "import" <+> text (m ++ ".Router") $$
>                 text "import" <+> text (m ++ ".Config") $$
>                 text "import" <+> text (m ++ ".Validation") <> newline $$
>                 text "import Frame" $$
>                 text "import Frame.Router"

> genMain :: String -- ^ Top-level module name
>	-> Doc -- ^ list of module name, module contents pairs
> genMain m
>     = header
>       $$ text "module Main where"
>       <> newline
>       $$ imports $$ mainImports m
>       <> newline
>       $$ text "test :: IO ()"
>       $$ text "test = testServer (withSession $ flash . router) config validations"
>       <> newline
>       $$ text "main :: IO ()"
>       $$ text "main = server (withSession $ flash . router) config validations"

Config docs

> configImports :: String -> Doc
> configImports m = text "import Frame.Config" <> newline $$
>                   text "import" <+> text (m ++ ".DB")

> genConfig :: String -- ^ Top-level module name
>   -> String -- ^ Database URL
>   -> String -- ^ Database name
>   -> String -- ^ Current path
>	-> Doc -- ^ list of module name, module contents pairs
> genConfig m du dn cp
>     = header
>       $$ text "module" <+> text (m ++ ".Config") <+> text "where"
>       <> newline
>       $$ imports $$ configImports m
>       <> newline
>       $$ text "config = Config {database=" <> text dn <>
>          text ", dbURL=" <> doubleQuotes (text du) <>
>          text ", dbName=" <> doubleQuotes (text dn) <>
>          text ", sessionPath=\"" <> text (cp ++ "/Sessions/") <> text "\", sessionId=\"\", css=[]}"
>       <> newline
>       $$ text "production = config"

Validation docs

> validationImports :: String -> [String] -> Doc
> validationImports m [] = text "import Data.Map (fromList)" <> newline
> validationImports m (r:rs) = validationImports m rs $$
>                              text "import" <+> text (m ++ ".DB." ++ r)

> genValidation :: String -- ^ Top-level module name
>   -> [String]
>	-> Doc -- ^ list of module name, module contents pairs
> genValidation m rs
>     = header
>       $$ text "module" <+> text (m ++ ".Validation") <+> text "where"
>       <> newline
>       $$ imports $$ validationImports m rs
>       <> newline
>       $$ text "validations :: Validators"
>       $$ text "validations = fromList []"


Router docs

> routerImports :: String -> [String] -> Doc
> routerImports m [] = text "import Frame.Router" $$
>                      text "import Frame.Model" $$
>                      text "import Frame.View" <> newline
> routerImports m (r:rs) = routerImports m rs $$
>                          text "import qualified" <+> text (m ++ ".Router." ++ r) <+> text "as" <+> text r

> routerRoutePattern :: [String] -> Doc
> routerRoutePattern [] = empty
> routerRoutePattern (p:ps) = doubleQuotes (text $ lcase p) <> text ":" <> routerRoutePattern ps

> routerRoutes :: [String] -> Doc
> routerRoutes [] = text "router _ = return Error404"
> routerRoutes (ps:rs) = text "router " <> 
>                        parens (routerRoutePattern [ps] <> text "ps") <> 
>                        text " = " <> text ps <> text "." <> text "index" $$ 
>                        routerRoutes rs

> genRouter :: String -- ^ Top-level module name
>   -> [String]
>	-> Doc -- ^ list of module name, module contents pairs
> genRouter m rs
>     = header
>       $$ text "module" <+> text (m ++ ".Router") <+> text "where"
>       <> newline
>       $$ imports $$ routerImports m rs
>       <> newline
>       $$ text "router :: FrameRouter m => [String] -> m Data"
>       $$ text "router " <> text "[]" <> 
>            text " = return $ ViewPart [paragraph $ text" <+> doubleQuotes (text "Generated index") <> text "]"
>       $$ routerRoutes rs

Sub-router docs

> subRouterImports :: String -> String -> Doc
> subRouterImports m n = text "import Frame.Router" $$
>                    text "import Frame.View" $$
>                    text "import Frame.Model" <> newline $$
>                    text "import " <> text m <> text ".Model." <> text n $$
>                    text "import " <> text m <> text ".View." <> text n

> genSubRouter :: String -- ^ Top-level module name
>   -> String -- ^ View name
>	-> Doc -- ^ list of module name, module contents pairs
> genSubRouter m n
>     = header
>       $$ text "module" <+> text (m ++ ".Router." ++ n) <+> text "where"
>       <> newline
>       $$ imports $$ subRouterImports m n
>       <> newline
>       $$ text "index :: FrameRouter m => m Data"
>       $$ text "index = return $ ViewPart [paragraph $ text" <+> doubleQuotes (text "Generated index for" <+> text n) <> text "]"

Model docs

> modelImports :: Doc
> modelImports = text "import Frame.Model"

> genModel :: String -- ^ Top-level module name
>   -> String
>	-> Doc -- ^ list of module name, module contents pairs
> genModel m n
>     = header
>       $$ text "module" <+> text (m ++ ".Model." ++ n) <+> text "where"
>       <> newline
>       $$ imports $$ modelImports

View docs

> viewImports :: Doc
> viewImports = text "import Frame.View"

> genView :: String -- ^ Top-level module name
>   -> String
>	-> Doc -- ^ list of module name, module contents pairs
> genView m n
>     = header
>       $$ text "module" <+> text (m ++ ".View." ++ n) <+> text "where"
>       <> newline
>       $$ imports $$ viewImports


> withODBC :: MonadIO m => String -> (Database -> m a) -> m a
> withODBC u = (connect driver) [("DSN", u)]

> -- | Automatically creates the database modules from a db description
> genDB :: String -- ^ The name of the application e.g. ''MyApp''
>          -> String -- ^ The DSN url for the database
>          -> String -- ^ The name of the database to be described
>          -> IO DBInfo
> genDB a u n = do
>     s <- withODBC u $ \db -> dbToDBSpec True mkIdentCamelCase n db
>     dbInfoToModuleFiles "" (a ++ ".DB") s
>     return s

> listTables :: [TInfo] -> IO ()
> listTables [] = return ()
> listTables (TInfo{tname=n}:ts) 
>     = do
>          putStr $ " * " ++ n ++ "\n"
>          listTables ts

> findTable :: [TInfo] -> String -> Bool
> findTable [] _ = False
> findTable (TInfo{tname=tn}:ts) n 
>     = if n == tn then True else False

> createModule :: String -> String -> String -> IO ()
> createModule "router" n t = do
>        createPath (n ++ "/Router/")
>        writeFile (n ++ "/Router/" ++ t ++ ".hs") $ show $ genSubRouter n t
>        return ()
> createModule "model" n t = do
>        createPath (n ++ "/Model/")
>        writeFile (n ++ "/Model/" ++ t ++ ".hs") $ show $ genModel n t
>        return ()
> createModule "view" n t = do
>        createPath (n ++ "/View/")
>        writeFile (n ++ "/View/" ++ t ++ ".hs") $ show $ genView n t
>        return ()
> createModule _ _ _ = return ()

> mainCreateFile :: String -> String -> DBInfo -> IO ()
> mainCreateFile mt n db = do
>          case db of 
>             DBInfo{tbls=[]} -> do
>                putStr "Perhaps you need to generate a DB first\n"
>                return ()
>             DBInfo{tbls=ts} -> do
>                putStr $ "Which table would you like to create a " ++ mt ++ " for?\n"
>                listTables ts
>                putStr "\n b) Back\n\n"
>                t <- getLine
>                putStr "\n"
>                case t == "b" || findTable ts t of
>                   True  -> createModule mt n t
>                   False -> do
>                       putStr "Could not find that table\n\n"
>                       mainCreateFile mt n db

> tName :: TInfo -> String
> tName TInfo{tname=n} = n

> appM :: (String -> IO ()) -> [String] -> IO ()
> appM _ []      = return ()
> appM mf (a:as) = do
>     mf a
>     appM mf as
>     return ()

> gen :: String -> String -> String -> IO ()
> gen n du dn = do 
>      db <- genDB n du dn         
>      case db of 
>         DBInfo{tbls=[]} -> do
>            putStr "No tables were found\n"
>            return ()
>         DBInfo{tbls=ts} -> do
>            cd <- getCurrentDirectory
>            createPath (n ++ "/Sessions/")
>            writeFile (n ++ "/Config.hs") $ show $ genConfig n du dn $ cd ++ "/" ++ n
>            writeFile (n ++ "/Validation.hs") $ show $ genValidation n $ map tName ts
>            appM (createModule "model" n) $ map tName ts
>            appM (createModule "view" n) $ map tName ts
>            appM (createModule "router" n) $ map tName ts
>            writeFile (n ++ "/Router.hs") $ show $ genRouter n $ map tName ts
>            writeFile (n ++ "/Main.hs") $ show $ genMain n
>      return ()

> helpText :: String
> helpText = "Usage: frame-gen APPNAME DBURL DBNAME\n"

> main :: IO ()
> main = do
>   as <- getArgs
>   case length as == 3 of
>      True -> gen (as!!0) (as!!1) (as!!2)
>      False -> do 
>                  putStr helpText
>                  return ()

> -- From DBSpecToDBDirect
> createPath :: FilePath -> IO ()
> createPath p | "/" `isPrefixOf` p = createPath' "/" (dropWhile (=='/') p)
>              | otherwise          = createPath' "" p
>    where
>    createPath' _ "" = return ()
>    createPath' b p = do
>		      let (d,r) = break (=='/') p
>			  n = withPrefix b d
>		      createDirIfNotExists n
>		      createPath' n (dropWhile (=='/') r)

> createDirIfNotExists :: FilePath -> IO ()
> createDirIfNotExists p = do
> 			 exists <- doesDirectoryExist p
> 			 unless exists (createDirectory p)


> withPrefix :: FilePath -> String -> FilePath
> withPrefix base f | null base = f
>                   | otherwise = base ++ "/" ++ f