{-# LANGUAGE TemplateHaskell #-}


--------------------------------------------------------------------------------

-- |

--

-- Module      :  Data.Units.Base.TH

-- Description :  Template Haskell quasi quoter for unit declaration

-- Copyright   :  (c) Alice Rixte 2025

-- License     :  BSD 3

-- Maintainer  :  alice.rixte@u-bordeaux.fr

-- Stability   :  unstable

-- Portability :  non-portable (GHC extensions)

--

--------------------------------------------------------------------------------



module Data.Units.Base.TH
  ( -- * Units

    mkUnit
  , mkUnitNoFactor
  , mkBaseUnit
  -- * Dimensions

  , mkDim
  -- * Prefixes

  , mkPrefix
  )
  where

import GHC.TypeError

import Language.Haskell.TH

import Data.Type.Int
import Data.Units.Base.System
import Data.Units.Base.Convert
import Data.Units.Base.Prefix

------------------------------------ Units -------------------------------------


-- | List of derived class for a unit.

--

deriveList :: [Name]
deriveList :: [Name]
deriveList =
  [''Eq
  , ''Ord
  , ''Num
  , ''Fractional
  , ''Floating
  , ''Real
  , ''RealFrac
  , ''RealFloat
  ]

-- | List of derived classes for a unit.

--

deriveListUnit :: [Name]
deriveListUnit :: [Name]
deriveListUnit = ''Show Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
deriveList

-- | Make a newtype of the form

--

-- @

-- newtype Minute a = Minute a

--   deriving ( Show, Eq, Ord, Num, Fractional, Floating, Real

--            , RealFrac, RealFloat)

-- @

--

mkUnitNewtype :: Quote m
  => [Name] -> Name -> m Dec
mkUnitNewtype :: forall (m :: * -> *). Quote m => [Name] -> Name -> m Dec
mkUnitNewtype [Name]
l Name
unitName =
  let a :: m Type
a = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (String -> Name
mkName String
"a") in
  m Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> m Con
-> [m DerivClause]
-> m Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> m Con
-> [m DerivClause]
-> m Dec
newtypeD
    ([m Type] -> m Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
    Name
unitName
    [Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
PlainTV (String -> Name
mkName String
"a") BndrVis
BndrReq]
    Maybe Type
forall a. Maybe a
Nothing
    (Name -> [m BangType] -> m Con
forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC Name
unitName
      [m Bang -> m Type -> m BangType
forall (m :: * -> *). Quote m => m Bang -> m Type -> m BangType
bangType (m SourceUnpackedness -> m SourceStrictness -> m Bang
forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang m SourceUnpackedness
forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness m SourceStrictness
forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness) m Type
a])
    [ Maybe DerivStrategy -> [m Type] -> m DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Type] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> m Type) -> [Name] -> [m Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
l)]

-- | Make instance of the form

--

-- @

-- instance IsUnit Hour where

--   type DimOf Hour = Time

-- @

--

mkIsUnitInstance :: Quote m => Name -> Name -> m [Dec]
mkIsUnitInstance :: forall (m :: * -> *). Quote m => Name -> Name -> m [Dec]
mkIsUnitInstance Name
unitName Name
dimName = [d|
  instance IsUnit $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
unitName) where
    type DimOf $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
unitName) = $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
dimName)
  |]

-- | Make an instance of the form

--

-- @

-- instance ShowUnit Minute where

--   type ShowUnitType Minute = Text "min"

--   showUnit = "Minute"

--   prettyUnit = "min"

-- @

--

mkShowUnitInstance :: Quote m => Name -> String -> String -> m [Dec]
mkShowUnitInstance :: forall (m :: * -> *).
Quote m =>
Name -> String -> String -> m [Dec]
mkShowUnitInstance Name
unitName String
unitStr String
prettyStr = [d|
  instance ShowUnit $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
unitName) where
    type ShowUnitType $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
unitName) = Text $(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyLit -> Type
LitT (String -> TyLit
StrTyLit String
prettyStr)))
    showUnit  = $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL String
unitStr))
    prettyUnit = $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL String
prettyStr))
  |]


-- | Make an instance of the form

--

-- @

-- instance Fractional a => ConversionFactor Minute a where

--    factor = 60

-- @

--

mkConvFactorInstance :: Quote m => Name -> Rational -> m [Dec]
mkConvFactorInstance :: forall (m :: * -> *). Quote m => Name -> Rational -> m [Dec]
mkConvFactorInstance Name
unitName Rational
fctr = [d|
  instance Fractional a => ConversionFactor $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
unitName) a where
    factor = $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Rational -> Lit
RationalL Rational
fctr))
  |]


-- | Make an instance of the form

--

-- @

-- instance Fractional a => ConvertibleUnit Minute a

-- @

--

mkDefaultSigConvertibleInstance :: Quote m => Name -> m [Dec]
mkDefaultSigConvertibleInstance :: forall (m :: * -> *). Quote m => Name -> m [Dec]
mkDefaultSigConvertibleInstance Name
unitName = [d|
  instance Fractional a => ConvertibleUnit $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
unitName) a
  |]

-- | Make an instance of the form

--

-- @

-- instance Fractional a => ConvertibleUnit Meter a where

--    toBaseUnit = coerce

--    {-# INLINE toBaseUnit #-}

--    fromBaseUnit = coerce

--    {-# INLINE fromBaseUnit #-}

-- @

--

mkNormalConvertibleInstance :: Quote m => Name -> m [Dec]
mkNormalConvertibleInstance :: forall (m :: * -> *). Quote m => Name -> m [Dec]
mkNormalConvertibleInstance Name
unitName = [d|
  instance Fractional a => ConvertibleUnit $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
unitName) a where
    toBaseUnit = coerce
    {-# INLINE toBaseUnit #-}
    fromBaseUnit = coerce
    {-# INLINE fromBaseUnit #-}
  |]


-- | Make a unit that can be converted via a factor

--

-- [Usage:]

--

-- @

-- \$(mkUnit "Minute" "min" ''Time 60)

-- @

--

mkUnit :: String -> String -> Name -> Rational -> Q [Dec]
mkUnit :: String -> String -> Name -> Rational -> Q [Dec]
mkUnit String
unitStr String
prettyStr Name
dimName Rational
fctr = do
  let unitName :: Name
unitName = String -> Name
mkName String
unitStr
  Dec
newtypeDec <- [Name] -> Name -> Q Dec
forall (m :: * -> *). Quote m => [Name] -> Name -> m Dec
mkUnitNewtype [Name]
deriveListUnit Name
unitName
  [Dec]
isUnitDec <- Name -> Name -> Q [Dec]
forall (m :: * -> *). Quote m => Name -> Name -> m [Dec]
mkIsUnitInstance Name
unitName Name
dimName
  [Dec]
showUnitDec <- Name -> String -> String -> Q [Dec]
forall (m :: * -> *).
Quote m =>
Name -> String -> String -> m [Dec]
mkShowUnitInstance Name
unitName String
unitStr String
prettyStr
  [Dec]
convFactorDec <- Name -> Rational -> Q [Dec]
forall (m :: * -> *). Quote m => Name -> Rational -> m [Dec]
mkConvFactorInstance Name
unitName Rational
fctr
  [Dec]
convUnitDec <-
    if Rational
fctr Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
1 then
      Name -> Q [Dec]
forall (m :: * -> *). Quote m => Name -> m [Dec]
mkNormalConvertibleInstance Name
unitName
    else
      Name -> Q [Dec]
forall (m :: * -> *). Quote m => Name -> m [Dec]
mkDefaultSigConvertibleInstance Name
unitName
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    [Dec
newtypeDec] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
isUnitDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
showUnitDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
convFactorDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
convUnitDec

-- | Make a unit without declaring any conversion instances.

--

-- Conversion instances must be added by hand.

--

-- [Usage:]

--

-- @

-- \$(mkUnit \"Bel\" "B" ''NoUnit )

-- @

--

mkUnitNoFactor :: String -> String -> Name -> Q [Dec]
mkUnitNoFactor :: String -> String -> Name -> Q [Dec]
mkUnitNoFactor String
unitStr String
prettyStr Name
dimName = do
  let unitName :: Name
unitName = String -> Name
mkName String
unitStr
  Dec
newtypeDec  <- [Name] -> Name -> Q Dec
forall (m :: * -> *). Quote m => [Name] -> Name -> m Dec
mkUnitNewtype [Name]
deriveListUnit Name
unitName
  [Dec]
isUnitDec  <- Name -> Name -> Q [Dec]
forall (m :: * -> *). Quote m => Name -> Name -> m [Dec]
mkIsUnitInstance Name
unitName Name
dimName
  [Dec]
showUnitDec  <- Name -> String -> String -> Q [Dec]
forall (m :: * -> *).
Quote m =>
Name -> String -> String -> m [Dec]
mkShowUnitInstance Name
unitName String
unitStr String
prettyStr
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec
newtypeDec] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++  [Dec]
isUnitDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
showUnitDec


-- | Make a base unit.

--

-- In addition to calling 'mkUnit' with factor 1, this also makes an

-- instance of 'IsDim', which cannot be done in 'mkDim' since the base unit is

-- not yet declared.

--

-- [Usage:]

--

-- @ \$(mkBaseUnit "Second" "s" ''Time ) @

--

mkBaseUnit :: String -> String -> Name -> Q [Dec]
mkBaseUnit :: String -> String -> Name -> Q [Dec]
mkBaseUnit String
unitStr String
prettyStr Name
dimName = do
  let unitName :: Name
unitName = String -> Name
mkName String
unitStr
  [Dec]
unitDec <- String -> String -> Name -> Rational -> Q [Dec]
mkUnit String
unitStr String
prettyStr Name
dimName Rational
1
  [Dec]
isDimDec <- Name -> Name -> Q [Dec]
forall (m :: * -> *). Quote m => Name -> Name -> m [Dec]
mkIsDimInstance Name
dimName Name
unitName
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
unitDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
isDimDec

---------------------------------- Dimensions ----------------------------------


-- | List of derived classes for a dimension.

--

deriveListDim :: [Name]
deriveListDim :: [Name]
deriveListDim = [Name]
deriveListUnit


mkDimNewtype :: Quote m
  => [Name] -> Name -> m Dec
mkDimNewtype :: forall (m :: * -> *). Quote m => [Name] -> Name -> m Dec
mkDimNewtype = [Name] -> Name -> m Dec
forall (m :: * -> *). Quote m => [Name] -> Name -> m Dec
mkUnitNewtype

-- | Make an instance of the form

--

-- @

-- instance IsDim Time where

--   type DimToUnit Time = Second

-- @

--

mkIsDimInstance :: Quote m => Name -> Name -> m [Dec]
mkIsDimInstance :: forall (m :: * -> *). Quote m => Name -> Name -> m [Dec]
mkIsDimInstance Name
dimName Name
unitName = [d|
  instance IsDim $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
dimName) where
    type DimToUnit $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
dimName) = $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
unitName)
  |]

-- | Make a type instance of the form

--

-- @

-- type instance DimId Time = 400

-- @

--

mkDimIdTypeInstance :: Quote m => Name -> Integer -> m [Dec]
mkDimIdTypeInstance :: forall (m :: * -> *). Quote m => Name -> Integer -> m [Dec]
mkDimIdTypeInstance Name
dimName Integer
n = [d|
  type instance DimId $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
dimName) = Pos $(m TyLit -> m Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Integer -> m TyLit
forall (m :: * -> *). Quote m => Integer -> m TyLit
numTyLit Integer
n))
  |]

-- | Make a type instance of the form

--

-- @

-- instance ShowDim Minute where

--   type ShowDimType Minute = Text "min"

--   showDim = "Minute"

--   prettyDim = "min"

-- @

--

mkShowDimInstance :: Quote m => Name -> String -> String -> m [Dec]
mkShowDimInstance :: forall (m :: * -> *).
Quote m =>
Name -> String -> String -> m [Dec]
mkShowDimInstance Name
dimName String
dimStr String
prettyStr = [d|
  instance ShowDim $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
dimName) where
    type ShowDimType $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
dimName) = Text $(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyLit -> Type
LitT (String -> TyLit
StrTyLit String
prettyStr)))
    showDim  = $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL String
dimStr))
    prettyDim = $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL String
prettyStr))
  |]

-- | Make a dimension.

--

-- This will not declare an instance for 'IsDim', which is instead declared

-- using 'mkBaseUnit'.


-- [Usage:]

--

-- @ \$(mkDim "Time" "T" 400) @

--

mkDim :: String -> String -> Integer -> Q [Dec]
mkDim :: String -> String -> Integer -> Q [Dec]
mkDim String
dimStr String
prettyStr Integer
n = do
  let dimName :: Name
dimName = String -> Name
mkName String
dimStr
  Dec
newtypeDec <- [Name] -> Name -> Q Dec
forall (m :: * -> *). Quote m => [Name] -> Name -> m Dec
mkDimNewtype [Name]
deriveListDim Name
dimName
  -- isDimDec <- mkIsDimInstance dimName unitName

  [Dec]
dimIdDec <- Name -> Integer -> Q [Dec]
forall (m :: * -> *). Quote m => Name -> Integer -> m [Dec]
mkDimIdTypeInstance Name
dimName Integer
n
  [Dec]
showDimDec <- Name -> String -> String -> Q [Dec]
forall (m :: * -> *).
Quote m =>
Name -> String -> String -> m [Dec]
mkShowDimInstance Name
dimName String
dimStr String
prettyStr
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec
newtypeDec]  [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
dimIdDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
showDimDec



----------------------------------- Prefixes -----------------------------------




-- | Make a newtype of the form:

--

-- @

-- newtype Milli (u :: Unit) a = Milli (u a)

--   deriving (Eq, Ord, Num, Fractional, Floating, Real

--            , RealFrac, RealFloat, Functor)

--   deriving Show via MetaPrefix Milli u a

--   deriving ShowUnit via MetaPrefix Milli u

-- @

--

mkPrefixNewtype :: Monad m => [Name] -> Name -> m Dec
mkPrefixNewtype :: forall (m :: * -> *). Monad m => [Name] -> Name -> m Dec
mkPrefixNewtype [Name]
l Name
prefixName = Dec -> m Dec
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> m Dec) -> Dec -> m Dec
forall a b. (a -> b) -> a -> b
$
  Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeD
    []
    Name
prefixName
    [ Name -> BndrVis -> Type -> TyVarBndr BndrVis
forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV (String -> Name
mkName String
"u") BndrVis
BndrReq (Name -> Type
ConT ''Unit)
    , Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
PlainTV  (String -> Name
mkName String
"a") BndrVis
BndrReq
    ]
    Maybe Type
forall a. Maybe a
Nothing
    (Name -> [BangType] -> Con
NormalC Name
prefixName
      [ ( SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
        , Type -> Type -> Type
AppT (Name -> Type
VarT (String -> Name
mkName String
"u")) (Name -> Type
VarT (String -> Name
mkName String
"a"))
        )
      ])
    [ Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause
        (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
NewtypeStrategy)
        ((Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
ConT [Name]
l)
    , Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause
        (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just (Type -> DerivStrategy
ViaStrategy Type
viaType))
        [Name -> Type
ConT ''Show]
    , Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause
        (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just (Type -> DerivStrategy
ViaStrategy Type
viaTypeNoA))
        [Name -> Type
ConT ''ShowUnit]
    ]
  where
    viaType :: Type
viaType =
      (Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT ''MetaPrefix)
        [ Name -> Type
ConT Name
prefixName
        , Name -> Type
VarT (String -> Name
mkName String
"u")
        , Name -> Type
VarT (String -> Name
mkName String
"a")
        ]

    viaTypeNoA :: Type
viaTypeNoA =
      (Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT ''MetaPrefix)
        [ Name -> Type
ConT Name
prefixName
        , Name -> Type
VarT (String -> Name
mkName String
"u")
        ]

-- | Make a deriving instance of the form

--

-- @

-- deriving via MetaPrefix Milli u instance IsUnit u => IsUnit (Milli u )

-- @

--

mkPrefixIsUnitInstance :: Name -> Q [Dec]
mkPrefixIsUnitInstance :: Name -> Q [Dec]
mkPrefixIsUnitInstance Name
prefixName = [d|
  deriving via MetaPrefix $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
prefixName) u instance IsUnit u => IsUnit ($(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
prefixName)  u)
  |]

-- | Make an instance of the form

--

-- @

-- instance ShowPrefix Milli where

--    type ShowPrefixType Milli = Text "m"

--    showPrefix = "Milli"

--    prettyPrefix = "m"

-- @

--

mkShowPrefixInstance :: Quote m => Name -> String -> String -> m [Dec]
mkShowPrefixInstance :: forall (m :: * -> *).
Quote m =>
Name -> String -> String -> m [Dec]
mkShowPrefixInstance Name
prefixName String
prefixStr String
prettyStr = [d|
  instance ShowPrefix $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
prefixName) where
    type ShowPrefixType $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
prefixName) = Text $(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyLit -> Type
LitT (String -> TyLit
StrTyLit String
prettyStr)))
    showPrefix = $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL String
prefixStr))
    prettyPrefix = $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL String
prettyStr))
  |]

-- | Make an instance of the form

--

-- @

-- instance Fractional a => PrefixFactor Kilo a where

--   prefixFactor = 1000

--   {-# INLINE prefixFactor #-}

--

mkPrefixFactorInstance :: Name -> Rational -> Q [Dec]
mkPrefixFactorInstance :: Name -> Rational -> Q [Dec]
mkPrefixFactorInstance Name
prefixName Rational
fctr = [d|
  instance Fractional a => PrefixFactor $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
prefixName) a where
    prefixFactor = $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Rational -> Lit
RationalL Rational
fctr))
    {-# INLINE prefixFactor #-}
  |]

-- | Make an instance of the form

--

-- @

-- instance ConversionFactor u a => ConversionFactor (Milli u) a where

--   factor = factor @(MetaPrefix Milli u)

--   {-# INLINE factor #-}

-- @

--

mkPrefixConvFactorInstance :: Name -> Q [Dec]
mkPrefixConvFactorInstance :: Name -> Q [Dec]
mkPrefixConvFactorInstance Name
prefixName = [d|
  instance ConversionFactor u a => ConversionFactor ($(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
prefixName) u) a where
    factor = factor @(MetaPrefix $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
prefixName) u)
    {-# INLINE factor #-}
  |]

-- | Make an instance of the form

--

-- @

-- instance (ConvertibleUnit u a, Fractional a)

--   => ConvertibleUnit (Milli u) a where

--   toBaseUnit = prefixToBaseUnit

--   {-# INLINE toBaseUnit #-}

--   fromBaseUnit = prefixFromBaseUnit

--   {-# INLINE fromBaseUnit #-}

-- @

--

mkPrefixConvUnitInstance :: Name -> Q [Dec]
mkPrefixConvUnitInstance :: Name -> Q [Dec]
mkPrefixConvUnitInstance Name
prefixName = [d|
  instance (ConvertibleUnit u a, Fractional a)
    => ConvertibleUnit ($(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
prefixName) u) a where
    toBaseUnit = prefixToBaseUnit
    {-# INLINE toBaseUnit #-}
    fromBaseUnit = prefixFromBaseUnit
    {-# INLINE fromBaseUnit #-}
  |]

-- | Make a unit prefix.

--

-- [Usage:]

--

-- @

-- \$(mkPrefix "Kilo" "k" 1000)

-- @

--

mkPrefix :: String -> String -> Rational -> Q [Dec]
mkPrefix :: String -> String -> Rational -> Q [Dec]
mkPrefix String
prefixStr String
prettyStr Rational
fctr = do
  let prefixName :: Name
prefixName = String -> Name
mkName String
prefixStr
  Dec
newtypeDec <- [Name] -> Name -> Q Dec
forall (m :: * -> *). Monad m => [Name] -> Name -> m Dec
mkPrefixNewtype [Name]
deriveList Name
prefixName
  [Dec]
isUnitDec <- Name -> Q [Dec]
mkPrefixIsUnitInstance Name
prefixName
  [Dec]
showPrefixDec <- Name -> String -> String -> Q [Dec]
forall (m :: * -> *).
Quote m =>
Name -> String -> String -> m [Dec]
mkShowPrefixInstance Name
prefixName String
prefixStr String
prettyStr
  [Dec]
factorDec <- Name -> Rational -> Q [Dec]
mkPrefixFactorInstance Name
prefixName Rational
fctr
  [Dec]
convFactorDec <- Name -> Q [Dec]
mkPrefixConvFactorInstance Name
prefixName
  [Dec]
convUnitDec <- Name -> Q [Dec]
mkPrefixConvUnitInstance Name
prefixName
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec
newtypeDec] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
isUnitDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
showPrefixDec
        [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
factorDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
convFactorDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
convUnitDec