1{-# LANGUAGE CPP #-} 2{-# LANGUAGE TemplateHaskell #-} 3 4-- | Internal functions to generate CSS size wrapper types. 5module Text.MkSizeType (mkSizeType) where 6 7#if !MIN_VERSION_template_haskell(2,12,0) 8import Language.Haskell.TH (conT) 9#endif 10import Language.Haskell.TH.Syntax 11import Data.Text.Lazy.Builder (fromLazyText) 12import qualified Data.Text.Lazy as TL 13 14mkSizeType :: String -> String -> Q [Dec] 15mkSizeType name' unit = do 16 ddn <- dataDec name 17 return [ ddn 18 , showInstanceDec name unit 19 , numInstanceDec name 20 , fractionalInstanceDec name 21 , toCssInstanceDec name ] 22 where name = mkName $ name' 23 24dataDec :: Name -> Q Dec 25dataDec name = 26#if MIN_VERSION_template_haskell(2,12,0) 27 return $ 28 DataD [] name [] Nothing [constructor] [DerivClause Nothing (map ConT derives)] 29#else 30 DataD [] name [] Nothing [constructor] <$> mapM conT derives 31#endif 32 where constructor = NormalC name [(notStrict, ConT $ mkName "Rational")] 33 derives = map mkName ["Eq", "Ord"] 34 35showInstanceDec :: Name -> String -> Dec 36showInstanceDec name unit' = instanceD [] (instanceType "Show" name) [showDec] 37 where showSize = VarE $ mkName "showSize" 38 x = mkName "x" 39 unit = LitE $ StringL unit' 40 showDec = FunD (mkName "show") [Clause [showPat] showBody []] 41 showPat = ConP name [VarP x] 42 showBody = NormalB $ AppE (AppE showSize $ VarE x) unit 43 44numInstanceDec :: Name -> Dec 45numInstanceDec name = instanceD [] (instanceType "Num" name) decs 46 where decs = map (binaryFunDec name) ["+", "*", "-"] ++ 47 map (unariFunDec1 name) ["abs", "signum"] ++ 48 [unariFunDec2 name "fromInteger"] 49 50fractionalInstanceDec :: Name -> Dec 51fractionalInstanceDec name = instanceD [] (instanceType "Fractional" name) decs 52 where decs = [binaryFunDec name "/", unariFunDec2 name "fromRational"] 53 54toCssInstanceDec :: Name -> Dec 55toCssInstanceDec name = instanceD [] (instanceType "ToCss" name) [toCssDec] 56 where toCssDec = FunD (mkName "toCss") [Clause [] showBody []] 57 showBody = NormalB $ (AppE dot from) `AppE` ((AppE dot pack) `AppE` show') 58 from = VarE 'fromLazyText 59 pack = VarE 'TL.pack 60 dot = VarE 'Prelude.fmap 61 show' = VarE 'Prelude.show 62 63instanceType :: String -> Name -> Type 64instanceType className name = AppT (ConT $ mkName className) (ConT name) 65 66binaryFunDec :: Name -> String -> Dec 67binaryFunDec name fun' = FunD fun [Clause [pat1, pat2] body []] 68 where pat1 = ConP name [VarP v1] 69 pat2 = ConP name [VarP v2] 70 body = NormalB $ AppE (ConE name) result 71 result = AppE (AppE (VarE fun) (VarE v1)) (VarE v2) 72 fun = mkName fun' 73 v1 = mkName "v1" 74 v2 = mkName "v2" 75 76unariFunDec1 :: Name -> String -> Dec 77unariFunDec1 name fun' = FunD fun [Clause [pat] body []] 78 where pat = ConP name [VarP v] 79 body = NormalB $ AppE (ConE name) (AppE (VarE fun) (VarE v)) 80 fun = mkName fun' 81 v = mkName "v" 82 83unariFunDec2 :: Name -> String -> Dec 84unariFunDec2 name fun' = FunD fun [Clause [pat] body []] 85 where pat = VarP x 86 body = NormalB $ AppE (ConE name) (AppE (VarE fun) (VarE x)) 87 fun = mkName fun' 88 x = mkName "x" 89 90notStrict :: Bang 91notStrict = Bang NoSourceUnpackedness NoSourceStrictness 92 93instanceD :: Cxt -> Type -> [Dec] -> Dec 94instanceD = InstanceD Nothing 95