diff --git a/AST.hs b/AST.hs --- a/AST.hs +++ b/AST.hs @@ -117,9 +117,9 @@ sqAliases :: SelectQuery -> [(EntityName, VariableName)] sqAliases sq = sqFrom sq : [ (joinEntity j, joinAlias j) | j <- sqJoins sq] -data SelectField = SelectAllFields EntityName - | SelectField EntityName FieldName (Maybe VariableName) - | SelectIdField EntityName (Maybe VariableName) +data SelectField = SelectAllFields VariableName + | SelectField VariableName FieldName (Maybe VariableName) + | SelectIdField VariableName (Maybe VariableName) deriving (Show, Eq) diff --git a/ClassImplementer.hs b/ClassImplementer.hs --- a/ClassImplementer.hs +++ b/ClassImplementer.hs @@ -26,7 +26,7 @@ fieldName = lowerFirst (entityName re) ++ upperFirst (fieldName f), fieldContent = EntityField (entityName re) } - +expandClassField _ _ _ = [] expandClassRefFields :: Module -> Entity -> Field -> [Field] expandClassRefFields m e f = expand (fieldContent f) @@ -40,7 +40,7 @@ entityError e msg = error $ msg ++ " (" ++ entityName e ++ " in " ++ (show $ entityLoc e) ++ ")" implInEntity :: Module -> [Class] -> Entity -> Entity -implInEntity m classes e +implInEntity m classes' e | null invalidClassNames = e { entityFields = concatMap (expandClassRefFields m e) $ entityFields e ++ extraFields, entityUniques = entityUniques e ++ (map (addEntityNameToUnique e) $ concatMap classUniques validClasses), @@ -49,6 +49,13 @@ | otherwise = entityError e $ "Invalid classes " ++ show invalidClassNames where + classes = sortBy (\c1 c2 -> maybeCompare (elemIndex (className c1) instances) + (elemIndex (className c2) instances)) + classes' + maybeCompare (Just a1) (Just a2) = compare a1 a2 + maybeCompare (Just _) Nothing = LT + maybeCompare Nothing (Just _) = GT + maybeCompare Nothing Nothing = EQ instances = entityInstances e invalidClassNames = [ name | name <- instances, isNothing $ classLookup classes name ] diff --git a/Generator/Models.hs b/Generator/Models.hs --- a/Generator/Models.hs +++ b/Generator/Models.hs @@ -27,7 +27,10 @@ entityFieldTypeName e f = upperFirst $ entityFieldName e f enum :: EnumType -> String enum e = T.unpack $(codegenFile "codegen/enum.cg") - + where fromPathPieces = concatMap fromPathPiece (enumValues e) + toPathPieces = concatMap toPathPiece (enumValues e) + fromPathPiece v = T.unpack $(codegenFile "codegen/enum-frompathpiece.cg") + toPathPiece v = T.unpack $(codegenFile "codegen/enum-topathpiece.cg") modelField :: Field -> String modelField f = T.unpack $(codegenFile "codegen/model-field.cg") diff --git a/Parser.y b/Parser.y --- a/Parser.y +++ b/Parser.y @@ -140,8 +140,8 @@ uniques maybeDeriving checks - rbrace { Entity (mkLoc $1) $2 (reverse $4) (reverse $5) - (reverse $6) (reverse $7) (reverse $8) } + rbrace { Entity (mkLoc $1) $2 $4 (reverse $5) + (reverse $6) $7 (reverse $8) } routeDef : route pathPieces lbrace handlers rbrace { Route (mkLoc $1) (reverse $2) (reverse $4) } pathPieces : slash pathPiece { [$2] } @@ -344,17 +344,23 @@ 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") +parseModule :: FilePath -> IO Module +parseModule path = catch + (do + s <- readFile path + return $! moduleDefs $! lexer s) + (\(ParseError msg) -> do + hPutStrLn stderr $ path ++ ": " ++ msg + exitWith (ExitFailure 1)) + + 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)) + mod <- parseModule path + rest <- parseModules (path:handled) (paths ++ modImports mod) + return ((path,mod):rest) parseModules _ [] = return [] parse path = parseModules [] [path] diff --git a/Validation/Names.hs b/Validation/Names.hs --- a/Validation/Names.hs +++ b/Validation/Names.hs @@ -83,6 +83,10 @@ routeLoc r) | (vn,lvl) <- sqScopedAliases sq] DeleteFrom en vn _ -> [([NestedNS 0], handlerName r h ++ " " ++ vn, routeLoc r)] + IfFilter (_,joins,_) -> [([NestedNS lvl], + handlerName r h ++ " " ++ joinAlias j, + routeLoc r) | (j,lvl) <- zip joins ([1..] :: [Int])] + _ -> [] diff --git a/Validation/Refs.hs b/Validation/Refs.hs --- a/Validation/Refs.hs +++ b/Validation/Refs.hs @@ -61,6 +61,7 @@ ++ getRefs (r,h, handlerLoc h, "update in " ++ handlerInfo r h, io) getRefs (r,h,(Select sq)) = getRefs (r,h,sq) + getRefs (r,h,(IfFilter ps)) = getRefs (r,h,ps) getRefs (r,h,(DeleteFrom en vn me)) = [(routeLoc r, "delete-from in " ++ handlerInfo r h, EntityNS, en)] ++ (case me of @@ -68,6 +69,14 @@ _ -> []) getRefs _ = [] +instance HasRefs (Route, Handler, IfFilterParams) where + getRefs (r,h,(pn,joins,e)) = let + l = routeLoc r + i = "if param \"" ++ pn ++ "\" = $$ then" + in getRefs (r,h,l,i,e,1000::Int) + ++ getRefs [ (r,h,l,i,j,lvl) + | (j,lvl) <- zip joins ([1..] :: [Int]) ] + instance HasRefs (Route, Handler, SelectQuery) where getRefs (r,h,sq) = let l= routeLoc r @@ -75,15 +84,27 @@ (en,vn) = sqFrom sq in [(l,i,EntityNS,en), (l,i,GlobalNS, handlerName r h ++ " " ++ vn)] + ++ getRefs [ (r,h,l,i,sf) | sf <- sqFields sq] ++ (case sqWhere sq of Just e -> getRefs (r,h,l,i,e,1000::Int) Nothing -> []) ++ getRefs [ (r,h,l,i,j,lvl) | (j,lvl) <- zip (sqJoins sq) ([1..] :: [Int])] ++ getRefs [ (r,h,l,i,fr, 1000::Int) | (fr,_) <- sqOrderBy sq ] +instance HasRefs (Route, Handler, Location, Info, SelectField) where + getRefs (r,h,l,i,SelectAllFields vn) = + [(l,i,NestedNS 1000, handlerName r h ++ " " ++ vn)] + getRefs (r,h,l,i,SelectField vn fn _) = + [(l,i,NestedNS 1000, handlerName r h ++ " " ++ vn)] + ++ case lookupEntityByVariable r h vn of + (Just en) -> [(l,i,FieldNS, en ++ "." ++ fn)] + Nothing -> [] + getRefs (r,h,l,i,SelectIdField vn _) = + [(l,i,NestedNS 1000, handlerName r h ++ " " ++ vn)] + instance HasRefs (Route, Handler, Location, Info, Join,Int) where getRefs (r,h,l,i,j,lvl) = [(l,i,EntityNS, joinEntity j)] - ++ [(l,i,GlobalNS, handlerName r h ++ " " + ++ [(l,i,NestedNS lvl, handlerName r h ++ " " ++ joinAlias j)] ++ (case joinExpr j of Just e -> @@ -135,6 +156,7 @@ getRefs (r,h,l, i, (OrExpr e1 e2),lvl) = getRefs (r,h,l,i,e1,lvl) ++ getRefs (r,h,l,i,e2,lvl) getRefs (r,h,l, i, (BinOpExpr e1 op e2),lvl) = getRefs (r,h,l,i,e1,lvl) ++ getRefs (r,h,l,i,e2,lvl) getRefs (r,h,l,i, (ListOpExpr fr1 op fr2),lvl) = getRefs (r,h,l,i,fr1,lvl) ++ getRefs (r,h,l,i,fr2,lvl) + getRefs _ = [] instance HasRefs (Route, Handler, Location, Info, ValExpr,Int) where getRefs (r,h,l, i,(FieldExpr f),lvl) = getRefs (r,h,l,i,f,lvl) diff --git a/codegen/enum-frompathpiece.cg b/codegen/enum-frompathpiece.cg new file mode 100644 --- /dev/null +++ b/codegen/enum-frompathpiece.cg @@ -0,0 +1,1 @@ + fromPathPiece "~{v}" = Just ~{v} diff --git a/codegen/enum-topathpiece.cg b/codegen/enum-topathpiece.cg new file mode 100644 --- /dev/null +++ b/codegen/enum-topathpiece.cg @@ -0,0 +1,1 @@ + toPathPiece ~{v} = "~{v}" diff --git a/codegen/enum.cg b/codegen/enum.cg --- a/codegen/enum.cg +++ b/codegen/enum.cg @@ -1,3 +1,8 @@ data ~{enumName e} = ~{intercalate " | " (enumValues e)} deriving (Show, Read, Eq) derivePersistField "~{enumName e}" deriveJSON id ''~{enumName e} + +instance PathPiece ~{enumName e} where +~{fromPathPieces} + fromPathPiece _ = Nothing +~{toPathPieces} diff --git a/codegen/enums-header.cg b/codegen/enums-header.cg --- a/codegen/enums-header.cg +++ b/codegen/enums-header.cg @@ -2,3 +2,5 @@ module Handler.~{moduleName m}.Enums where import Database.Persist.TH import Data.Aeson.TH +import Prelude +import Web.PathPieces diff --git a/dist/build/yesod-dsl/yesod-dsl-tmp/Parser.hs b/dist/build/yesod-dsl/yesod-dsl-tmp/Parser.hs --- a/dist/build/yesod-dsl/yesod-dsl-tmp/Parser.hs +++ b/dist/build/yesod-dsl/yesod-dsl-tmp/Parser.hs @@ -680,8 +680,8 @@ case happyOut55 happy_x_7 of { happy_var_7 -> case happyOut57 happy_x_8 of { happy_var_8 -> happyIn12 - (Entity (mkLoc happy_var_1) happy_var_2 (reverse happy_var_4) (reverse happy_var_5) - (reverse happy_var_6) (reverse happy_var_7) (reverse happy_var_8) + (Entity (mkLoc happy_var_1) happy_var_2 happy_var_4 (reverse happy_var_5) + (reverse happy_var_6) happy_var_7 (reverse happy_var_8) ) `HappyStk` happyRest}}}}}}} happyReduce_17 = happyReduce 5# 9# happyReduction_17 @@ -1911,17 +1911,23 @@ 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") +parseModule :: FilePath -> IO Module +parseModule path = catch + (do + s <- readFile path + return $! moduleDefs $! lexer s) + (\(ParseError msg) -> do + hPutStrLn stderr $ path ++ ": " ++ msg + exitWith (ExitFailure 1)) + + 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)) + mod <- parseModule path + rest <- parseModules (path:handled) (paths ++ modImports mod) + return ((path,mod):rest) parseModules _ [] = return [] parse path = parseModules [] [path] 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.1 +version: 0.1.1.2 license: BSD3 license-file: LICENSE author: Tero Laitinen