diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for type-of-html +## 1.4.0.2 -- 2018-11-12 + +* remove all checks for Raw data + ## 1.4.0.1 -- 2018-05-26 * reduction of reduction depth diff --git a/bench/Alloc.hs b/bench/Alloc.hs --- a/bench/Alloc.hs +++ b/bench/Alloc.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} -- | Note that the allocation numbers are only reproducible on linux using the nix shell. @@ -27,74 +28,77 @@ | n' < n = Just $ "Less" ++ answer | otherwise = Nothing where n' = weightAllocatedBytes w - answer = " allocated bytes than " ++ commas n ++ ": " ++ commas n' + answer = " allocated bytes than expected: " ++ show (abs $ n' - n) -allocsError :: Int -> Int -> Weight -> Maybe String -allocsError n i w - | n' > (n+1) = Just $ "More" ++ answer - | n' < (n-1) = Just $ "Less" ++ answer +allocsError :: Int -> Int -> Int -> Weight -> Maybe String +allocsError i m n w + | n' > (m'+1) = Just $ "More" ++ answer + | n' < (m'-1) = Just $ "Less" ++ answer | otherwise = Nothing where n' = round (fromIntegral (weightAllocatedBytes w) / (10^i) :: Rational) :: Int - answer = " allocated bytes than " - ++ pretty n - ++ ": " - ++ pretty n' + m' = n + m + answer = " allocated bytes than expected: " ++ pretty (abs $ m' - n') pretty x = show x ++ " e" ++ show i -f :: NFData b => String -> Int64 -> (a -> b) -> a -> Weigh () -f s n g x = validateFunc s g x (allocs n) +f :: NFData b => String -> (a -> b) -> a -> Int64 -> Weigh () +f s g x n = validateFunc s g x (allocs n) main :: IO () main = withSystemTempDirectory "compile" $ \tmp -> mainWith $ do - f "()" 96 renderByteString () - f "Int" 216 renderByteString (123456789 :: Int) - f "Word" 216 renderByteString (123456789 :: Word) - f "Char" 232 renderByteString 'a' - f "Integer" 248 renderByteString (123456789 :: Integer) - f "Proxy" 280 renderByteString (Proxy :: Proxy "a") - f "oneElement Proxy" 280 (renderByteString . S.oneElement) (Proxy :: Proxy "b") - f "oneElement ()" 280 (renderByteString . S.oneElement) () - f "oneAttribute ()" 280 (renderByteString . A.class_) () - f "oneAttribute Proxy" 280 (renderByteString . A.class_) (Proxy :: Proxy "c") - f "listElement" 392 (renderByteString . S.listElement) () - f "Double" 360 renderByteString (123456789 :: Double) - f "oneElement" 368 (renderByteString . S.oneElement) "" - f "nestedElement" 368 (renderByteString . S.nestedElement) "" - f "listOfAttributes" 488 (\x -> renderByteString [A.class_ x, A.class_ x]) () - f "Float" 400 renderByteString (123456789 :: Float) - f "oneAttribute" 408 (renderByteString . A.class_) "" - f "parallelElement" 520 (renderByteString . S.parallelElement) "" - f "parallelAttribute" 584 (\x -> renderByteString $ A.class_ x # A.id_ x) "" - f "elementWithAttribute" 584 (\x -> renderByteString $ div_A (A.class_ x) x) "" - f "listOfListOf" 984 (\x -> renderByteString $ div_ [i_ [span_ x]]) () - f "helloWorld" 1264 (renderByteString . M.helloWorld) () - f "page" 1256 (renderByteString . M.page) () - f "table" 1664 (renderByteString . M.table) (2,2) - f "AttrShort" 3232 (renderByteString . M.attrShort) () - f "pageA" 2320 (renderByteString . M.pageA) () - f "AttrLong" 3232 (renderByteString . M.attrLong) () - f "Big table" 19968 (renderByteString . M.table) (15,15) - f "Big page" 24960 (renderByteString . B.page) () + -- ghc version 822 843 861 + f "()" renderByteString () $ ghc [ 96 ] + f "Int" renderByteString (123456789 :: Int) $ ghc [ 216 ] + f "Word" renderByteString (123456789 :: Word) $ ghc [ 216 ] + f "Char" renderByteString 'a' $ ghc [ 232 ] + f "Integer" renderByteString (123456789 :: Integer) $ ghc [ 248 ] + f "Proxy" renderByteString (Proxy :: Proxy "a") $ ghc [ 280 ] + f "oneElement Proxy" (renderByteString . S.oneElement) (Proxy :: Proxy "b") $ ghc [ 280 ] + f "oneElement ()" (renderByteString . S.oneElement) () $ ghc [ 280 ] + f "oneAttribute ()" (renderByteString . A.class_) () $ ghc [ 280 ] + f "oneAttribute Proxy" (renderByteString . A.class_) (Proxy :: Proxy "c") $ ghc [ 280 ] + f "listElement" (renderByteString . S.listElement) () $ ghc [ 392 ] + f "Double" renderByteString (123456789 :: Double) $ ghc [ 360 ] + f "oneElement" (renderByteString . S.oneElement) "" $ ghc [ 368 ] + f "nestedElement" (renderByteString . S.nestedElement) "" $ ghc [ 368 ] + f "listOfAttributes" (\x -> renderByteString [A.class_ x, A.class_ x]) () $ ghc [ 488, 0, -16 ] + f "Float" renderByteString (123456789 :: Float) $ ghc [ 400 ] + f "oneAttribute" (renderByteString . A.class_) "" $ ghc [ 408 ] + f "parallelElement" (renderByteString . S.parallelElement) "" $ ghc [ 520 ] + f "parallelAttribute" (\x -> renderByteString $ A.class_ x # A.id_ x) "" $ ghc [ 584 ] + f "elementWithAttribute" (\x -> renderByteString $ div_A (A.class_ x) x) "" $ ghc [ 584 ] + f "listOfListOf" (\x -> renderByteString $ div_ [i_ [span_ x]]) () $ ghc [ 896, 88, -8 ] + f "helloWorld" (renderByteString . M.helloWorld) () $ ghc [ 1248, 0, 16 ] + f "page" (renderByteString . M.page) () $ ghc [ 1256 ] + f "table" (renderByteString . M.table) (2,2) $ ghc [ 1920, -256, -8 ] + f "AttrShort" (renderByteString . M.attrShort) () $ ghc [ 3184, 48 ] + f "pageA" (renderByteString . M.pageA) () $ ghc [ 2536, -216 ] + f "AttrLong" (renderByteString . M.attrLong) () $ ghc [ 3184, 48, -192 ] + f "Big table" (renderByteString . M.table) (15,15) $ ghc [12904, 7064, -8 ] + f "Big page" (renderByteString . B.page) () $ ghc [25208, -248, -40 ] + let g x y z = validateAction x (compile tmp) y . allocsError 7 z $ ghc [ 104, 0, 2 ] + g "Compile Library" "Html" $ ghc [ 0 ] + g "Compile Small.hs" "Small" $ ghc [ 0 ] + g "Compile Medium.hs" "Medium" $ ghc [ 37, 0, 2 ] + g "Compile Big.hs" "Big" $ ghc [ 70, 0, 3 ] + g "Compile Alloc.hs" "bench/Alloc.hs" $ ghc [ 74, 2 ] + g "Compile Perf.hs" "bench/Perf.hs" $ ghc [ 179, 2 ] + g "Compile X0.hs" "bench/Compilation/X0.hs" $ ghc [ 4, -2 ] + g "Compile X1.hs" "bench/Compilation/X1.hs" $ ghc [ 3 ] + g "Compile X2.hs" "bench/Compilation/X2.hs" $ ghc [ 5 ] + g "Compile X4.hs" "bench/Compilation/X4.hs" $ ghc [ 7 ] + g "Compile X8.hs" "bench/Compilation/X8.hs" $ ghc [ 12 ] + g "Compile X16.hs" "bench/Compilation/X16.hs" $ ghc [ 23 ] + g "Compile X32.hs" "bench/Compilation/X32.hs" $ ghc [ 64, 0 ] + g "Compile X64.hs" "bench/Compilation/X64.hs" $ ghc [ 203, 2, -3 ] + g "Compile X128.hs" "bench/Compilation/X128.hs" $ ghc [ 711, 4, -5 ] - let libAlloc n = allocsError (104 + n) 7 +ghc :: Num a => [a] -> a +ghc [] = 0 +ghc (x:xs) = sum $ x:[y | (y, v) <- zip xs supportedGhcs, v < __GLASGOW_HASKELL__] - validateAction "Compile Library" (compile tmp) "Html" $ libAlloc 0 - validateAction "Compile Small.hs" (compile tmp) "Small" $ libAlloc 2 - validateAction "Compile Medium.hs" (compile tmp) "Medium" $ libAlloc 39 - validateAction "Compile Big.hs" (compile tmp) "Big" $ libAlloc 73 - validateAction "Compile Alloc.hs" (compile tmp) "bench/Alloc.hs" $ libAlloc 76 - validateAction "Compile Perf.hs" (compile tmp) "bench/Perf.hs" $ libAlloc 181 + where supportedGhcs = [802, 804] :: [Int] - validateAction "Compile X0.hs" (compile tmp) "bench/Compilation/X0.hs" $ libAlloc 4 - validateAction "Compile X1.hs" (compile tmp) "bench/Compilation/X1.hs" $ libAlloc 5 - validateAction "Compile X2.hs" (compile tmp) "bench/Compilation/X2.hs" $ libAlloc 5 - validateAction "Compile X4.hs" (compile tmp) "bench/Compilation/X4.hs" $ libAlloc 7 - validateAction "Compile X8.hs" (compile tmp) "bench/Compilation/X8.hs" $ libAlloc 12 - validateAction "Compile X16.hs" (compile tmp) "bench/Compilation/X16.hs" $ libAlloc 25 - validateAction "Compile X32.hs" (compile tmp) "bench/Compilation/X32.hs" $ libAlloc 66 - validateAction "Compile X64.hs" (compile tmp) "bench/Compilation/X64.hs" $ libAlloc 205 - validateAction "Compile X128.hs" (compile tmp) "bench/Compilation/X128.hs" $ libAlloc 717 compile :: String -> String -> IO () compile out m = diff --git a/bench/Perf.hs b/bench/Perf.hs --- a/bench/Perf.hs +++ b/bench/Perf.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} module Main where diff --git a/src/Html/Convert.hs b/src/Html/Convert.hs --- a/src/Html/Convert.hs +++ b/src/Html/Convert.hs @@ -114,14 +114,14 @@ stringConvRaw = Converted . B.stringUtf8 escapeUtf8 :: BP.BoundedPrim Char -escapeUtf8 = - BP.condB (> '>' ) BP.charUtf8 $ - BP.condB (== '<' ) (fixed4 ('&',('l',('t',';')))) $ - BP.condB (== '>' ) (fixed4 ('&',('g',('t',';')))) $ - BP.condB (== '&' ) (fixed5 ('&',('a',('m',('p',';'))))) $ - BP.condB (== '"' ) (fixed5 ('&',('#',('3',('4',';'))))) $ - BP.condB (== '\'') (fixed5 ('&',('#',('3',('9',';'))))) $ - BP.liftFixedToBounded BP.char7 +escapeUtf8 + = BP.condB (> '>' ) BP.charUtf8 + . BP.condB (== '<' ) (fixed4 ('&',('l',('t',';')))) + . BP.condB (== '>' ) (fixed4 ('&',('g',('t',';')))) + . BP.condB (== '&' ) (fixed5 ('&',('a',('m',('p',';'))))) + . BP.condB (== '"' ) (fixed5 ('&',('#',('3',('4',';'))))) + . BP.condB (== '\'') (fixed5 ('&',('#',('3',('9',';'))))) + $ BP.liftFixedToBounded BP.char7 where {-# INLINE fixed4 #-} fixed4 x = BP.liftFixedToBounded $ const x BP.>$< @@ -132,14 +132,14 @@ BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 escape :: BP.BoundedPrim Word8 -escape = - BP.condB (> c2w '>' ) (BP.liftFixedToBounded BP.word8) $ - BP.condB (== c2w '<' ) (fixed4 (c2w '&',(c2w 'l',(c2w 't',c2w ';')))) $ - BP.condB (== c2w '>' ) (fixed4 (c2w '&',(c2w 'g',(c2w 't',c2w ';')))) $ - BP.condB (== c2w '&' ) (fixed5 (c2w '&',(c2w 'a',(c2w 'm',(c2w 'p',c2w ';'))))) $ - BP.condB (== c2w '"' ) (fixed5 (c2w '&',(c2w '#',(c2w '3',(c2w '4',c2w ';'))))) $ - BP.condB (== c2w '\'') (fixed5 (c2w '&',(c2w '#',(c2w '3',(c2w '9',c2w ';'))))) $ - BP.liftFixedToBounded BP.word8 +escape + = BP.condB (> c2w '>' ) (BP.liftFixedToBounded BP.word8) + . BP.condB (== c2w '<' ) (fixed4 (c2w '&',(c2w 'l',(c2w 't',c2w ';')))) + . BP.condB (== c2w '>' ) (fixed4 (c2w '&',(c2w 'g',(c2w 't',c2w ';')))) + . BP.condB (== c2w '&' ) (fixed5 (c2w '&',(c2w 'a',(c2w 'm',(c2w 'p',c2w ';'))))) + . BP.condB (== c2w '"' ) (fixed5 (c2w '&',(c2w '#',(c2w '3',(c2w '4',c2w ';'))))) + . BP.condB (== c2w '\'') (fixed5 (c2w '&',(c2w '#',(c2w '3',(c2w '9',c2w ';'))))) + $ BP.liftFixedToBounded BP.word8 where c2w = fromIntegral . ord diff --git a/src/Html/Reify.hs b/src/Html/Reify.hs --- a/src/Html/Reify.hs +++ b/src/Html/Reify.hs @@ -67,7 +67,7 @@ instance {-# OVERLAPPING #-} ( R (T xs val) - ) => R (T (NoTail xs) val) where + ) => R (T ('List xs "") val) where {-# INLINE render #-} render (T t) = render (T t :: T xs val) diff --git a/src/Html/Type/Internal.hs b/src/Html/Type/Internal.hs --- a/src/Html/Type/Internal.hs +++ b/src/Html/Type/Internal.hs @@ -14,7 +14,7 @@ module Html.Type.Internal where import GHC.TypeLits -import GHC.Exts +import GHC.Exts (Constraint) import Data.Proxy import Data.Type.Bool @@ -332,10 +332,6 @@ -- | We need efficient cons, snoc and append. This API has cons(O1) -- and snoc(O1) but append(On). Optimal would be a FingerTree. data List = List [Symbol] Symbol -type Empty = 'List '[] "" -type Split = 'List '[""] "" -type NoTail xs = 'List xs "" -type Singleton = 'List '[] type family (<|) s t :: List where (<|) l ('List (s ': ss) r) = 'List (AppendSymbol l s ': ss) r @@ -355,14 +351,14 @@ -- | Flatten a document into a type list of tags. type family ToList a :: List where ToList (a # b) = ToList a >< ToList b - ToList ((a :@: ()) ()) = Singleton (If (HasContent (GetEInfo a)) (AppendSymbol (OpenTag a) (CloseTag a)) (OpenTag a)) + ToList ((a :@: ()) ()) = 'List '[] (If (HasContent (GetEInfo a)) (AppendSymbol (OpenTag a) (CloseTag a)) (OpenTag a)) ToList ((a :@: b) ()) = AppendSymbol "<" (ShowElement a) <| ToList b |> If (HasContent (GetEInfo a)) (AppendSymbol ">" (CloseTag a)) ">" ToList ((a :@: ()) b) = OpenTag a <| ToList b |> CloseTag a ToList ((a :@: b) c) = (AppendSymbol "<" (ShowElement a) <| ToList b) >< (">" <| ToList c |> CloseTag a) ToList (a := b) = AppendSymbol " " (AppendSymbol (ShowAttribute a) "=\"") <| ToList b |> "\"" - ToList () = Empty - ToList (Proxy x) = Singleton x - ToList x = Split + ToList () = 'List '[] "" + ToList (Proxy x) = 'List '[] x + ToList x = 'List '[""] "" newtype (:=) (a :: Attribute) b = AT b @@ -374,6 +370,7 @@ type family Check f a b :: Constraint where Check _ _ () = () + Check _ _ (Raw _) = () Check f a (b # c) = (Check f a b, Check f a c) Check f a (Maybe b) = Check f a b Check f a (Either b c) = (Check f a b, Check f a c) diff --git a/test/Type.hs b/test/Type.hs --- a/test/Type.hs +++ b/test/Type.hs @@ -18,9 +18,9 @@ type Test = ( ToList () - == Empty + == 'List '[] "" , ToList Int - == Split + == 'List '[""] "" , ToList (Proxy "a") == 'List '[] "a" , ToList ('A > Char) diff --git a/type-of-html.cabal b/type-of-html.cabal --- a/type-of-html.cabal +++ b/type-of-html.cabal @@ -1,5 +1,5 @@ name: type-of-html -version: 1.4.0.1 +version: 1.4.0.2 synopsis: High performance type driven html generation. description: This library makes most invalid html documents compile time errors and uses advanced type level features to realise compile time computations. license: BSD3 @@ -8,7 +8,8 @@ maintainer: fknupfer@gmail.com homepage: https://github.com/knupfer/type-of-html tested-with: GHC == 8.2.2 - , GHC == 8.4.2 + , GHC == 8.4.4 + , GHC == 8.6.2 copyright: 2017 - 2018, Florian Knupfer category: Language, Text, Web, HTML build-type: Simple @@ -30,7 +31,7 @@ hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall - build-depends: base >= 4.9 && < 5 + build-depends: base >= 4.9 && <= 5 , text , bytestring , ghc-prim @@ -42,7 +43,7 @@ hs-source-dirs: test ghc-options: -Wall -O0 default-language: Haskell2010 - build-depends: base >= 4.9 && < 5 + build-depends: base >= 4.9 && <= 5 , type-of-html , QuickCheck , hspec @@ -55,7 +56,7 @@ other-modules: Html.Type.Internal ghc-options: -Wall default-language: Haskell2010 - build-depends: base >= 4.9 && < 5 + build-depends: base >= 4.9 && <= 5 benchmark reduction type: exitcode-stdio-1.0 @@ -63,7 +64,7 @@ hs-source-dirs: bench ghc-options: -Wall -O2 default-language: Haskell2010 - build-depends: base >= 4.9 && < 5 + build-depends: base >= 4.9 && <= 5 , type-of-html benchmark alloc @@ -85,7 +86,7 @@ hs-source-dirs: bench ghc-options: -Wall -O2 default-language: Haskell2010 - build-depends: base >= 4.9 && < 5 + build-depends: base >= 4.9 && <= 5 , type-of-html , deepseq , weigh @@ -103,7 +104,7 @@ hs-source-dirs: bench ghc-options: -Wall -O2 default-language: Haskell2010 - build-depends: base >= 4.9 && < 5 + build-depends: base >= 4.9 && <= 5 , type-of-html , text , bytestring