yesod-dsl 0.1.1.1 → 0.1.1.2
raw patch · 12 files changed
+83/−26 lines, 12 files
Files
- AST.hs +3/−3
- ClassImplementer.hs +9/−2
- Generator/Models.hs +4/−1
- Parser.y +15/−9
- Validation/Names.hs +4/−0
- Validation/Refs.hs +23/−1
- codegen/enum-frompathpiece.cg +1/−0
- codegen/enum-topathpiece.cg +1/−0
- codegen/enum.cg +5/−0
- codegen/enums-header.cg +2/−0
- dist/build/yesod-dsl/yesod-dsl-tmp/Parser.hs +15/−9
- yesod-dsl.cabal +1/−1
AST.hs view
@@ -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)
ClassImplementer.hs view
@@ -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 ]
Generator/Models.hs view
@@ -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")
Parser.y view
@@ -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]
Validation/Names.hs view
@@ -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])]+ _ -> []
Validation/Refs.hs view
@@ -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)
+ codegen/enum-frompathpiece.cg view
@@ -0,0 +1,1 @@+ fromPathPiece "~{v}" = Just ~{v}
+ codegen/enum-topathpiece.cg view
@@ -0,0 +1,1 @@+ toPathPiece ~{v} = "~{v}"
codegen/enum.cg view
@@ -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}
codegen/enums-header.cg view
@@ -2,3 +2,5 @@ module Handler.~{moduleName m}.Enums where import Database.Persist.TH import Data.Aeson.TH+import Prelude+import Web.PathPieces
dist/build/yesod-dsl/yesod-dsl-tmp/Parser.hs view
@@ -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]
yesod-dsl.cabal view
@@ -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