packages feed

yesod-dsl (empty) → 0.1

raw patch · 85 files changed

+1109/−0 lines, 85 filesdep +MissingHdep +arraydep +basesetup-changed

Dependencies added: MissingH, array, base, directory, filepath, shakespeare-text, text

Files

+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2012, Tero Laitinen. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Lexer.x view
@@ -0,0 +1,228 @@+{+module Lexer (lexer, tokenType, tokenLineNum, tokenColNum, Token(..), TokenType(..) ) where+}++%wrapper "posn"++$digit = 0-9+$alpha = [a-zA-Z]+$lower = [a-z]+$upper = [A-Z]+@stringWithoutSpecialChars = ($printable # [\" \\])*+@specialChars = [\\]$printable+@string = \" (@stringWithoutSpecialChars | @specialChars)* \"+@fieldName = \' $lower [$alpha $digit \_ ]* \'+@pathParam = \$ ($digit)++@authId = \$ "authId"+@entityId = $upper [$alpha $digit \_]* "Id"+tokens :-+	$white+	;+	"--".*	;+    \n ;+    @string { mkTvar (TString . stripQuotes) }+    \; { mkT TSemicolon } +    \{ { mkT TLBrace }+    \} { mkT TRBrace }+    \( { mkT TLParen }+    \) { mkT TRParen }+    \, { mkT TComma }+    \. { mkT TDot }+    \= { mkT TEquals }+    \!\= { mkT TNe }+    \< { mkT TLt }+    \> { mkT TGt }+    \<\= { mkT TLe }+    \>\= { mkT TGe }+    "like" { mkT TLike }+    "ilike" { mkT TIlike }+    "||" { mkT TConcat }+    \| { mkT TPipe }+    \/ { mkT TSlash }+    \# { mkT THash }+    \* { mkT TAsterisk }+    "get" { mkT TGet }+    "put" { mkT TPut }+    "post" { mkT TPost }+    "delete" { mkT TDelete }+    "import" { mkT TImport }+    "enum" { mkT TEnum }+    "module" { mkT TModule }+    "entity" { mkT TEntity }+    "class" { mkT TClass  }+    "route" { mkT TRoute }+    "unique" { mkT TUnique }+    "check" { mkT TCheck }+    "inner" { mkT TInner }+    "outer" { mkT TOuter }+    "left" { mkT TLeft }+    "right" { mkT TRight }+    "join" { mkT TJoin }+    "full" { mkT TFull }+    "cross" { mkT TCross }+    "on" { mkT TOn }+    "as" { mkT TAs }+    "public" { mkT TPublic }+    "select" { mkT TSelect }+    "update" { mkT TUpdate }+    "insert" { mkT TInsert }+    "from" { mkT TFrom }+    "Word32" { mkT TWord32 }+    "Word64" { mkT TWord64 }+    "Int32" { mkT TInt32 }+    "Int64" { mkT TInt64 }+    "Text" { mkT TText }+    "Bool" { mkT TBool }+    "Double" { mkT TDouble }+    "Maybe" { mkT TMaybe }+    "Day" { mkT TDay }+    "TimeOfDay" { mkT TTimeOfDay }+    "UTCTime" { mkT TUTCTime }+    "ZonedTime" { mkT TZonedTime }+    "default-filter-sort" { mkT TDefaultFilterSort }+    "param" { mkT TParam }+    "if" { mkT TIf }+    "then" { mkT TThen }+    "order" { mkT TOrder }+    "identified" { mkT TIdentified }+    "with" { mkT TWith }+    "by" { mkT TBy }+    "and" { mkT TAnd }+    "or" { mkT TOr }+    "asc" { mkT TAsc }+    "desc" { mkT TDesc }+    "in" { mkT TIn }+    "not" { mkT TNot }+    "limit" { mkT TLimit }+    "offset" { mkT TOffset }+    "where" { mkT TWhere }+    "default" { mkT TDefault }+    "instance" { mkT TInstance }+    "of" { mkT TOf }+    "deriving" { mkT TDeriving }+    $digit+ 		{ mkTvar (TInt . read) }+    $digit+ "." $digit+ { mkTvar (TFloat . read) }+     "id" { mkT TId }+    $lower [$alpha $digit \_ ]*  { mkTvar TLowerId  }+    @entityId { mkTvar (TEntityId . (reverse . (drop 2) . reverse)) }+    $upper [$alpha $digit \_ ]*  { mkTvar TUpperId  }+    @fieldName { mkTvar (TLowerId . stripQuotes) }+    @pathParam { mkTvar (TPathParam . (read . (drop 1))) }+    @authId { mkT TAuthId }+     "$$"  { mkT TLocalParam }++{++data Token = Tk AlexPosn TokenType deriving (Show)+data TokenType = TSemicolon+           | TLBrace+           | TRBrace+           | TLParen+           | TRParen+           | TEquals+           | TNe +           | TLt+           | TGt+           | TLe+           | TGe+           | TLike+           | TIlike+           | TPipe+           | TComma+           | TDot+           | TImport+           | TEnum+           | TModule+           | TEntity+           | TUnique+           | TClass+           | TRoute+           | THash+           | TIn+           | TLimit +           | TOffset+           | TString  String+           | TLowerId String+           | TUpperId String+           | TInt     Int+           | TFloat   Double+           | TConcat+           | TSlash+           | TOrder+           | TIdentified +           | TUpdate+           | TInsert+           | TWith +           | TBy+           | TAsc+           | TDesc+           | TCheck+           | TWord32+           | TWord64+           | TInt32+           | TInt64+           | TText+           | TBool+           | TDouble+           | TMaybe+           | TTimeOfDay+           | TDay+           | TUTCTime+           | TZonedTime+           | TJoin+           | TLeft+           | TRight+           | TInner+           | TOuter+           | TFull+           | TCross+           | TOn+           | TGet+           | TPut+           | TPost+           | TInstance+           | TOf+           | TDelete+           | TPublic+           | TSelect+           | TFrom+           | TAnd+           | TOr+           | TBeforeHandler+           | TAfterHandler+           | TDefaultFilterSort+           | TId+           | TNot+           | TIf+           | TThen+           | TAsterisk+           | TParam+           | TWhere+           | TAs+           | TDeriving+           | TDefault+           | TPathParam Int+           | TAuthId +           | TEntityId String+           | TLocalParam+    deriving (Show)++stripQuotes s = take ((length s) -2) (tail s)++mkT :: TokenType -> AlexPosn -> String -> Token+mkT t p s = Tk p t++mkTvar :: (String -> TokenType) -> AlexPosn -> String -> Token+mkTvar st p s = Tk p (st s)++tokenLineNum (Tk p _) = getLineNum p+tokenColNum (Tk p _)  = getColNum p+tokenType (Tk _ t) = t++getLineNum :: AlexPosn -> Int+getLineNum (AlexPn offset lineNum colNum) = lineNum++getColNum :: AlexPosn -> Int+getColNum (AlexPn offset lineNum colNum) = colNum++lexer = alexScanTokens +}
+ Parser.y view
@@ -0,0 +1,361 @@+{+module Parser (parse) where+import Lexer+import AST+import ModuleMerger+import System.IO+import Data.Maybe+import Data.Typeable+import Prelude hiding (catch) +import Control.Exception hiding (Handler)+import System.Exit++}++%name moduleDefs+%tokentype { Token }+%error { parseError }++%token+    module { Tk _ TModule }+    import     { Tk _ TImport }+    enum       { Tk _ TEnum }+    pipe       { Tk _ TPipe }+    entity   { Tk _ TEntity }+    class      { Tk _ TClass }+    route    { Tk _ TRoute }+    unique     { Tk _ TUnique }+    check      { Tk _ TCheck }+    lowerId    { Tk _ (TLowerId $$) }+    upperId    { Tk _ (TUpperId $$)  }+    intval        { Tk _ (TInt $$)  }+    floatval      { Tk _ (TFloat $$) }+    semicolon  { Tk _ TSemicolon }+    hash        { Tk _ THash }+    equals { Tk _ TEquals }+    concat { Tk _ TConcat }+    ne { Tk _ TNe }+    lt { Tk _ TLt }+    gt { Tk _ TGt }+    le { Tk _ TLe }+    ge { Tk _ TGe }+    and { Tk _ TAnd }+    or { Tk _ TOr }+    like  { Tk _ TLike }+    ilike { Tk _ TIlike }+    lbrace { Tk _ TLBrace }+    rbrace { Tk _ TRBrace }+    lparen { Tk _ TLParen }+    rparen { Tk _ TRParen }+    comma  { Tk _ TComma }+    dot  { Tk _ TDot }+    slash { Tk _ TSlash }+    stringval     { Tk _ (TString $$) }+    word32   { Tk _ TWord32 }+    word64   { Tk _ TWord64 }+    int32    { Tk _ TInt32 }+    int64    { Tk _ TInt64 }+    text { Tk _ TText }+    bool { Tk _ TBool }+    double { Tk _ TDouble }+    timeofday { Tk _ TTimeOfDay }+    day { Tk _ TDay }+    utctime { Tk _ TUTCTime }+    zonedtime { Tk _ TZonedTime }+    maybe { Tk _ TMaybe }+    get { Tk _ TGet }+    param { Tk _ TParam }+    not { Tk _ TNot }+    if {  Tk _ TIf }+    then { Tk _ TThen }+    asterisk { Tk _ TAsterisk }+    put { Tk _ TPut }+    post { Tk _ TPost }+    delete { Tk _ TDelete }+    public { Tk _ TPublic }+    instance { Tk _ TInstance }+    of { Tk _ TOf }+    in { Tk _ TIn }+    limit { Tk _ TLimit }+    offset { Tk _ TOffset } +    select { Tk _ TSelect }+    from { Tk _ TFrom }+    join { Tk _ TJoin }+    inner { Tk _ TInner }+    outer { Tk _ TOuter }+    left { Tk _ TLeft }+    right { Tk _ TRight }+    full { Tk _ TFull }+    cross { Tk _ TCross }+    on { Tk _ TOn }+    as { Tk _ TAs }+    insert { Tk _ TInsert }+    update { Tk _ TUpdate }+    defaultfiltersort { Tk _ TDefaultFilterSort }+    identified { Tk _ TIdentified }+    with { Tk _ TWith }+    order { Tk _ TOrder }+    by { Tk _ TBy }+    asc { Tk _ TAsc }+    desc { Tk _ TDesc }+    where { Tk _ TWhere }+    deriving { Tk _ TDeriving }+    default  { Tk _ TDefault }+    pathParam { Tk _ (TPathParam $$) }+    authId { Tk _ TAuthId }+    idField { Tk _ TId }+    entityId { Tk _ (TEntityId $$) }+    localParam { Tk _ TLocalParam }+%%++dbModule : maybeModuleName +           imports defs { Module $1 (reverse $2) ((reverse . getEntities) $3) +                                    ((reverse . getClasses) $3)+                                    ((reverse . getEnums) $3)+                                    ((reverse . getRoutes) $3)}+++maybeModuleName : { Nothing }+                | module upperId semicolon { Just $2 }+imports : { [] }+        | imports importStmt { $2 : $1 }++importStmt : import stringval semicolon { $2 }+defs : { [] }+       | defs def  { $2 : $1 }+def : routeDef     { RouteDef $1 }+      | entityDef      { EntityDef $1 } +      | classDef      { ClassDef $1 }+      | enumDef       { EnumDef $1 }++enumDef : enum upperId equals enumValues semicolon +         { EnumType (mkLoc $1) $2 $4 }++enumValues : upperId { [$1] }+           | enumValues pipe upperId { $3 : $1 }+    +entityDef : entity upperId lbrace +            maybeInstances+            fields+            uniques+            maybeDeriving+            checks+            rbrace { Entity (mkLoc $1) $2 (reverse $4) (reverse $5)+                            (reverse $6) (reverse $7) (reverse $8) }++routeDef : route pathPieces lbrace handlers rbrace { Route (mkLoc $1) (reverse $2) (reverse $4) }+pathPieces : slash pathPiece { [$2] }+           | pathPieces slash pathPiece { $3 : $1 }++pathPiece : lowerId { PathText $1 } +          | hash entityId { PathId $2 }++handlers : handlerdef  { [$1] }+         | handlers handlerdef { $2 : $1 }++handlerdef : get handlerParamsBlock { Handler (mkLoc $1) GetHandler $2 }+           | put handlerParamsBlock { Handler (mkLoc $1) PutHandler $2 }+           | post handlerParamsBlock { Handler (mkLoc $1) PostHandler $2 }+           | delete handlerParamsBlock { Handler (mkLoc $1) DeleteHandler $2 }++fieldRef : lowerId dot idField { FieldRefId $1 }+          | lowerId dot lowerId { FieldRefNormal $1 $3 } +          | pathParam { FieldRefPathParam $1 }+          | authId { FieldRefAuthId }+          | localParam { FieldRefLocalParam }+    +handlerParamsBlock : lbrace handlerParams rbrace { (reverse $2) }++handlerParams : { [] }+              | handlerParams handlerParam semicolon { $2 : $1 }+handlerParam : public { Public }+             | select selectFields from upperId as lowerId +               joins maybeWhere maybeOrder maybeLimitOffset +              { Select (SelectQuery $2 ($4,$6) (reverse $7) $8 $9 $10) }+             | update upperId identified by inputRef with inputJson { Update $2 $5 (Just $7) } +             | delete from upperId as lowerId { DeleteFrom $3 $5 Nothing }+             | delete from upperId as lowerId where expr { DeleteFrom $3 $5 (Just $7) }+             | update upperId identified by inputRef { Update $2 $5 Nothing }+             | insert upperId from inputJson { Insert $2 (Just $4) }+             | insert upperId { Insert $2 Nothing }+             | defaultfiltersort { DefaultFilterSort }+             | if param stringval equals localParam then joins where expr { IfFilter ($3 ,(reverse $7) ,$9) }+selectFields: selectField moreSelectFields { $1 : (reverse $2) }++moreSelectFields: { [] }+                | moreSelectFields comma selectField { $3 : $1 }++selectField: lowerId dot asterisk { SelectAllFields $1 }                    +           | lowerId dot idField maybeSelectAlias { SelectIdField $1 $4 }+           | lowerId dot lowerId maybeSelectAlias { SelectField $1 $3 $4 }+       +maybeSelectAlias: { Nothing }+                | as lowerId { Just $2 }+joins : { [] }+      | joins jointype upperId as lowerId maybeJoinOn { (Join $2 $3 $5 $6):$1 }++maybeWhere : { Nothing }+           | where expr { Just $2 }++maybeOrder: { [] }+          | order by orderByList { (reverse $3) }++maybeLimitOffset: { (10000,0) }+                | limit intval maybeOffset {  ($2,$3) }+maybeOffset: { 0 }+           | offset intval { $2 }++orderByList : orderByListitem { [$1] }+        | orderByList comma orderByListitem { $3 : $1 }+orderByListitem : fieldRef orderByDir { ($1, $2) }++orderByDir : asc { SortAsc }+        | desc  { SortDesc }+ +inputJson:  lbrace inputJsonFields rbrace { $2 }+inputJsonField : lowerId equals inputRef { ($1, $3) }++inputRef: lowerId { InputFieldNormal $1 }+        | pathParam { InputFieldPathParam $1 }+        | authId { InputFieldAuthId }+        | value { InputFieldConst $1 }++inputJsonFields : inputJsonField { [$1] }+           | inputJsonFields comma inputJsonField  { $3:$1 }+            +binop : equals { Eq }+      | ne { Ne }+      | lt { Lt }+      | gt { Gt }+      | le { Le }+      | ge { Ge }+      | like { Like }+      | ilike { Ilike }+      ++expr : lparen expr rparen and lparen expr rparen { AndExpr $2 $6 }+     | lparen expr rparen or lparen expr rparen { OrExpr $2 $6 }+     | not expr { NotExpr $2 }+     | lparen expr rparen { $2 } +     | valexpr binop valexpr { BinOpExpr $1 $2 $3 }+     | fieldRef listOp fieldRef { ListOpExpr $1 $2 $3 }+listOp: in { In }+      | not in { NotIn }++valexpr : value { ConstExpr $1 }+        | fieldRef { FieldExpr $1 }+        | valexpr concat valexpr { ConcatExpr $1 $3 }++maybeJoinOn : { Nothing }+            | on expr { Just $2 }+            +jointype : inner join { InnerJoin }+         | cross join { CrossJoin } +         | left outer join { LeftOuterJoin }+         | right outer join { RightOuterJoin }+         | full outer join { FullOuterJoin }+         +             +maybeInstances : { [] }+               | instance of instances semicolon { (reverse $3) }++instances : upperId { [$1] }+            | instances comma upperId { $3 : $1 }++classDef : class upperId lbrace+             fields+            uniques+            rbrace { Class (mkLoc $1) $2 (reverse $4) (reverse $5)  }++fields : { [] }+              | fields field semicolon { $2 : $1 }+ +field : lowerId maybeMaybe fieldType fieldOptions { Field $2 $1 (NormalField $3 (reverse $4)) } +      | lowerId maybeMaybe entityId { Field $2 $1 (EntityField $3) }+      | lowerId maybeMaybe upperId { Field $2 $1 (EnumField $3) }++fieldOptions : { [] }+             | fieldOptionsList { $1 }+fieldOptionsList : fieldOption { [$1] }+                 | fieldOptionsList  fieldOption { $2 : $1 }+fieldOption : check lowerId { FieldCheck $2 }+            | default value { FieldDefault $2 }++value : stringval { StringValue $1 }+      | intval { IntValue $1 }+      | floatval { FloatValue $1 }++      +uniques : { [] }+        | uniques uniqueDef semicolon { $2 : $1 }+uniqueDef :  unique upperId fieldIdList { Unique $2 (reverse $3) }++maybeDeriving : { [] }+             | deriving derives semicolon { (reverse $2) }+derives : upperId { [$1] }+        | derives comma upperId { $3 : $1 }++checks : { [] }+        | check fieldIdList semicolon { reverse $2 }++fieldIdList : lowerId { [$1] }+            | fieldIdList comma lowerId { $3 : $1 }++fieldType : word32 { FTWord32 }+          | word64{ FTWord64 }+          | int32{ FTInt32 }+          | int64{ FTInt64 }+          | text { FTText }+          | bool{ FTBool }+          | double{ FTDouble }+          | timeofday { FTTimeOfDay }+          | day { FTDay }+          | utctime{ FTUTCTime }+          | zonedtime{ FTZonedTime }++maybeMaybe : { False }+              | maybe { True }++{+data ModDef = EntityDef Entity+           | ClassDef Class+           | EnumDef EnumType+           | RouteDef Route+           deriving (Show)++getEntities :: [ModDef] -> [Entity]+getEntities defs = mapMaybe (\d -> case d of (EntityDef e) -> Just e ; _ -> Nothing) defs++getClasses :: [ModDef] -> [Class]+getClasses defs = mapMaybe (\d -> case d of (ClassDef c) -> Just c; _ -> Nothing) defs++getEnums :: [ModDef] -> [EnumType]+getEnums defs = mapMaybe (\d -> case d of (EnumDef e) -> Just e; _ -> Nothing) defs++getRoutes :: [ModDef] -> [Route]+getRoutes defs = mapMaybe (\d -> case d of (RouteDef e) -> Just e; _ -> Nothing) defs++++data ParseError = ParseError String deriving (Show, Typeable)+instance Exception ParseError++parseError :: [Token] -> a+parseError (t:ts) = throw (ParseError $ "Parse error : unexpected " ++ show (tokenType t) ++ " at line " ++ show (tokenLineNum t) ++ " col " ++ show (tokenColNum t))+parseError _ = throw (ParseError $ "Parse error : unexpected end of file")++parseModules :: [FilePath] -> [FilePath] -> IO [(FilePath,Module)]+parseModules handled (path:paths)+    | path `elem` handled = return []+    | otherwise = do+        s <- readFile path+        let mod = (moduleDefs . lexer) s+        catch (do rest <- parseModules (path:handled) (paths ++ modImports mod)+                  return ((path,mod):rest))+              (\(ParseError msg) -> do +                    hPutStrLn stderr $ path ++ ": " ++ msg+                    exitWith (ExitFailure 1))+parseModules _ [] = return []++parse path = parseModules [] [path]+}
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ codegen/base-if-filter.cg view
@@ -0,0 +1,5 @@+        case getDefaultFilter filterParam_~{pn} defaultFilterJson "~{pn}" of+            Just localParam -> ~{maybeFrom} +~{indent 8 (concatMap (implicitJoinExpr m ctx) joins)}+                where_ $ ~{hsExpr ctx expr}+            Nothing -> return ()
+ codegen/base-select-query.cg view
@@ -0,0 +1,10 @@+    let baseQuery limitOffsetOrder = from $ \(~{selectVar} ~{concatMap joinDef (sqJoins sq)}) -> do+~{concatMap (mapJoinExpr m ctx) (reverse (sqJoins sq))}        let ~{selectVar}Id' = ~{selectVar} ^. ~{selectEntity}Id+~{maybeWhere}+        _ <- if limitOffsetOrder+            then do +                offset ~{show offset}+                limit ~{show limit}+~{indent 16 $ maybeDefaultSortFields}+~{indent 16 $ maybeDefaultLimitOffset}                 +            else return ()
+ codegen/class-field.cg view
@@ -0,0 +1,1 @@+    ~{classFieldName c f} :: a -> ~{hsFieldType f}
+ codegen/class-header.cg view
@@ -0,0 +1,1 @@+class ~{className c} a where
+ codegen/class-instance-field.cg view
@@ -0,0 +1,1 @@+    ~{classFieldName c f} = ~{entityFieldName e f}
+ codegen/class-instance-header.cg view
@@ -0,0 +1,1 @@+instance ~{className c} ~{entityName e} where
+ codegen/default-filter-field.cg view
@@ -0,0 +1,3 @@+                "~{fieldName f}" -> case (fromPathPiece $ filterJsonMsg_value fjm) of +                    (Just v) -> where_ $ defaultFilterOp (filterJsonMsg_comparison fjm) (~{vn} ^. ~{entityFieldTypeName e f}) (val ~{maybeJust (fieldOptional f) "v"}) +                    _        -> return ()
+ codegen/default-filter-fields.cg view
@@ -0,0 +1,6 @@+        case defaultFilterJson of +            Just xs -> mapM_ (\fjm -> case filterJsonMsg_field fjm of+~{fields}+                _ -> return ()+                ) xs+            Nothing -> return ()
+ codegen/default-filter-sort-param.cg view
@@ -0,0 +1,4 @@+    defaultFilterParam <- lookupGetParam "filter"+    let defaultFilterJson = (maybe Nothing (decode . LBS.fromChunks . (:[]) . encodeUtf8) defaultFilterParam) :: Maybe [FilterJsonMsg]+    defaultSortParam <- lookupGetParam "sort"+    let defaultSortJson = (maybe Nothing (decode . LBS.fromChunks . (:[]) . encodeUtf8) defaultSortParam) :: Maybe [SortJsonMsg]
+ codegen/default-filter.cg view
@@ -0,0 +1,4 @@+do +    f <- lookupGetParam "filter" +    let f' = (maybe Nothing (decode . LBS.fromChunks . (:[]) . encodeUtf8) f) :: Maybe [FilterJsonMsg] +    return $ maybe [] (concatMap toDefaultFilter~{entityName e}) f'
+ codegen/default-offset-limit.cg view
@@ -0,0 +1,6 @@+case defaultOffset of+    Just o -> offset o+    Nothing -> return ()+case defaultLimit of+    Just l -> limit (min 10000 l)+    Nothing -> return ()
+ codegen/default-selectopts.cg view
@@ -0,0 +1,5 @@+do+    s <- lookupGetParam "sort"+    rangeOpts <- getRangeSelectOpts+    let s' = (maybe Nothing (decode . LBS.fromChunks .(:[]) . encodeUtf8) s) :: Maybe [SortJsonMsg]+    return $ maybe [] (mapMaybe toDefaultSort~{entityName e}) s' ++ rangeOpts
+ codegen/default-sort-field.cg view
@@ -0,0 +1,4 @@+"~{pn}" -> case (sortJsonMsg_direction sjm) of +    "ASC"  -> orderBy [ asc (~{vn} ^. ~{entityFieldTypeName e f}) ] +    "DESC" -> orderBy [ desc (~{vn} ^. ~{entityFieldTypeName e f}) ] +    _      -> return ()
+ codegen/default-sort-fields.cg view
@@ -0,0 +1,6 @@+case defaultSortJson of +    Just xs -> mapM_ (\sjm -> case sortJsonMsg_property sjm of+~{indent 12 $ fields}+            _ -> return ()+        ) xs+    Nothing -> orderBy [ ~{intercalate ", " (map (hsOrderBy ctx) $ sqOrderBy sq)} ]
+ codegen/delete-all.cg view
@@ -0,0 +1,1 @@+~{vn} ^. ~{en}Id ==. ~{vn} ^. ~{en}Id
+ codegen/delete-handler-footer.cg view
@@ -0,0 +1,1 @@+    return $ A.Null
+ codegen/delete.cg view
@@ -0,0 +1,1 @@+        delete $ from $ (\~{vn} -> where_ $ ~{maybeExpr})
+ codegen/dispatch.cg view
@@ -0,0 +1,25 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Handler.~{moduleName m} +    ( module Handler.~{moduleName m}.Enums, module Handler.~{moduleName m}.Internal ) where+import Handler.~{moduleName m}.Internal+import Yesod.Core+import Yesod.Auth+import Yesod.Persist+import Database.Esqueleto+import Prelude+type ~{moduleName m}Route = Route ~{moduleName m}+ +instance (YesodAuthPersist master,+          ~{moduleName m}Validation master,+          YesodPersistBackend master ~ SqlPersistT) => YesodSubDispatch ~{moduleName m} (HandlerT master IO) where+    yesodSubDispatch = $(mkYesodSubDispatch resources~{moduleName m})
+ codegen/enum.cg view
@@ -0,0 +1,3 @@+data ~{enumName e} = ~{intercalate " | " (enumValues e)} deriving (Show, Read, Eq)+derivePersistField "~{enumName e}"+deriveJSON id ''~{enumName e}
+ codegen/enums-header.cg view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+module Handler.~{moduleName m}.Enums where+import Database.Persist.TH+import Data.Aeson.TH
+ codegen/get-filter-param.cg view
@@ -0,0 +1,1 @@+    filterParam_~{pn} <- lookupGetParam "~{pn}"
+ codegen/get-handler-limit.cg view
@@ -0,0 +1,1 @@+        limit ~{show limit}
+ codegen/get-handler-offset.cg view
@@ -0,0 +1,1 @@+        offset ~{show offset}
+ codegen/get-handler-order-by.cg view
@@ -0,0 +1,1 @@+        orderBy [~{intercalate ", " (map (hsOrderBy ps) fields)}]
+ codegen/get-handler-return.cg view
@@ -0,0 +1,9 @@+    return $ A.object [+        "totalCount" .= (T.pack $ (\(Database.Esqueleto.Value v) -> show (v::Int)) (head count)),+        "result" .= (toJSON $ map (\row -> case row of+                (~{intercalate ", " resultFields}) -> A.object [+~{rstrip $ indent 20 $ intercalate ",\n" $ map rstrip $ lines mappedResultFields}                                    +                    ]+                _ -> A.object []+            ) results)+       ]
+ codegen/get-handler-select.cg view
@@ -0,0 +1,1 @@+    ~{result} <- lift $ runDB $ select $ from $ \(~{selectFromVariable}~{concatMap getHandlerJoinDef joins}) -> do
+ codegen/handler-header.cg view
@@ -0,0 +1,5 @@+~{hsHandlerMethod ht}~{hsRouteName (routePath r)} :: forall master. (~{moduleName m}Validation master, +    YesodAuthPersist master,+    YesodPersistBackend master ~ SqlPersistT)+    => ~{hsRouteType (routePath r)}HandlerT ~{moduleName m} (HandlerT master IO) A.Value+~{hsHandlerMethod ht}~{hsRouteName (routePath r)} ~{hsRouteParams (routePath r)} = do
+ codegen/handler-requireauth.cg view
@@ -0,0 +1,1 @@+    authId <- lift $ requireAuthId
+ codegen/header.cg view
@@ -0,0 +1,159 @@+{-# 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}.Internal where+import Handler.~{moduleName m}.Enums+import Prelude+import Database.Esqueleto+import Database.Esqueleto.Internal.Sql (unsafeSqlBinOp)+import qualified Database.Persist as P+import Database.Persist.TH+import Yesod.Auth (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.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, status404)+import Blaze.ByteString.Builder.ByteString (fromByteString)+import Control.Applicative ((<$>), (<*>))  +import qualified Data.HashMap.Lazy as HML++data FilterJsonMsg = FilterJsonMsg {+    filterJsonMsg_type :: Text,+    filterJsonMsg_value :: Text,+    filterJsonMsg_field :: Text,+    filterJsonMsg_property :: Text,+    filterJsonMsg_comparison :: Text+} +instance FromJSON FilterJsonMsg where+    parseJSON (A.Object v) = FilterJsonMsg <$>+        v .:? "type" .!= "string" <*> +        v .: "value" <*>+        v .:? "field" .!= "" <*>+        v .:? "property" .!= "" <*>+        v .:? "comparison" .!= "eq"+    parseJSON _ = mzero++data SortJsonMsg = SortJsonMsg {+    sortJsonMsg_property :: Text,+    sortJsonMsg_direction :: Text+}++$(deriveJSON (drop 12) ''SortJsonMsg)++-- defaultFilterOp :: forall v typ. PersistField typ => Text -> EntityField v typ -> typ -> Filter v+defaultFilterOp "eq" = (==.)+defaultFilterOp "neq" = (!=.)+defaultFilterOp "lt" = (<.)+defaultFilterOp "gt" = (>.)+defaultFilterOp "le" = (<=.)+defaultFilterOp "ge" = (>=.)+defaultFilterOp _ = (==.)++ilike = unsafeSqlBinOp " ILIKE "+safeRead :: forall a. Read a => Text -> Maybe a+safeRead s = case (reads $ T.unpack s) of+   [(v,_)] -> Just v+   _ -> Nothing++instance PathPiece Int32 where+    fromPathPiece s = +        case Data.Text.Read.decimal s of+            Right (i, _) -> Just i+            Left _ -> Nothing+    toPathPiece = T.pack . show++instance PathPiece Word32 where+    fromPathPiece s =+        case Data.Text.Read.decimal s of+            Right (i, _) -> Just i+            Left _ -> Nothing++    toPathPiece = T.pack . show++instance PathPiece Word64 where+    fromPathPiece s = +        case Data.Text.Read.decimal s of+            Right (i, _) -> Just i+            Left _ -> Nothing++    toPathPiece = T.pack . show++instance PathPiece Double where+    fromPathPiece s = +        case Data.Text.Read.double s of+            Right (i, _) -> Just i+            Left _ -> Nothing+    toPathPiece = T.pack . show++instance PathPiece Bool where+    fromPathPiece "true" = Just True+    fromPathPiece "false" = Just False+    fromPathPiece "True" = Just True+    fromPathPiece "False" = Just False+    fromPathPiece  _ = Nothing+    toPathPiece = T.pack . show++instance PathPiece TimeOfDay where+    fromPathPiece = safeRead+    toPathPiece = T.pack . show++instance PathPiece UTCTime where+    fromPathPiece = safeRead+    toPathPiece = T.pack . show++instance PathPiece ZonedTime where+    fromPathPiece = safeRead+    toPathPiece = T.pack . show++instance PathPiece a => PathPiece [a] where+    fromPathPiece s = do+        parts <- safeRead s+        values <- mapM fromPathPiece parts+        return values+    toPathPiece values = T.concat [ +            T.pack "[",+            T.intercalate (T.pack ",") (map toPathPiece values),+            T.pack "]" +        ]+            ++getDefaultFilter maybeGetParam defaultFilterJson p = do+    f <- maybe maybeGetParam Just getFilter+    fromPathPiece f+    where +        getFilter = do            +            j <- defaultFilterJson+            v <- DL.find (\fjm -> filterJsonMsg_property fjm == p) j+            return (filterJsonMsg_value v)
+ codegen/if-filter-from.cg view
@@ -0,0 +1,1 @@+from $ \(~{intercalate ", " (map joinAlias joins)}) -> do
+ codegen/input-field-authid.cg view
@@ -0,0 +1,1 @@+authId
+ codegen/input-field-normal.cg view
@@ -0,0 +1,1 @@+(fromPathPiece $ ~{json
+ codegen/input-field-path-param.cg view
@@ -0,0 +1,1 @@+p~{show i}
+ codegen/insert.cg view
@@ -0,0 +1,7 @@+        vErrors <- lift $ validate e~{show pId}+        case vErrors of+            xs@(_:_) -> sendResponseStatus status400 (A.object [ +                        "message" .= ("Entity validation failed" :: Text),+                        "errors" .= toJSON xs +                    ])+            _ -> P.insert (e~{show pId} :: ~{en})
+ codegen/join-def.cg view
@@ -0,0 +1,1 @@+ `~{show jt}` ~{vn}
+ codegen/join-expr.cg view
@@ -0,0 +1,1 @@+        on (~{hsExpr ctx expr})
+ codegen/json-body.cg view
@@ -0,0 +1,9 @@+    yReq <- getRequest+    let wReq = reqWaiRequest yReq+    bss <- liftIO $ runResourceT $ lazyConsume $ W.requestBody wReq+    jsonBody <- case AP.eitherResult $ AP.parse A.json (B.concat bss) of+         Left err -> sendResponseStatus status400 $ A.object [ "message" .= ( "Could not decode JSON object from request body : " ++ err) ]+         Right o -> return o+    jsonBodyObj <- case jsonBody of+        A.Object o -> return o+        v -> sendResponseStatus status400 $ A.object [ "message" .= ("Expected JSON object in the request body, got: " ++ show v) ]
+ codegen/json-wrapper.cg view
@@ -0,0 +1,19 @@+instance ToJSON Day where+    toJSON = toJSON . show++instance FromJSON Day where+    parseJSON x = do+        s <- parseJSON x+        case reads s of+            (d, _):_ -> return d+            [] -> mzero ++instance ToJSON TimeOfDay where+    toJSON = toJSON . show++instance FromJSON TimeOfDay where+    parseJSON x = do+        s <- parseJSON x+        case reads s of+            (d, _):_ -> return d+            [] -> mzero
+ codegen/map-input-field-authid.cg view
@@ -0,0 +1,1 @@+authId
+ codegen/map-input-field-const.cg view
@@ -0,0 +1,1 @@+~{show v}
+ codegen/map-input-field-no-match.cg view
@@ -0,0 +1,1 @@+~{entityFieldName e f} e
+ codegen/map-input-field-normal.cg view
@@ -0,0 +1,1 @@+attr_~{fn}
+ codegen/map-input-field-pathparam.cg view
@@ -0,0 +1,1 @@+p~{show i}
+ codegen/map-input-field.cg view
@@ -0,0 +1,1 @@+        ~{entityFieldName e f} = ~{maybeJust (fieldOptional f) content}
+ codegen/map-result-field.cg view
@@ -0,0 +1,1 @@+"~{fn}" .= toJSON f~{show i}
+ codegen/model-deriving.cg view
@@ -0,0 +1,1 @@+    deriving ~{d}
+ codegen/model-field.cg view
@@ -0,0 +1,1 @@+    ~{fieldName f} ~{persistFieldType f}
+ codegen/model-header.cg view
@@ -0,0 +1,1 @@+~{entityName e} json
+ codegen/model-unique.cg view
@@ -0,0 +1,1 @@+    Unique~{name} ~{intercalate " " fields} !force
+ codegen/models-footer.cg view
@@ -0,0 +1,1 @@+|]
+ codegen/models-header.cg view
@@ -0,0 +1,1 @@+share [mkPersist sqlOnlySettings, mkMigrate "migrate~{moduleName m}" ] [persistLowerCase|
+ codegen/offset-limit-param.cg view
@@ -0,0 +1,4 @@+    defaultOffsetParam <- lookupGetParam "start"+    defaultLimitParam <- lookupGetParam "limit"+    let defaultOffset = (maybe Nothing fromPathPiece defaultOffsetParam) :: Maybe Int64+    let defaultLimit = (maybe Nothing fromPathPiece defaultLimitParam) :: Maybe Int64
+ codegen/offset-limit.cg view
@@ -0,0 +1,2 @@+        offset ~{show offset}+        limit ~{show limit}
+ codegen/prepare-input-field-normal.cg view
@@ -0,0 +1,10 @@+attr_~{fn} <- case HML.lookup "~{fn}" jsonBodyObj of +    Just v -> case A.fromJSON v of+        A.Success v' -> return v'+        A.Error err -> sendResponseStatus status400 $ A.object [+                "message" .= ("Could not parse value of type ~{hsFieldType f} from attribute ~{fn} in the JSON object in request body" :: Text),+                "error" .= err+            ]+    Nothing -> sendResponseStatus status400 $ A.object [+            "message" .= ("Expected attribute ~{fn} in the JSON object in request body" :: Text)+        ]
+ codegen/read-input-object-fields.cg view
@@ -0,0 +1,6 @@+    e~{show pId} <- do+~{indent 8 $ prepareFields e fields}+~{maybeSelectExisting e fields fr}+        return $ ~{entityName e} {+~{indent 16 $ mapFields e fields} +            }
+ codegen/read-input-object-whole.cg view
@@ -0,0 +1,3 @@+    e~{show pId} <- case A.fromJSON jsonBody of+        A.Success e -> return e+        A.Error err -> sendResponseStatus status400 ("Could not decode an entity of type ~{entityName e} from JSON object in the request body : " ++ err )
+ codegen/replace.cg view
@@ -0,0 +1,7 @@+       vErrors <- lift $ validate e~{show pId}+       case vErrors of+            xs@(_:_) -> sendResponseStatus status400 (A.object [ +                        "message" .= ("Entity validation failed" :: Text),+                        "errors" .= toJSON xs +                    ])+            _ -> P.repsert ~{inputFieldRef ctx fr} (e~{show pId} :: ~{en})
+ codegen/return-entity.cg view
@@ -0,0 +1,1 @@+    return $ A.object [ "result" .=  map JSONWrapper result, "totalCount" .= (T.pack $ (\(Database.Esqueleto.Value v) -> show v)  (head count)) ]
+ codegen/return-field.cg view
@@ -0,0 +1,1 @@+                "~{pn}" .= (T.pack $ show ~{pn})
+ codegen/return-fields.cg view
@@ -0,0 +1,6 @@+    return $ object [ +            "result" .= map (\~{intercalate " " params} -> object [+~{intercalate ",\n" fields}+            ]) result,+            "totalCount" .= (T.pack $ (\(Database.Esqueleto.Value v) -> show v) (head (count)))+        ]
+ codegen/route.cg view
@@ -0,0 +1,1 @@+~{routeName (routePath r)}        ~{hsRouteName (routePath r)}      ~{handlers}
+ codegen/routes-footer.cg view
@@ -0,0 +1,2 @@+|]+
+ codegen/routes-header.cg view
@@ -0,0 +1,7 @@++data ~{moduleName m} = ~{moduleName m}++get~{moduleName m} :: a -> ~{moduleName m}+get~{moduleName m} = const ~{moduleName m}++mkYesodSubData "~{moduleName m}" [parseRoutes|
+ codegen/rundb.cg view
@@ -0,0 +1,1 @@+    _ <- lift $ runDB $ do
+ codegen/select-count.cg view
@@ -0,0 +1,5 @@+    count <- lift $ runDB $ select $ do+        baseQuery False+        let countRows' = countRows+        orderBy []+        return $ (countRows' :: SqlExpr (Database.Esqueleto.Value Int))
+ codegen/select-existing.cg view
@@ -0,0 +1,9 @@+        es <- lift $ runDB $ select $ from $ \o -> do+            where_ (o ^. ~{entityName e}Id ==. (val ~{inputFieldRef ctx fr}))+            limit 1+            return o+        e <- case es of+            [(Entity _ e')] -> return e'    +            _ -> sendResponseStatus status404 $ A.object [ +                    "message" .= ("Could not update a non-existing ~{entityName e}" :: Text)+                ]
+ codegen/select-results.cg view
@@ -0,0 +1,1 @@+    results <- lift $ runDB $ select $ baseQuery True
+ codegen/select-return-count.cg view
@@ -0,0 +1,2 @@+        let countRows' = countRows+        return $ (countRows' :: SqlExpr (Database.Esqueleto.Value Int))
+ codegen/select-return-entity.cg view
@@ -0,0 +1,1 @@+        return (~{vn})
+ codegen/select-return-fields.cg view
@@ -0,0 +1,1 @@+        return (~{intercalate ", " (map (hsFieldRef ctx Nothing) fields)})
+ codegen/update-handler-footer.cg view
@@ -0,0 +1,1 @@+    return $ A.Null
+ codegen/validation-entity-footer.cg view
@@ -0,0 +1,2 @@+            ]+        return $ catMaybes results
+ codegen/validation-entity-header.cg view
@@ -0,0 +1,3 @@+instance Validatable ~{entityName e} where+    validate v = do+        results <- sequence [
+ codegen/validation-entity.cg view
@@ -0,0 +1,1 @@+                checkResult "~{entityName e} ~{func}" $ ~{func} v
+ codegen/validation-field.cg view
@@ -0,0 +1,1 @@+                checkResult "~{entityName e}.~{fieldName f} ~{func}" (~{func} $ ~{entityFieldName e f} v)
+ codegen/validation-function-entity.cg view
@@ -0,0 +1,6 @@+    ~{func} :: (P.PersistMonadBackend (b (HandlerT master IO)) ~ P.PersistEntityBackend ~{entityName e}, +                b ~ YesodPersistBackend master,+                P.PersistQuery (b (HandlerT master IO)),+                P.PersistUnique (b (HandlerT master IO)),+                YesodPersist master)+            => ~{entityName e} -> HandlerT master IO Bool
+ codegen/validation-function-field.cg view
@@ -0,0 +1,1 @@+    ~{func} :: (YesodPersist master) => ~{hsFieldType f} -> HandlerT master IO Bool
+ codegen/validation-header.cg view
@@ -0,0 +1,15 @@+checkResult :: forall (m :: * -> *). (Monad m) => Text -> m Bool -> m (Maybe Text)+checkResult msg f = do+   result <- f+   return $ if result then Nothing else (Just msg)++class Validatable a where+    validate :: forall master b. (P.PersistMonadBackend (b (HandlerT master IO)) ~ P.PersistEntityBackend a,+                 b ~ YesodPersistBackend master,+                 P.PersistQuery (b (HandlerT master IO)),+                 P.PersistUnique (b (HandlerT master IO)),+                 YesodPersist master,+                 ~{moduleName m}Validation master) +             => a -> HandlerT master IO [Text]++class Yesod master => ~{moduleName m}Validation master where
+ codegen/where-expr.cg view
@@ -0,0 +1,1 @@+        where_ (~{hsExpr ctx expr})
+ main.hs view
@@ -0,0 +1,38 @@+import Lexer+import Parser+import System.Environment+import System.Console.GetOpt+import ModuleMerger+import Validation+import ClassImplementer+import AST+import Data.List+import Data.Maybe+import Generator+import System.Directory+import Control.Monad+import System.IO++data Flag = Input FilePath ++options :: [OptDescr Flag]+options = [+  ]++header = "Usage: yesod-dsl FILE"+main = do+    args <- getArgs+    case getOpt RequireOrder options args of+        (_,     (path:_), [])     -> main' path+        (_,     _,       msgs)   -> error $ concat msgs ++ usageInfo header options+++    where+                         +        main' path = do+            dbs <- parse path+            let ast  = implementClasses . mergeModules $ dbs+            let errors = validate ast+            if null errors +                then generate $ ast +                else hPutStrLn stderr errors
+ yesod-dsl.cabal view
@@ -0,0 +1,29 @@+name:           yesod-dsl+version:        0.1+license:        BSD3+license-file:   LICENSE+author:         Tero Laitinen +maintainer:     Tero Laitinen+synopsis:       DSL for generating Yesod subsite to manage an RDBMS;+description:    A domain specific language and a code generator desined to create RESTful services for managing an RDBMS with Yesod web framework and Persistent.+category:       Web, Yesod+stability:      Experimental+cabal-version:  >= 1.6+build-type:     Simple+homepage:       https://github.com/tlaitinen/yesod-dsl++extra-source-files:+    codegen/*.cg++executable  yesod-dsl+    main-is: main.hs+    build-depends: base >= 4 && < 5+                 , shakespeare-text >= 1.0  && < 1.1+                 , text >= 0.11+                 , directory >= 1.1.0.2+                 , array >= 0.4.0.0+                 , MissingH >= 1.2.0.0+                 , filepath >= 1.3.0.0+    Build-tools:         alex, happy+    other-modules: Lexer Parser +    ghc-options: -Wall