diff --git a/Generator.hs b/Generator.hs --- a/Generator.hs +++ b/Generator.hs @@ -3,8 +3,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module Generator (generate, hsRouteName) where - +import Prelude hiding (readFile) import System.IO (FilePath, writeFile) +import System.IO.Strict (readFile) import System.FilePath (joinPath) import System.Directory (createDirectoryIfMissing) import Data.String.Utils (rstrip) @@ -13,6 +14,7 @@ import qualified Data.Text as T import Data.List import Data.Maybe +import Control.Monad import Data.Char import Generator.Models @@ -20,23 +22,42 @@ import Generator.Routes import Generator.Validation import Generator.Handlers +import Generator.EsqueletoInstances +import Generator.Cabal +import SyncFile -generate :: Module -> IO () -generate m = do +writeRoute :: Module -> Route -> IO () +writeRoute m r = syncFile (joinPath ["Handler", moduleName m, + routeModuleName r ++ ".hs"]) $ + T.unpack $(codegenFile "codegen/route-header.cg") + ++ (concatMap (handler m r) (routeHandlers r)) + + + +generate :: FilePath -> Module -> IO () +generate path m = do + syncCabal path m createDirectoryIfMissing True (joinPath ["Handler", moduleName m]) - writeFile (joinPath ["Handler", moduleName m, "Enums.hs"]) $ + syncFile (joinPath ["Handler", moduleName m, "Enums.hs"]) $ T.unpack $(codegenFile "codegen/enums-header.cg") ++ (concatMap enum $ modEnums m) - writeFile (joinPath ["Handler", moduleName m, "Internal.hs"]) $ + syncFile (joinPath ["Handler", moduleName m, "Esqueleto.hs"]) $ + T.unpack $(codegenFile "codegen/esqueleto-header.cg") + ++ (esqueletoInstances m) + syncFile (joinPath ["Handler", moduleName m, "Internal.hs"]) $ T.unpack $(codegenFile "codegen/header.cg") ++ models m ++ classes m ++ validation m - ++ (T.unpack $(codegenFile "codegen/json-wrapper.cg")) - ++ (concat [ handler m r h | r <- modRoutes m, h <- routeHandlers r ]) - ++ routes m - writeFile (joinPath ["Handler", moduleName m ++ ".hs"]) $ + ++ (T.unpack $(codegenFile "codegen/json-wrapper.cg")) + forM_ (modRoutes m) (writeRoute m) + syncFile (joinPath ["Handler", moduleName m, "Routes.hs"]) $ + routes m + syncFile (joinPath ["Handler", moduleName m ++ ".hs"]) $ T.unpack $(codegenFile "codegen/dispatch.cg") + where + routeImport r = T.unpack $(codegenFile "codegen/route-import.cg") + diff --git a/Generator/Routes.hs b/Generator/Routes.hs --- a/Generator/Routes.hs +++ b/Generator/Routes.hs @@ -8,6 +8,10 @@ import Data.List import Text.Shakespeare.Text hiding (toText) import Data.Char +routeModuleName :: Route -> String +routeModuleName r = "Route" ++ (concat $ map f (routePath r)) + where f (PathText s) = upperFirst s + f (PathId en) = upperFirst en hsRouteName :: [PathPiece] -> String hsRouteName = f . routeName where f ('/':'#':xs) = f xs @@ -28,5 +32,8 @@ routes m = T.unpack $(codegenFile "codegen/routes-header.cg") ++ (concatMap hsRoutePath (modRoutes m)) ++ (T.unpack $(codegenFile "codegen/routes-footer.cg")) + where + routeImport r = T.unpack $(codegenFile "codegen/route-import.cg") + diff --git a/codegen/dispatch.cg b/codegen/dispatch.cg --- a/codegen/dispatch.cg +++ b/codegen/dispatch.cg @@ -10,9 +10,11 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.~{moduleName m} - ( module Handler.~{moduleName m}.Enums, module Handler.~{moduleName m}.Internal ) where + ( module Handler.~{moduleName m}.Enums, module Handler.~{moduleName m}.Internal, module Handler.~{moduleName m}.Routes ) where import Handler.~{moduleName m}.Enums import Handler.~{moduleName m}.Internal +~{concatMap routeImport (modRoutes m)} +import Handler.~{moduleName m}.Routes import Yesod.Core import Yesod.Auth import Yesod.Persist diff --git a/codegen/esqueleto-header.cg b/codegen/esqueleto-header.cg new file mode 100644 --- /dev/null +++ b/codegen/esqueleto-header.cg @@ -0,0 +1,45 @@ +{-# LANGUAGE ConstraintKinds + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GADTs + , MultiParamTypeClasses + , OverloadedStrings + , UndecidableInstances + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Handler.~{moduleName m}.Esqueleto where +import Prelude +import Control.Applicative (Applicative(..), (<$>), (<$)) +import Control.Arrow ((***), first) +import Control.Exception (throw, throwIO) +import Control.Monad ((>=>), ap, void, MonadPlus(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Logger (MonadLogger) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Resource (MonadResourceBase) +import Data.Int (Int64) +import Data.List (intersperse) +import Data.Monoid (Monoid(..), (<>)) +import Data.Proxy (Proxy(..)) +import qualified Control.Monad.Trans.Reader as R +import qualified Control.Monad.Trans.State as S +import qualified Control.Monad.Trans.Writer as W +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL +import qualified Data.HashSet as HS +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Lazy.Builder.Int as TLBI + +import Database.Esqueleto.Internal.Language +import Database.Esqueleto.Internal.Sql + +uncommas :: [TLB.Builder] -> TLB.Builder +uncommas = mconcat . intersperse ", " . filter (/= mempty) + +uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a) +uncommas' = (uncommas *** mconcat) . unzip + + diff --git a/codegen/header.cg b/codegen/header.cg --- a/codegen/header.cg +++ b/codegen/header.cg @@ -14,6 +14,7 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module Handler.~{moduleName m}.Internal where import Handler.~{moduleName m}.Enums +import Handler.~{moduleName m}.Esqueleto import Prelude import Database.Esqueleto import Database.Esqueleto.Internal.Sql (unsafeSqlBinOp) @@ -51,6 +52,8 @@ import qualified Data.HashMap.Lazy as HML import qualified Data.HashMap.Strict as HMS +data ~{moduleName m} = ~{moduleName m} + data FilterJsonMsg = FilterJsonMsg { filterJsonMsg_type :: Text, filterJsonMsg_value :: Text, @@ -83,7 +86,7 @@ sortJsonMsg_direction :: Text } -$(deriveJSON (drop 12) ''SortJsonMsg) +$(deriveJSON defaultOptions{fieldLabelModifier = drop 12} ''SortJsonMsg) -- defaultFilterOp :: forall v typ. PersistField typ => Text -> EntityField v typ -> typ -> Filter v defaultFilterOp "eq" = (==.) diff --git a/codegen/route-header.cg b/codegen/route-header.cg new file mode 100644 --- /dev/null +++ b/codegen/route-header.cg @@ -0,0 +1,55 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ConstraintKinds #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +module Handler.~{moduleName m}.~{routeModuleName r} where +import Handler.~{moduleName m}.Enums +import Handler.~{moduleName m}.Esqueleto +import Handler.~{moduleName m}.Internal +import Prelude +import Database.Esqueleto +import Database.Esqueleto.Internal.Sql (unsafeSqlBinOp) +import qualified Database.Persist as P +import Database.Persist.TH +import Yesod.Auth (requireAuth, requireAuthId, YesodAuth, AuthId, YesodAuthPersist) +import Yesod.Core +import Yesod.Persist (runDB, YesodPersist, YesodPersistBackend) +import Data.Aeson ((.:), (.:?), (.!=), FromJSON, parseJSON, decode) +import Data.Aeson.TH +import Data.Int +import Data.Word +import Data.Time +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (Typeable) +import qualified Data.Attoparsec as AP +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as AT +import qualified Data.ByteString.Lazy as LBS +import Data.Maybe +import qualified Data.Text.Read +import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.List as DL +import Control.Monad (mzero) +import Control.Monad.Trans.Resource (runResourceT) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Conduit as C +import qualified Network.Wai as W +import Data.Conduit.Lazy (lazyConsume) +import Network.HTTP.Types (status200, status400, status403, status404) +import Blaze.ByteString.Builder.ByteString (fromByteString) +import Control.Applicative ((<$>), (<*>)) +import qualified Data.HashMap.Lazy as HML +import qualified Data.HashMap.Strict as HMS + diff --git a/codegen/route-import.cg b/codegen/route-import.cg new file mode 100644 --- /dev/null +++ b/codegen/route-import.cg @@ -0,0 +1,1 @@ +import Handler.~{moduleName m}.~{routeModuleName r} diff --git a/codegen/routes-header.cg b/codegen/routes-header.cg --- a/codegen/routes-header.cg +++ b/codegen/routes-header.cg @@ -1,5 +1,27 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ConstraintKinds #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +module Handler.~{moduleName m}.Routes where +import Prelude (const) +import Handler.~{moduleName m}.Enums +import Handler.~{moduleName m}.Esqueleto +import Handler.~{moduleName m}.Internal +~{concatMap routeImport (modRoutes m)} +import Yesod.Auth (requireAuth, requireAuthId, YesodAuth, AuthId, YesodAuthPersist) +import Yesod.Core +import Yesod.Persist (runDB, YesodPersist, YesodPersistBackend) -data ~{moduleName m} = ~{moduleName m} get~{moduleName m} :: a -> ~{moduleName m} get~{moduleName m} = const ~{moduleName m} diff --git a/codegen/sqlselect-instance.cg b/codegen/sqlselect-instance.cg new file mode 100644 --- /dev/null +++ b/codegen/sqlselect-instance.cg @@ -0,0 +1,11 @@ +instance ( ~{intercalate ", " (map sqlSelectTypeLhs nums)} ) => SqlSelect (~{intercalate ", " (map ifield nums)}) (~{intercalate ", " (map ofield nums)}) where + sqlSelectCols esc (~{intercalate ", " (map ifield nums)}) = + uncommas' [ ~{intercalate ", " (map sqlSelectCols nums)} ] + sqlSelectColCount = sqlSelectColCount . from~{show fnum}P + sqlSelectProcessRow = fmap to~{show fnum} . sqlSelectProcessRow + +from~{show fnum}P :: Proxy (~{intercalate ", " (map ifield nums)}) -> Proxy (~{pairs (map ifield nums)}) +from~{show fnum}P = const Proxy + +to~{show fnum} :: (~{pairs (map ifield nums)}) -> (~{intercalate ", " (map ifield nums)}) +to~{show fnum} (~{pairs (map ifield nums)}) = (~{intercalate ", " (map ifield nums)}) diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -34,5 +34,5 @@ let ast = implementClasses . mergeModules $ dbs let errors = validate ast if null errors - then generate $ ast + then generate path $ ast else hPutStrLn stderr errors diff --git a/yesod-dsl.cabal b/yesod-dsl.cabal --- a/yesod-dsl.cabal +++ b/yesod-dsl.cabal @@ -1,5 +1,5 @@ name: yesod-dsl -version: 0.1.1.6 +version: 0.1.1.7 license: BSD3 license-file: LICENSE author: Tero Laitinen @@ -26,6 +26,8 @@ , filepath >= 1.3.0.0 , containers >= 0.4.2.1 , mtl >= 2.1.2 + , strict + , Cabal Build-tools: alex, happy other-modules: Lexer Parser AST Generator ClassImplementer ModuleMerger Validation