ihp-hsx 1.0.0 → 1.1.0
raw patch · 6 files changed
+70/−33 lines, 6 filesdep ~basedep ~containersdep ~ghc
Dependency ranges changed: base, containers, ghc, megaparsec, template-haskell, text
Files
- IHP/HSX/HaskellParser.hs +26/−6
- IHP/HSX/HsExpToTH.hs +8/−8
- IHP/HSX/Parser.hs +15/−4
- IHP/HSX/QQ.hs +2/−0
- README.md +5/−5
- ihp-hsx.cabal +14/−10
IHP/HSX/HaskellParser.hs view
@@ -2,7 +2,6 @@ import Prelude import GHC.Parser.Lexer (ParseResult (..), PState (..))-import qualified GHC.Parser.Errors.Ppr as ParserErrorPpr import GHC.Types.SrcLoc import qualified GHC.Parser as Parser import qualified GHC.Parser.Lexer as Lexer@@ -16,16 +15,26 @@ import GHC import IHP.HSX.HsExpToTH (toExp) +import GHC.Types.Error+import GHC.Utils.Outputable hiding ((<>))+import GHC.Utils.Error+import qualified GHC.Types.SrcLoc as SrcLoc+ parseHaskellExpression :: SourcePos -> [TH.Extension] -> String -> Either (Int, Int, String) TH.Exp parseHaskellExpression sourcePos extensions input = case expr of POk parserState result -> Right (toExp (unLoc result)) PFailed parserState -> let- error = concatMap (show . ParserErrorPpr.pprError) (parserState.errors)- realLoc = (psRealLoc parserState.loc)- line = srcLocLine realLoc- col = srcLocCol realLoc+ error = renderWithContext defaultSDocContext+ $ vcat+ $ map (formatBulleted defaultSDocContext)+ $ map diagnosticMessage+ $ map errMsgDiagnostic+ $ sortMsgBag Nothing+ $ getMessages parserState.errors+ line = SrcLoc.srcLocLine parserState.loc.psRealLoc+ col = SrcLoc.srcLocCol parserState.loc.psRealLoc in Left (line, col, error) where@@ -50,4 +59,15 @@ parseState = Lexer.initParserState parserOpts buffer location parserOpts :: Lexer.ParserOpts- parserOpts = Lexer.mkParserOpts EnumSet.empty (EnumSet.fromList extensions) False False False False+ parserOpts = Lexer.mkParserOpts (EnumSet.fromList extensions) diagOpts [] False False False False++diagOpts :: DiagOpts+diagOpts =+ DiagOpts+ { diag_warning_flags = EnumSet.empty+ , diag_fatal_warning_flags = EnumSet.empty+ , diag_warn_is_error = False+ , diag_reverse_errors = False+ , diag_max_errors = Nothing+ , diag_ppr_ctx = defaultSDocContext+ }
IHP/HSX/HsExpToTH.hs view
@@ -74,7 +74,7 @@ toPat :: Pat.Pat GhcPs -> TH.Pat toPat (Pat.VarPat _ (unLoc -> name)) = TH.VarP (toName name) toPat (TuplePat _ p _) = TH.TupP (map (toPat . unLoc) p)-toPat (ParPat xP lP) = (toPat . unLoc) lP+toPat (ParPat xP _ lP _) = (toPat . unLoc) lP toPat (ConPat pat_con_ext ((unLoc -> name)) pat_args) = TH.ConP (toName name) (map toType []) (map (toPat . unLoc) (Pat.hsConPatArgs pat_args)) toPat (ViewPat pat_con pat_args pat_con_ext) = error "TH.ViewPattern not implemented" toPat (SumPat _ _ _ _) = error "TH.SumPat not implemented"@@ -138,7 +138,7 @@ tupArgs = fmap ((fmap toExp) . toTupArg) args -- toExp (Expr.List _ xs) = TH.ListE (fmap toExp xs)-toExp (Expr.HsPar _ e)+toExp (Expr.HsPar _ _ e _) = TH.ParensE (toExp . unLoc $ e) toExp (Expr.SectionL _ (unLoc -> a) (unLoc -> b))@@ -155,9 +155,9 @@ let f (unLoc -> x) = (name, value) where- value = toExp $ unLoc $ hsRecFieldArg x+ value = toExp $ unLoc $ hfbRHS x name =- case unLoc (hsRecFieldLbl x) of+ case unLoc (hfbLHS x) of Unambiguous _ (unLoc -> name) -> toName name Ambiguous _ (unLoc -> name) -> toName name in@@ -181,15 +181,15 @@ toExp (Expr.HsProjection _ locatedFields) = let- extractFieldLabel (HsFieldLabel _ locatedStr) = locatedStr- extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..."+ extractFieldLabel (DotFieldOcc _ locatedStr) = locatedStr+ extractFieldLabel _ = error "Don't know how to handle XDotFieldOcc constructor..." in TH.ProjectionE (NonEmpty.map (unpackFS . unLoc . extractFieldLabel . unLoc) locatedFields) toExp (Expr.HsGetField _ expr locatedField) = let- extractFieldLabel (HsFieldLabel _ locatedStr) = locatedStr- extractFieldLabel _ = error "Don't know how to handle XHsFieldLabel constructor..."+ extractFieldLabel (DotFieldOcc _ locatedStr) = locatedStr+ extractFieldLabel _ = error "Don't know how to handle XDotFieldOcc constructor..." in TH.GetFieldE (toExp (unLoc expr)) (unpackFS . unLoc . extractFieldLabel . unLoc $ locatedField)
IHP/HSX/Parser.hs view
@@ -43,7 +43,8 @@ | PreEscapedTextNode !Text -- ^ Used in @script@ or @style@ bodies | SplicedNode !Haskell.Exp -- ^ Inline haskell expressions like @{myVar}@ or @{f "hello"}@ | Children ![Node]- | CommentNode !Text+ | CommentNode !Text -- ^ A Comment that is rendered in the final HTML+ | NoRenderCommentNode -- ^ A comment that is not rendered in the final HTML deriving (Eq, Show) -- | Parses a HSX text and returns a 'Node'@@ -79,7 +80,7 @@ pure node hsxElement :: Parser Node-hsxElement = try hsxComment <|> try hsxSelfClosingElement <|> hsxNormalElement+hsxElement = try hsxNoRenderComment <|> try hsxComment <|> try hsxSelfClosingElement <|> hsxNormalElement manyHsxElement :: Parser Node manyHsxElement = do@@ -138,7 +139,14 @@ space pure (CommentNode (cs body)) +hsxNoRenderComment :: Parser Node+hsxNoRenderComment = do+ string "{-"+ manyTill (satisfy (const True)) (string "-}")+ space+ pure NoRenderCommentNode + hsxNodeAttributes :: Parser a -> Parser [Attribute] hsxNodeAttributes end = staticAttributes where@@ -155,7 +163,7 @@ hsxSplicedAttributes :: Parser Attribute hsxSplicedAttributes = do- (pos, name) <- between (string "{...") (string "}") do+ (pos, name) <- between (do char '{'; optional space; string "...") (string "}") do pos <- getSourcePos code <- takeWhile1P Nothing (\c -> c /= '}') pure (pos, code)@@ -279,7 +287,7 @@ hsxElementName :: Parser Text hsxElementName = do- name <- takeWhile1P (Just "identifier") (\c -> Char.isAlphaNum c || c == '_' || c == '-')+ name <- takeWhile1P (Just "identifier") (\c -> Char.isAlphaNum c || c == '_' || c == '-' || c == '!') let isValidParent = name `Set.member` parents let isValidLeaf = name `Set.member` leafs let isValidCustomWebComponent = "-" `Text.isInfixOf` name@@ -387,6 +395,8 @@ , "cellspacing", "cellpadding", "bgcolor", "classes" , "loading" , "frameborder", "allow", "allowfullscreen", "nonce", "referrerpolicy", "slot"+ , "kind"+ , "html" ] parents :: Set Text@@ -578,6 +588,7 @@ , "link" , "meta" , "param"+ , "!DOCTYPE" ] stripTextNodeWhitespaces nodes = stripLastTextNodeWhitespaces (stripFirstTextNodeWhitespaces nodes)
IHP/HSX/QQ.hs view
@@ -49,6 +49,7 @@ pure $ Megaparsec.SourcePos (TH.loc_filename loc) (Megaparsec.mkPos line) (Megaparsec.mkPos col) compileToHaskell :: Node -> TH.ExpQ+compileToHaskell (Node "!DOCTYPE" [StaticAttribute "html" (TextValue "html")] [] True) = [| Html5.docType |] compileToHaskell (Node name attributes children isLeaf) = let renderedChildren = TH.listE $ map compileToHaskell children@@ -79,6 +80,7 @@ compileToHaskell (PreEscapedTextNode value) = [| Html5.preEscapedText value |] compileToHaskell (SplicedNode expression) = [| toHtml $(pure expression) |] compileToHaskell (CommentNode value) = [| Html5.textComment value |]+compileToHaskell (NoRenderCommentNode) = [| mempty |] toStringAttribute :: Attribute -> TH.ExpQ
README.md view
@@ -222,11 +222,11 @@ ### Syntax Rules -While most HTML is also valid HSX, there are some difference you need to be aware of:+While most HTML is also valid HSX, there are some differences you need to be aware of: #### Closing Tags -Tags always need to have a closing tag or be self-closing: so instead of `<br>` you need to write `<br/>`+Tags always need to have a closing tag or be self-closing: so instead of `<br>` you need to write `<br/>`. #### JSX Differences @@ -292,11 +292,11 @@ ```haskell render user = [hsx|- <p>Hi {get #name user}</p>+ <p>Hi {user.name}</p> {renderCountry} |] where- renderCountry = case get #country user of+ renderCountry = case user.country of Just country -> [hsx|<p><small>{country}</small></p>|] Nothing -> [hsx||] ```@@ -304,7 +304,7 @@ What about if the country is a empty string? A simple solution could look like this: ```haskell-renderCountry = case get #country user of+renderCountry = case user.country of Just "" -> [hsx||] Just country -> [hsx|<p>from {country}!</p>|] Nothing -> [hsx||]
ihp-hsx.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: ihp-hsx-version: 1.0.0+version: 1.1.0 synopsis: JSX-like but for Haskell description: JSX-like templating syntax for Haskell license: MIT@@ -19,15 +19,15 @@ library default-language: Haskell2010 build-depends:- base >= 4.16.3 && < 4.17- , blaze-html >= 0.9.1 && < 0.10- , bytestring >= 0.11.3 && < 0.12- , template-haskell >= 2.18.0 && < 2.19- , text >= 1.2.5 && < 1.3- , containers >= 0.6.5 && < 0.7- , blaze-markup >= 0.8.2 && < 0.9- , ghc >= 9.2.4 && < 9.3- , megaparsec >= 9.2.1 && < 9.3+ base >= 4.17.0 && < 4.18+ , blaze-html >= 0.9.1 && < 0.10+ , bytestring >= 0.11.3 && < 0.12+ , template-haskell >= 2.19.0 && < 2.20+ , text >= 2.0.1 && < 2.1+ , containers >= 0.6.6 && < 0.7+ , blaze-markup >= 0.8.2 && < 0.9+ , ghc >= 9.4.4 && < 9.5+ , megaparsec >= 9.2.2 && < 9.3 , string-conversions >= 0.4.0 && < 0.5 default-extensions: OverloadedStrings@@ -74,7 +74,11 @@ -Winaccessible-code -Wmissed-specialisations -Wall-missed-specialisations+ -fspecialise-aggressively+ -funfolding-use-threshold=120+ -fdicts-strict -fexpose-all-unfoldings+ -optc-O3 hs-source-dirs: . exposed-modules: IHP.HSX.Parser