ihp-hsx 1.1.0 → 1.3.0
raw patch · 6 files changed
+102/−36 lines, 6 filesdep ~basedep ~bytestringdep ~ghc
Dependency ranges changed: base, bytestring, ghc, megaparsec, template-haskell, text
Files
- IHP/HSX/Attribute.hs +43/−0
- IHP/HSX/HaskellParser.hs +16/−0
- IHP/HSX/HsExpToTH.hs +33/−3
- IHP/HSX/Parser.hs +1/−0
- IHP/HSX/QQ.hs +1/−26
- ihp-hsx.cabal +8/−7
+ IHP/HSX/Attribute.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE UndecidableInstances #-}+{-|+Module: IHP.HSX.Attribute+Copyright: (c) digitally induced GmbH, 2023+-}+module IHP.HSX.Attribute+( ApplyAttribute (..)+) where++import Prelude+import Text.Blaze.Html5 ((!))+import qualified Text.Blaze.Html5 as Html5+import Text.Blaze.Internal (attribute, MarkupM (Parent, Leaf), StaticString (..))+import Data.String.Conversions+import IHP.HSX.ToHtml+import qualified Data.Text as Text+import Data.Text (Text)++class ApplyAttribute value where+ applyAttribute :: Text -> Text -> value -> (Html5.Html -> Html5.Html)++instance ApplyAttribute Bool where+ applyAttribute attr attr' True h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') (Html5.textValue value))+ where+ value = if "data-" `Text.isPrefixOf` attr+ then "true" -- "true" for data attributes+ else attr -- normal html boolean attriubtes, like <input disabled="disabled"/>, see https://html.spec.whatwg.org/multipage/common-microsyntaxes.html#boolean-attributes+ applyAttribute attr attr' false h | "data-" `Text.isPrefixOf` attr = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') "false") -- data attribute set to "false"+ applyAttribute attr attr' false h = h -- html boolean attribute, like <input disabled/> will be dropped as there is no other way to specify that it's set to false+ {-# INLINE applyAttribute #-}++instance ApplyAttribute attribute => ApplyAttribute (Maybe attribute) where+ applyAttribute attr attr' (Just value) h = applyAttribute attr attr' value h+ applyAttribute attr attr' Nothing h = h+ {-# INLINE applyAttribute #-}++instance ApplyAttribute Html5.AttributeValue where+ applyAttribute attr attr' value h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') value)+ {-# INLINE applyAttribute #-}++instance {-# OVERLAPPABLE #-} ConvertibleStrings value Html5.AttributeValue => ApplyAttribute value where+ applyAttribute attr attr' value h = applyAttribute attr attr' ((cs value) :: Html5.AttributeValue) h+ {-# INLINE applyAttribute #-}
IHP/HSX/HaskellParser.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module IHP.HSX.HaskellParser (parseHaskellExpression) where import Prelude@@ -19,6 +20,9 @@ import GHC.Utils.Outputable hiding ((<>)) import GHC.Utils.Error import qualified GHC.Types.SrcLoc as SrcLoc+#if __GLASGOW_HASKELL__ >= 908+import GHC.Unit.Module.Warnings+#endif parseHaskellExpression :: SourcePos -> [TH.Extension] -> String -> Either (Int, Int, String) TH.Exp parseHaskellExpression sourcePos extensions input =@@ -28,8 +32,16 @@ let error = renderWithContext defaultSDocContext $ vcat+#if __GLASGOW_HASKELL__ >= 908+ $ map formatBulleted+#else $ map (formatBulleted defaultSDocContext)+#endif+#if __GLASGOW_HASKELL__ >= 906+ $ map (diagnosticMessage NoDiagnosticOpts)+#else $ map diagnosticMessage+#endif $ map errMsgDiagnostic $ sortMsgBag Nothing $ getMessages parserState.errors@@ -70,4 +82,8 @@ , diag_reverse_errors = False , diag_max_errors = Nothing , diag_ppr_ctx = defaultSDocContext+#if __GLASGOW_HASKELL__ >= 908+ , diag_custom_warning_categories = emptyWarningCategorySet+ , diag_fatal_custom_warning_categories = emptyWarningCategorySet+#endif }
IHP/HSX/HsExpToTH.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns, CPP #-} {-| Module: IHP.HSX.HsExpToTH Copyright: (c) digitally induced GmbH, 2022@@ -28,6 +28,9 @@ import GHC.Stack import qualified Data.List.NonEmpty as NonEmpty import Language.Haskell.Syntax.Type+#if __GLASGOW_HASKELL__ >= 906+import Language.Haskell.Syntax.Basic+#endif fl_value = rationalFromFractionalLit@@ -89,7 +92,11 @@ then TH.ConE (toName n') else TH.VarE (toName n') +#if __GLASGOW_HASKELL__ >= 906+toExp (Expr.HsUnboundVar _ n) = TH.UnboundVarE (TH.mkName . occNameString $ occName n)+#else toExp (Expr.HsUnboundVar _ n) = TH.UnboundVarE (TH.mkName . occNameString $ n)+#endif toExp Expr.HsIPVar {} = noTH "toExp" "HsIPVar"@@ -103,7 +110,11 @@ toExp (Expr.HsApp _ e1 e2) = TH.AppE (toExp . unLoc $ e1) (toExp . unLoc $ e2) +#if __GLASGOW_HASKELL__ >= 906+toExp (Expr.HsAppType _ e _ HsWC {hswc_body}) = TH.AppTypeE (toExp . unLoc $ e) (toType . unLoc $ hswc_body)+#else toExp (Expr.HsAppType _ e HsWC {hswc_body}) = TH.AppTypeE (toExp . unLoc $ e) (toType . unLoc $ hswc_body)+#endif toExp (Expr.ExprWithTySig _ e HsWC{hswc_body=unLoc -> HsSig{sig_body}}) = TH.SigE (toExp . unLoc $ e) (toType . unLoc $ sig_body) toExp (Expr.OpApp _ e1 o e2)@@ -113,7 +124,11 @@ = TH.AppE (TH.VarE 'negate) (toExp . unLoc $ e) -- NOTE: for lambda, there is only one match+#if __GLASGOW_HASKELL__ >= 906+toExp (Expr.HsLam _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)]))))+#else toExp (Expr.HsLam _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)])) _))+#endif = TH.LamE (fmap toPat ps) (toExp e) -- toExp (Expr.Let _ bs e) = TH.LetE (toDecs bs) (toExp e)@@ -151,7 +166,11 @@ = TH.RecConE (toName . unLoc $ name) (fmap toFieldExp rec_flds) toExp (Expr.RecordUpd _ (unLoc -> e) xs) = TH.RecUpdE (toExp e) $ case xs of+#if __GLASGOW_HASKELL__ >= 908+ RegularRecUpdFields { recUpdFields = fields } ->+#else Left fields ->+#endif let f (unLoc -> x) = (name, value) where@@ -162,7 +181,7 @@ Ambiguous _ (unLoc -> name) -> toName name in map f fields- Right xs -> error "todo"+ otherwise -> error "todo" -- toExp (Expr.ListComp _ e ss) = TH.CompE $ map convert ss ++ [TH.NoBindS (toExp e)] -- where -- convert (Expr.QualStmt _ st) = toStmt st@@ -184,17 +203,28 @@ extractFieldLabel (DotFieldOcc _ locatedStr) = locatedStr extractFieldLabel _ = error "Don't know how to handle XDotFieldOcc constructor..." in+#if __GLASGOW_HASKELL__ >= 906+ TH.ProjectionE (NonEmpty.map (unpackFS . (.field_label) . unLoc . extractFieldLabel . unLoc) locatedFields)+#else TH.ProjectionE (NonEmpty.map (unpackFS . unLoc . extractFieldLabel . unLoc) locatedFields)+#endif toExp (Expr.HsGetField _ expr locatedField) = let extractFieldLabel (DotFieldOcc _ locatedStr) = locatedStr extractFieldLabel _ = error "Don't know how to handle XDotFieldOcc constructor..." in+#if __GLASGOW_HASKELL__ >= 906+ TH.GetFieldE (toExp (unLoc expr)) (unpackFS . (.field_label) . unLoc . extractFieldLabel . unLoc $ locatedField)+#else TH.GetFieldE (toExp (unLoc expr)) (unpackFS . unLoc . extractFieldLabel . unLoc $ locatedField)-+#endif +#if __GLASGOW_HASKELL__ >= 906+toExp (Expr.HsOverLabel _ _ fastString) = TH.LabelE (unpackFS fastString)+#else toExp (Expr.HsOverLabel _ fastString) = TH.LabelE (unpackFS fastString)+#endif toExp e = todo "toExp" e
IHP/HSX/Parser.hs view
@@ -397,6 +397,7 @@ , "frameborder", "allow", "allowfullscreen", "nonce", "referrerpolicy", "slot" , "kind" , "html"+ , "sse-connect", "sse-swap" ] parents :: Set Text
IHP/HSX/QQ.hs view
@@ -24,6 +24,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.List (foldl')+import IHP.HSX.Attribute hsx :: QuasiQuoter hsx = QuasiQuoter {@@ -108,32 +109,6 @@ textToStaticString :: Text -> StaticString textToStaticString text = StaticString (Text.unpack text ++) (Text.encodeUtf8 text) text {-# INLINE textToStaticString #-}--class ApplyAttribute value where- applyAttribute :: Text -> Text -> value -> (Html5.Html -> Html5.Html)--instance ApplyAttribute Bool where- applyAttribute attr attr' True h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') (Html5.textValue value))- where- value = if "data-" `Text.isPrefixOf` attr- then "true" -- "true" for data attributes- else attr -- normal html boolean attriubtes, like <input disabled="disabled"/>, see https://html.spec.whatwg.org/multipage/common-microsyntaxes.html#boolean-attributes- applyAttribute attr attr' false h | "data-" `Text.isPrefixOf` attr = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') "false") -- data attribute set to "false"- applyAttribute attr attr' false h = h -- html boolean attribute, like <input disabled/> will be dropped as there is no other way to specify that it's set to false- {-# INLINE applyAttribute #-}--instance ApplyAttribute attribute => ApplyAttribute (Maybe attribute) where- applyAttribute attr attr' (Just value) h = applyAttribute attr attr' value h- applyAttribute attr attr' Nothing h = h- {-# INLINE applyAttribute #-}--instance ApplyAttribute Html5.AttributeValue where- applyAttribute attr attr' value h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') value)- {-# INLINE applyAttribute #-}--instance {-# OVERLAPPABLE #-} ConvertibleStrings value Html5.AttributeValue => ApplyAttribute value where- applyAttribute attr attr' value h = applyAttribute attr attr' ((cs value) :: Html5.AttributeValue) h- {-# INLINE applyAttribute #-} instance Show (MarkupM ()) where show html = BlazeString.renderHtml html
ihp-hsx.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: ihp-hsx-version: 1.1.0+version: 1.3.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.17.0 && < 4.18+ base >= 4.17.0 && < 4.20 , 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+ , bytestring >= 0.11.3 && < 0.13+ , template-haskell >= 2.19.0 && < 2.22+ , text >= 2.0.1 && < 2.2 , 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+ , ghc >= 9.4.4 && < 9.9+ , megaparsec >= 9.2.2 && < 9.7 , string-conversions >= 0.4.0 && < 0.5 default-extensions: OverloadedStrings@@ -87,3 +87,4 @@ , IHP.HSX.ConvertibleStrings , IHP.HSX.HaskellParser , IHP.HSX.HsExpToTH+ , IHP.HSX.Attribute