TH.hs

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

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

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

  -- for internal use only
  checkIsType                                    
  ) where

import Language.Haskell.TH
import Language.Haskell.TH.Desugar
import Language.Haskell.TH.Desugar.Expand
import Language.Haskell.TH.Desugar.Lift ()   -- need Lift Rational

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

-- | "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 qty = do
  ty <- qty
  dty <- dsType ty
  ex_dty <- expandType dty
  return $ sweeten 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 n = do
  info <- reify n
  case info of
    ClassOpI {} -> generic_error
    DataConI {} -> datacon_error
    VarI {} -> generic_error
    _ -> return ()
  where
    generic_error = reportError $ "The name " ++ show n ++ " does not describe a type.\n    A type is expected here."
    datacon_error = reportError $ "The name " ++ show n ++ " describes a data constructor.\n    Did you perhaps mean to say ''" ++ nameBase n ++ "? 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 str =
  return [ DataD [] name [] [NormalC name []] []
         , InstanceD [] (ConT ''Dimension `AppT` ConT name) [] ]
  where
    name = mkName str

-- | Conditionally generates a @Show@ instance
maybeMkShowInstance :: Name -> Maybe String -> Q [Dec]
maybeMkShowInstance name (Just abbrev) =
  [d| instance Show $(return $ ConT name) where { show _ = abbrev } |]
maybeMkShowInstance _ Nothing = 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@. (@dim@ must be the name of
-- the dimension /type/, not /data constructor/.) @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" ''Length (Just "m"))
declareCanonicalUnit :: String -> Name -> Maybe String -> Q [Dec]
declareCanonicalUnit unit_name_str dim m_abbrev = do
  checkIsType dim
  show_instance <- maybeMkShowInstance unit_name m_abbrev
  unit_instance <- [d| instance Unit $unit_type where
                         type BaseUnit $unit_type = Canonical
                         type DimOfUnit $unit_type = $dim_type |]
  return $ (DataD [] unit_name [] [NormalC unit_name []] [])
           : unit_instance ++ show_instance
  where
    unit_name = mkName unit_name_str
    unit_type = return $ ConT unit_name
    dim_type = return $ ConT dim

-- | @declareDerivedUnit unit_name base_unit_type ratio (Just abbrev)@ creates
-- a new derived unit, expressed in terms of @base_unit_type@ (which must be the
-- name of a /type/ not a /data constructor/). @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" ''Second 60 (Just "min"))
declareDerivedUnit :: String -> Name -> Rational -> Maybe String -> Q [Dec]
declareDerivedUnit unit_name_str base_unit ratio m_abbrev = do
  checkIsType base_unit
  show_instance <- maybeMkShowInstance unit_name m_abbrev
  unit_instance <- [d| instance Unit $unit_type where
                         type BaseUnit $unit_type = $base_unit_type
                         conversionRatio _ = ratio |]
  return $ (DataD [] unit_name [] [NormalC unit_name []] [])
           : unit_instance ++ show_instance
  where
    unit_name = mkName unit_name_str
    unit_type = return $ ConT unit_name
    base_unit_type = return $ ConT base_unit

-- | @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 unit_name_str m_abbrev = do
  show_instance <- maybeMkShowInstance unit_name m_abbrev
  dim_instance <- [d| instance Dimension $unit_type |]
  unit_instance <- [d| instance Unit $unit_type where
                         type BaseUnit $unit_type = Canonical
                         type DimOfUnit $unit_type = $unit_type |]
  default_instance <- [d| type instance DefaultUnitOfDim $unit_type = $unit_type |]
  return $ (DataD [] unit_name [] [NormalC unit_name []] [])
           : show_instance ++ dim_instance ++ unit_instance ++ default_instance
  where
    unit_name = mkName unit_name_str
    unit_type = return $ ConT unit_name