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