-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Metrology.TH
-- Copyright   :  (C) 2014 Richard Eisenberg
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Richard Eisenberg (rae@cs.brynmawr.edu)
-- Stability   :  experimental
-- Portability :  non-portable
--
-- This module exports Template Haskell functions to make working with
-- @units@ a little more convenient.
-----------------------------------------------------------------------------

{-# LANGUAGE TemplateHaskell, CPP #-}
{-# OPTIONS_HADDOCK prune #-}

module Data.Metrology.TH (
  evalType,
  declareDimension, declareCanonicalUnit, declareDerivedUnit, declareMonoUnit,
  declareConstant,

  -- for internal use only
  checkIsType
  ) where

import Language.Haskell.TH
import Language.Haskell.TH.Desugar         ( dsType, sweeten )
import Language.Haskell.TH.Desugar.Expand  ( expandUnsoundly )
import Language.Haskell.TH.Desugar.Lift ()   -- need Lift Rational

import Data.Metrology.Dimensions
import Data.Metrology.Units
import Data.Metrology.LCSU
import Data.Metrology.Poly

-- | "Evaluates" a type as far as it can. This is useful, say, in instance
-- declarations:
--
-- > instance Show $(evalType [t| Length |]) where ...
--
-- Without the 'evalType', the instance declaration fails because @Length@
-- mentions type families, which can't be used in instance declarations.
--
-- This function is somewhat experimental, and will likely not work with
-- more polymorphic types. (If it doesn't work, not all of the type families
-- will be evaluated, and the instance declaration will fail. This function
-- should never cause /incorrect/ behavior.)
--
evalType :: Q Type -> Q Type
evalType :: Q Type -> Q Type
evalType Q Type
qty = do
  Type
ty <- Q Type
qty
  DType
dty <- Type -> Q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
  DType
ex_dty <- DType -> Q DType
forall (q :: * -> *) a. (DsMonad q, Data a) => a -> q a
expandUnsoundly DType
dty
    -- NB: No units type families branch on kind variables, so this is safe here.
  Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ DType -> Type
forall th ds. Desugar th ds => ds -> th
sweeten DType
ex_dty

-- Checks to make sure the given name names a /type/, not a /data constructor/.
-- Reports a compile-time error if the name is not a type.
checkIsType :: Name -> Q ()
checkIsType :: Name -> Q ()
checkIsType Name
n = do
  Info
info <- Name -> Q Info
reify Name
n
  case Info
info of
    ClassOpI {} -> Q ()
generic_error
    DataConI {} -> Q ()
datacon_error
    VarI {} -> Q ()
generic_error
    Info
_ -> () -> Q ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    generic_error :: Q ()
generic_error = String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"The name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not describe a type.\n    A type is expected here."
    datacon_error :: Q ()
datacon_error = String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"The name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" describes a data constructor.\n    Did you perhaps mean to say ''" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"? Note the two quotes."

-- | Declare a new dimension of the given name:
--
-- > $(declareDimension "Length")
--
-- produces
--
-- > data Length = Length
-- > instance Dimension Length
declareDimension :: String -> Q [Dec]
declareDimension :: String -> Q [Dec]
declareDimension String
str =
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> Dec
mkEmptyDataD Name
name
#if __GLASGOW_HASKELL__ >= 711
         , Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] (Name -> Type
ConT ''Dimension Type -> Type -> Type
`AppT` Name -> Type
ConT Name
name) []
#else
         , InstanceD [] (ConT ''Dimension `AppT` ConT name) []
#endif
         ]
  where
    name :: Name
name = String -> Name
mkName String
str

-- | Conditionally generates a @Show@ instance
maybeMkShowInstance :: Name -> Maybe String -> Q [Dec]
maybeMkShowInstance :: Name -> Maybe String -> Q [Dec]
maybeMkShowInstance Name
name (Just String
abbrev) =
  [d| instance Show $(return $ ConT name) where { show _ = abbrev } |]
maybeMkShowInstance Name
_ Maybe String
Nothing = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | @declareCanonicalUnit unit_name dim (Just abbrev)@ creates a new
-- canonical unit (that is, it is not defined in terms of other known units)
-- named @unit_name@, measuring dimension @dim@. @abbrev@ will be the
-- abbreviation in the unit's @Show@ instance. If no abbraviation is supplied,
-- then no @Show@ instance will be generated.
--
-- Example usage:
--
-- > $(declareCanonicalUnit "Meter" [t| Length |] (Just "m"))
declareCanonicalUnit :: String -> Q Type -> Maybe String -> Q [Dec]
declareCanonicalUnit :: String -> Q Type -> Maybe String -> Q [Dec]
declareCanonicalUnit String
unit_name_str Q Type
dim Maybe String
m_abbrev = do
  [Dec]
show_instance <- Name -> Maybe String -> Q [Dec]
maybeMkShowInstance Name
unit_name Maybe String
m_abbrev
  [Dec]
unit_instance <- [d| instance Unit $unit_type where
                         type BaseUnit $unit_type = Canonical
                         type DimOfUnit $unit_type = $dim |]
  [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
$ (Name -> Dec
mkEmptyDataD Name
unit_name)
           Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
unit_instance [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
show_instance
  where
    unit_name :: Name
unit_name = String -> Name
mkName String
unit_name_str
    unit_type :: Q Type
unit_type = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
unit_name

-- | @declareDerivedUnit unit_name base_unit_type ratio (Just abbrev)@ creates
-- a new derived unit, expressed in terms of @base_unit_type@. @ratio@ says
-- how many base units are in the derived unit. (Thus, if @unit_name@ is
-- @"Minute"@ and @base_unit_type@ is @''Second@, then @ratio@ would be @60@.)
-- @abbrev@, if supplied, becomes the string produced in the derived unit's
-- @Show@ instance. If no abbreviation is supplied, no @Show@ instance is
-- generated.
--
-- Example usage:
--
-- > $(declareDerivedUnit "Minute" [t| Second |] 60 (Just "min"))
declareDerivedUnit :: String -> Q Type -> Rational -> Maybe String -> Q [Dec]
declareDerivedUnit :: String -> Q Type -> Rational -> Maybe String -> Q [Dec]
declareDerivedUnit String
unit_name_str Q Type
base_unit Rational
ratio Maybe String
m_abbrev = do
  [Dec]
show_instance <- Name -> Maybe String -> Q [Dec]
maybeMkShowInstance Name
unit_name Maybe String
m_abbrev
  [Dec]
unit_instance <- [d| instance Unit $unit_type where
                         type BaseUnit $unit_type = $base_unit
                         conversionRatio _ = ratio |]
  [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
$ (Name -> Dec
mkEmptyDataD Name
unit_name)
           Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
unit_instance [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
show_instance
  where
    unit_name :: Name
unit_name = String -> Name
mkName String
unit_name_str
    unit_type :: Q Type
unit_type = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
unit_name

-- | @declareMonoUnit unit_name (Just abbrev)@ creates a new derived unit,
-- intended for use without unit polymorphism. The same type stands for both
-- the unit and dimension, and the instance of 'DefaultUnitOfDim' is set up
-- accordingly. Use this function (with the 'Data.Metrology' imports) if you
-- don't want to bother with LCSUs and just want to get to work. The @abbrev@,
-- if supplied, creates an appropriate @Show@ instance.
--
-- > $(declareMonoUnit "Meter" (Just "m"))
--
-- produces all of the following
--
-- > data Meter = Meter
-- > instance Dimension Meter
-- > instance Unit Meter where
-- >   type BaseUnit Meter = Canonical
-- >   type DimOfUnit Meter = Meter
-- > type instance DefaultUnitOfDim Meter = Meter
-- > instance Show Meter where
-- >   show _ = "m"
--
-- After a declaration like this, you probably want
--
-- > type Length = MkQu_U Meter
--
-- This last line is /not/ generated, as it is easy enough for you to write,
-- and it involves a new name (@Length@).
declareMonoUnit :: String -> Maybe String -> Q [Dec]
declareMonoUnit :: String -> Maybe String -> Q [Dec]
declareMonoUnit String
unit_name_str Maybe String
m_abbrev = do
  [Dec]
show_instance <- Name -> Maybe String -> Q [Dec]
maybeMkShowInstance Name
unit_name Maybe String
m_abbrev
  [Dec]
dim_instance <- [d| instance Dimension $unit_type |]
  [Dec]
unit_instance <- [d| instance Unit $unit_type where
                         type BaseUnit $unit_type = Canonical
                         type DimOfUnit $unit_type = $unit_type |]
  [Dec]
default_instance <- [d| type instance DefaultUnitOfDim $unit_type = $unit_type |]
  [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
$ (Name -> Dec
mkEmptyDataD Name
unit_name)
           Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
show_instance [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
dim_instance [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
unit_instance [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
default_instance
  where
    unit_name :: Name
unit_name = String -> Name
mkName String
unit_name_str
    unit_type :: Q Type
unit_type = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
unit_name

-- | @declareConstant const_name value unit_type@ creates a new numerical
-- constant, named @const_name@. Its numerical value is @value@ expressed
-- in units given by @unit_type@. The constant is polymorphic in both its
-- LCSU and numerical representation. For example,
--
-- > declareConstant "gravity_g" 9.80665 [t| Meter :/ Second :^ Two |]
--
-- yields
--
-- > gravity_g :: forall lcsu n.
-- >              ( Fractional n
-- >              , CompatibleUnit lcsu (Meter :/ Second :^ Two) )
-- >           => MkQu_ULN (Meter :/ Second :^ Two) lcsu n
-- > gravity_g = 9.80665 % (undefined :: Meter :/ Second :^ Two)
declareConstant :: String -> Rational -> Q Type -> Q [Dec]
declareConstant :: String -> Rational -> Q Type -> Q [Dec]
declareConstant String
name Rational
value Q Type
q_unit_type = do
  Type
unit_type <- Q Type
q_unit_type
  Name
lcsu_name <- String -> Q Name
newName String
"lcsu"
  Name
n_name <- String -> Q Name
newName String
"n"
  let lcsu :: Type
lcsu = Name -> Type
VarT Name
lcsu_name
      n :: Type
n    = Name -> Type
VarT Name
n_name
      const_name :: Name
const_name = String -> Name
mkName String
name
      const_type :: Type
const_type =
#if __GLASGOW_HASKELL__ >= 900
                   ForallT [PlainTV lcsu_name SpecifiedSpec, PlainTV n_name SpecifiedSpec]
#else
                   [TyVarBndr] -> Cxt -> Type -> Type
ForallT [Name -> TyVarBndr
PlainTV Name
lcsu_name, Name -> TyVarBndr
PlainTV Name
n_name]
#endif
                           [ Name -> Cxt -> Type
forall (t :: * -> *). Foldable t => Name -> t Type -> Type
mkClassP ''Fractional [Type
n]
                           , Name -> Cxt -> Type
forall (t :: * -> *). Foldable t => Name -> t Type -> Type
mkClassP ''CompatibleUnit [Type
lcsu, Type
unit_type] ] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                   Name -> Type
ConT ''MkQu_ULN Type -> Type -> Type
`AppT` Type
unit_type Type -> Type -> Type
`AppT` Type
lcsu Type -> Type -> Type
`AppT` Type
n
      ty_sig :: Dec
ty_sig = Name -> Type -> Dec
SigD Name
const_name Type
const_type
      dec :: Dec
dec    = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
const_name) (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
                                       Name -> Exp
VarE '(%) Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (Rational -> Lit
RationalL Rational
value)
                                                 Exp -> Exp -> Exp
`AppE` Exp -> Type -> Exp
SigE (Name -> Exp
VarE 'undefined)
                                                             Type
unit_type) []
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
ty_sig, Dec
dec]
  where
#if __GLASGOW_HASKELL__ < 709
    mkClassP = ClassP
#else
    mkClassP :: Name -> t Type -> Type
mkClassP Name
n t Type
tys = (Type -> Type -> Type) -> Type -> t Type -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
n) t Type
tys
#endif

-- Make a DataD like `data <name> = <name>`.
mkEmptyDataD :: Name -> Dec
mkEmptyDataD :: Name -> Dec
mkEmptyDataD Name
name
#if __GLASGOW_HASKELL__ >= 801
  = Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name [] Maybe Type
forall a. Maybe a
Nothing [Con
con] []
#elif __GLASGOW_HASKELL__ >= 711
  = DataD [] name [] Nothing [con] []
#else
  = DataD [] name [] [con] []
#endif
  where
    con :: Con
con = Name -> [BangType] -> Con
NormalC Name
name []