{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Internal functions to generate CSS size wrapper types.
module Text.MkSizeType (mkSizeType) where

#if !MIN_VERSION_template_haskell(2,12,0)
import Language.Haskell.TH (conT)
#endif
import Language.Haskell.TH.Syntax
import Data.Text.Lazy.Builder (fromLazyText)
import qualified Data.Text.Lazy as TL

mkSizeType :: String -> String -> Q [Dec]
mkSizeType :: String -> String -> Q [Dec]
mkSizeType String
name' String
unit = do
    Dec
ddn <- Name -> Q Dec
dataDec Name
name
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return  [ Dec
ddn
            , Name -> String -> Dec
showInstanceDec Name
name String
unit
            , Name -> Dec
numInstanceDec Name
name
            , Name -> Dec
fractionalInstanceDec Name
name
            , Name -> Dec
toCssInstanceDec Name
name ]
  where name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
name'

dataDec :: Name -> Q Dec
dataDec :: Name -> Q Dec
dataDec Name
name =
#if MIN_VERSION_template_haskell(2,12,0)
  Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
    Cxt
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name [] Maybe Kind
forall a. Maybe a
Nothing [Con
constructor] [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
ConT [Name]
derives)]
#else
  DataD [] name [] Nothing [constructor] <$> mapM conT derives
#endif
  where constructor :: Con
constructor = Name -> [BangType] -> Con
NormalC Name
name [(Bang
notStrict, Name -> Kind
ConT (Name -> Kind) -> Name -> Kind
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Rational")]
        derives :: [Name]
derives = (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map String -> Name
mkName [String
"Eq", String
"Ord"]

showInstanceDec :: Name -> String -> Dec
showInstanceDec :: Name -> String -> Dec
showInstanceDec Name
name String
unit' = Cxt -> Kind -> [Dec] -> Dec
instanceD [] (String -> Name -> Kind
instanceType String
"Show" Name
name) [Dec
showDec]
  where showSize :: Exp
showSize = Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"showSize"
        x :: Name
x = String -> Name
mkName String
"x"
        unit :: Exp
unit = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
unit'
        showDec :: Dec
showDec = Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"show") [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
showPat] Body
showBody []]
        showPat :: Pat
showPat = Name -> [Pat] -> Pat
conP Name
name [Name -> Pat
VarP Name
x]
        showBody :: Body
showBody = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE Exp
showSize (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
x) Exp
unit

numInstanceDec :: Name -> Dec
numInstanceDec :: Name -> Dec
numInstanceDec Name
name = Cxt -> Kind -> [Dec] -> Dec
instanceD [] (String -> Name -> Kind
instanceType String
"Num" Name
name) [Dec]
decs
  where decs :: [Dec]
decs = (String -> Dec) -> [String] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> String -> Dec
binaryFunDec Name
name) [String
"+", String
"*", String
"-"] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
               (String -> Dec) -> [String] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> String -> Dec
unariFunDec1 Name
name) [String
"abs", String
"signum"] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
               [Name -> String -> Dec
unariFunDec2 Name
name String
"fromInteger"]

fractionalInstanceDec :: Name -> Dec
fractionalInstanceDec :: Name -> Dec
fractionalInstanceDec Name
name = Cxt -> Kind -> [Dec] -> Dec
instanceD [] (String -> Name -> Kind
instanceType String
"Fractional" Name
name) [Dec]
decs
  where decs :: [Dec]
decs = [Name -> String -> Dec
binaryFunDec Name
name String
"/", Name -> String -> Dec
unariFunDec2 Name
name String
"fromRational"]

toCssInstanceDec :: Name -> Dec
toCssInstanceDec :: Name -> Dec
toCssInstanceDec Name
name = Cxt -> Kind -> [Dec] -> Dec
instanceD [] (String -> Name -> Kind
instanceType String
"ToCss" Name
name) [Dec
toCssDec]
  where toCssDec :: Dec
toCssDec = Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"toCss") [[Pat] -> Body -> [Dec] -> Clause
Clause [] Body
showBody []]
        showBody :: Body
showBody = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp
AppE Exp
dot Exp
from) Exp -> Exp -> Exp
`AppE` ((Exp -> Exp -> Exp
AppE Exp
dot Exp
pack) Exp -> Exp -> Exp
`AppE` Exp
show')
        from :: Exp
from = Name -> Exp
VarE 'fromLazyText
        pack :: Exp
pack = Name -> Exp
VarE 'TL.pack
        dot :: Exp
dot = Name -> Exp
VarE 'Prelude.fmap
        show' :: Exp
show' = Name -> Exp
VarE 'Prelude.show

instanceType :: String -> Name -> Type
instanceType :: String -> Name -> Kind
instanceType String
className Name
name = Kind -> Kind -> Kind
AppT (Name -> Kind
ConT (Name -> Kind) -> Name -> Kind
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
className) (Name -> Kind
ConT Name
name)

binaryFunDec :: Name -> String -> Dec
binaryFunDec :: Name -> String -> Dec
binaryFunDec Name
name String
fun' = Name -> [Clause] -> Dec
FunD Name
fun [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat1, Pat
pat2] Body
body []]
  where pat1 :: Pat
pat1 = Name -> [Pat] -> Pat
conP Name
name [Name -> Pat
VarP Name
v1]
        pat2 :: Pat
pat2 = Name -> [Pat] -> Pat
conP Name
name [Name -> Pat
VarP Name
v2]
        body :: Body
body = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
name) Exp
result
        result :: Exp
result = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
fun) (Name -> Exp
VarE Name
v1)) (Name -> Exp
VarE Name
v2)
        fun :: Name
fun = String -> Name
mkName String
fun'
        v1 :: Name
v1 = String -> Name
mkName String
"v1"
        v2 :: Name
v2 = String -> Name
mkName String
"v2"

unariFunDec1 :: Name -> String -> Dec
unariFunDec1 :: Name -> String -> Dec
unariFunDec1 Name
name String
fun' = Name -> [Clause] -> Dec
FunD Name
fun [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] Body
body []]
  where pat :: Pat
pat = Name -> [Pat] -> Pat
conP Name
name [Name -> Pat
VarP Name
v]
        body :: Body
body = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
name) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
fun) (Name -> Exp
VarE Name
v))
        fun :: Name
fun = String -> Name
mkName String
fun'
        v :: Name
v = String -> Name
mkName String
"v"

unariFunDec2 :: Name -> String -> Dec
unariFunDec2 :: Name -> String -> Dec
unariFunDec2 Name
name String
fun' = Name -> [Clause] -> Dec
FunD Name
fun [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] Body
body []]
  where pat :: Pat
pat = Name -> Pat
VarP Name
x
        body :: Body
body = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
name) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
fun) (Name -> Exp
VarE Name
x))
        fun :: Name
fun = String -> Name
mkName String
fun'
        x :: Name
x = String -> Name
mkName String
"x"

notStrict :: Bang
notStrict :: Bang
notStrict = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness

instanceD :: Cxt -> Type -> [Dec] -> Dec
instanceD :: Cxt -> Kind -> [Dec] -> Dec
instanceD = Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing

conP :: Name -> [Pat] -> Pat
#if MIN_VERSION_template_haskell(2,18,0)
conP name = ConP name []
#else
conP :: Name -> [Pat] -> Pat
conP = Name -> [Pat] -> Pat
ConP
#endif