-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Metrology.Parser
-- 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 functions allowing users to create their own unit
-- quasiquoters to make for compact unit expressions.
--
-- A typical use case is this:
--
-- > $(makeQuasiQuoter "unit" [''Kilo, ''Milli] [''Meter, ''Second])
--
-- and then, /in a separate module/ (due to GHC's staging constraints)
--
-- > x = 3 % [unit| m/s^2 ]
--
-- The unit expressions can refer to the prefixes and units specified in
-- the call to 'makeQuasiQuoter'. The spellings of the prefixes and units
-- are taken from their @Show@ instances.
--
-- The syntax for these expressions is like
-- F#'s. There are four arithmetic operators (@*@, @/@, @^@, and juxtaposition).
-- Exponentiation binds the tightest, and it allows an integer to its right
-- (possibly with minus signs and parentheses). Next tightest is juxtaposition,
-- which indicates multiplication. Because juxtaposition binds tighter than division,
-- the expressions @m/s^2@ and @m/s s@ are equivalent. Multiplication and
-- division bind the loosest and are left-associative, meaning that @m/s*s@
-- is equivalent to @(m/s)*s@, probably not what you meant. Parentheses in
-- unit expressions are allowed, of course.
--
-- Within a unit string (that is, a unit with an optional prefix), there may
-- be ambiguity. If a unit string can be interpreted as a unit without a
-- prefix, that parsing is preferred. Thus, @min@ would be minutes, not
-- milli-inches (assuming appropriate prefixes and units available.) There still
-- may be ambiguity between unit strings, even interpreting the string as a prefix
-- and a base unit. If a unit string is amiguous in this way, it is rejected.
-- For example, if we have prefixes @da@ and @d@ and units @m@ and @am@, then
-- @dam@ is ambiguous like this.
-----------------------------------------------------------------------------

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

module Data.Metrology.Parser (
  -- * Quasiquoting interface
  makeQuasiQuoter, allUnits, allPrefixes,

  -- * Direct interface

  -- | The definitions below allow users to access the unit parser directly.
  -- The parser produces 'UnitExp's which can then be further processed as
  -- necessary.
  parseUnit,
  UnitExp(..), SymbolTable,
  mkSymbolTable,

  -- for internal use only
  parseUnitExp, parseUnitType
  ) where

import Prelude hiding ( exp )

import Language.Haskell.TH hiding ( Pred )
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Desugar.Lift  ()  -- get the Lift Name instance
import Data.Maybe
import Control.Monad

import Text.Parse.Units
import Data.Metrology
import Data.Metrology.TH

----------------------------------------------------------------------
-- TH conversions
----------------------------------------------------------------------

parseUnitExp :: SymbolTable Name Name -> String -> Either String Exp
parseUnitExp :: SymbolTable Name Name -> String -> Either String Exp
parseUnitExp SymbolTable Name Name
tab String
s = UnitExp Name Name -> Exp
to_exp (UnitExp Name Name -> Exp)
-> Either String (UnitExp Name Name) -> Either String Exp
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` SymbolTable Name Name
-> String -> Either String (UnitExp Name Name)
forall pre u.
(Show pre, Show u) =>
SymbolTable pre u -> String -> Either String (UnitExp pre u)
parseUnit SymbolTable Name Name
tab String
s   -- the Either monad
  where
    to_exp :: UnitExp Name Name -> Exp
to_exp UnitExp Name Name
Unity                  = Name -> Exp
ConE 'Number
    to_exp (Unit (Just Name
pre) Name
unit) = Name -> Exp
ConE '(:@) Exp -> Exp -> Exp
`AppE` Name -> Exp
of_type Name
pre Exp -> Exp -> Exp
`AppE` Name -> Exp
of_type Name
unit
    to_exp (Unit Maybe Name
Nothing Name
unit)    = Name -> Exp
of_type Name
unit
    to_exp (Mult UnitExp Name Name
e1 UnitExp Name Name
e2)           = Name -> Exp
ConE '(:*) Exp -> Exp -> Exp
`AppE` UnitExp Name Name -> Exp
to_exp UnitExp Name Name
e1 Exp -> Exp -> Exp
`AppE` UnitExp Name Name -> Exp
to_exp UnitExp Name Name
e2
    to_exp (Div UnitExp Name Name
e1 UnitExp Name Name
e2)            = Name -> Exp
ConE '(:/) Exp -> Exp -> Exp
`AppE` UnitExp Name Name -> Exp
to_exp UnitExp Name Name
e1 Exp -> Exp -> Exp
`AppE` UnitExp Name Name -> Exp
to_exp UnitExp Name Name
e2
    to_exp (Pow UnitExp Name Name
e Integer
i)              = Name -> Exp
ConE '(:^) Exp -> Exp -> Exp
`AppE` UnitExp Name Name -> Exp
to_exp UnitExp Name Name
e Exp -> Exp -> Exp
`AppE` Integer -> Exp
mk_sing Integer
i

    of_type :: Name -> Exp
    of_type :: Name -> Exp
of_type Name
n = (Name -> Exp
VarE 'undefined) Exp -> Type -> Exp
`SigE` (Name -> Type
ConT Name
n)

    mk_sing :: Integer -> Exp
    mk_sing :: Integer -> Exp
mk_sing Integer
n
      | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0     = Name -> Exp
VarE 'sPred Exp -> Exp -> Exp
`AppE` Integer -> Exp
mk_sing (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
      | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0     = Name -> Exp
VarE 'sSucc Exp -> Exp -> Exp
`AppE` Integer -> Exp
mk_sing (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
      | Bool
otherwise = Name -> Exp
VarE 'sZero

parseUnitType :: SymbolTable Name Name -> String -> Either String Type
parseUnitType :: SymbolTable Name Name -> String -> Either String Type
parseUnitType SymbolTable Name Name
tab String
s = UnitExp Name Name -> Type
to_type (UnitExp Name Name -> Type)
-> Either String (UnitExp Name Name) -> Either String Type
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` SymbolTable Name Name
-> String -> Either String (UnitExp Name Name)
forall pre u.
(Show pre, Show u) =>
SymbolTable pre u -> String -> Either String (UnitExp pre u)
parseUnit SymbolTable Name Name
tab String
s   -- the Either monad
  where
    to_type :: UnitExp Name Name -> Type
to_type UnitExp Name Name
Unity                  = Name -> Type
ConT ''Number
    to_type (Unit (Just Name
pre) Name
unit) = Name -> Type
ConT ''(:@) Type -> Type -> Type
`AppT` Name -> Type
ConT Name
pre Type -> Type -> Type
`AppT` Name -> Type
ConT Name
unit
    to_type (Unit Maybe Name
Nothing Name
unit)    = Name -> Type
ConT Name
unit
    to_type (Mult UnitExp Name Name
e1 UnitExp Name Name
e2)           = Name -> Type
ConT ''(:*) Type -> Type -> Type
`AppT` UnitExp Name Name -> Type
to_type UnitExp Name Name
e1 Type -> Type -> Type
`AppT` UnitExp Name Name -> Type
to_type UnitExp Name Name
e2
    to_type (Div UnitExp Name Name
e1 UnitExp Name Name
e2)            = Name -> Type
ConT ''(:/) Type -> Type -> Type
`AppT` UnitExp Name Name -> Type
to_type UnitExp Name Name
e1 Type -> Type -> Type
`AppT` UnitExp Name Name -> Type
to_type UnitExp Name Name
e2
    to_type (Pow UnitExp Name Name
e Integer
i)              = Name -> Type
ConT ''(:^) Type -> Type -> Type
`AppT` UnitExp Name Name -> Type
to_type UnitExp Name Name
e Type -> Type -> Type
`AppT` Integer -> Type
mk_z Integer
i

    mk_z :: Integer -> Type
    mk_z :: Integer -> Type
mk_z Integer
n
      | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0     = Name -> Type
ConT ''Pred Type -> Type -> Type
`AppT` Integer -> Type
mk_z (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
      | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0     = Name -> Type
ConT ''Succ Type -> Type -> Type
`AppT` Integer -> Type
mk_z (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
      | Bool
otherwise = Name -> Type
ConT 'Zero   -- single quote as it's a data constructor!

----------------------------------------------------------------------
-- QuasiQuoters
----------------------------------------------------------------------

emptyQQ :: QuasiQuoter
emptyQQ :: QuasiQuoter
emptyQQ = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = \String
_ -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No quasi-quoter for expressions"
                      , quotePat :: String -> Q Pat
quotePat = \String
_ -> String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No quasi-quoter for patterns"
                      , quoteType :: String -> Q Type
quoteType = \String
_ -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No quasi-quoter for types"
                      , quoteDec :: String -> Q [Dec]
quoteDec = \String
_ -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No quasi-quoter for declarations" }

errorQQ :: String -> QuasiQuoter
errorQQ :: String -> QuasiQuoter
errorQQ String
msg = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = \String
_ -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
                          , quotePat :: String -> Q Pat
quotePat = \String
_ -> String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
                          , quoteType :: String -> Q Type
quoteType = \String
_ -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
                          , quoteDec :: String -> Q [Dec]
quoteDec = \String
_ -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg }

-- | @makeQuasiQuoter "qq" prefixes units@ makes a quasi-quoter named @qq@
-- that considers the prefixes and units provided. These are provided via
-- names of the /type/ constructors, /not/ the data constructors. See the
-- module documentation for more info and an example.
makeQuasiQuoter :: String -> [Name] -> [Name] -> Q [Dec]
makeQuasiQuoter :: String -> [Name] -> [Name] -> Q [Dec]
makeQuasiQuoter String
qq_name_str [Name]
prefix_names [Name]
unit_names = do
  (Name -> Q ()) -> [Name] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> Q ()
checkIsType [Name]
prefix_names
  (Name -> Q ()) -> [Name] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> Q ()
checkIsType [Name]
unit_names
  Exp
qq <- [| case $sym_tab of
            Left err -> errorQQ err
            Right computed_sym_tab ->
              emptyQQ { quoteExp = \unit_exp ->
                         case parseUnitExp computed_sym_tab unit_exp of
                           Left err2 -> fail err2
                           Right exp -> return exp
                      , quoteType = \unit_exp ->
                         case parseUnitType computed_sym_tab unit_exp of
                           Left err2 -> fail err2
                           Right typ -> return typ
                      } |]
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> Type -> Dec
SigD Name
qq_name (Name -> Type
ConT ''QuasiQuoter)
         , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
qq_name) (Exp -> Body
NormalB Exp
qq) []]
  where
    qq_name :: Name
qq_name = String -> Name
mkName String
qq_name_str

    mk_pair :: Name -> Q Exp   -- Exp is of type (String, Name)
    mk_pair :: Name -> Q Exp
mk_pair Name
n = [| (show (undefined :: $( return $ ConT n )), n) |]

    sym_tab :: Q Exp           -- Exp is of type (Either String SymbolTable)
    sym_tab :: Q Exp
sym_tab = do
      [Exp]
prefix_pairs <- (Name -> Q Exp) -> [Name] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q Exp
mk_pair [Name]
prefix_names
      [Exp]
unit_pairs   <- (Name -> Q Exp) -> [Name] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q Exp
mk_pair [Name]
unit_names
      [| mkSymbolTable $( return $ ListE prefix_pairs ) $( return $ ListE unit_pairs ) |]

----------------------------------------------------------------------
-- Getting instances
----------------------------------------------------------------------

getInstanceNames :: Name -> Q [Name]
getInstanceNames :: Name -> Q [Name]
getInstanceNames Name
class_name = do
  ClassI Dec
_ [Dec]
insts <- Name -> Q Info
reify Name
class_name
  [Maybe Name]
m_names <- [Dec] -> (Dec -> Q (Maybe Name)) -> Q [Maybe Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Dec]
insts ((Dec -> Q (Maybe Name)) -> Q [Maybe Name])
-> (Dec -> Q (Maybe Name)) -> Q [Maybe Name]
forall a b. (a -> b) -> a -> b
$ \Dec
inst ->
    case Dec
inst of
      InstanceD
#if __GLASGOW_HASKELL__ >= 711
        Maybe Overlap
_
#endif
          Cxt
_ ((ConT Name
class_name') `AppT` (ConT Name
unit_name)) []
        |  Name
class_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
class_name'
        -> do [Dec]
show_insts <- Name -> Cxt -> Q [Dec]
reifyInstances ''Show [Name -> Type
ConT Name
unit_name]
              case [Dec]
show_insts of
                [Dec
_show_inst] -> Maybe Name -> Q (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Name -> Q (Maybe Name)) -> Maybe Name -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Name
forall a. a -> Maybe a
Just Name
unit_name
                [Dec]
_            -> Maybe Name -> Q (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
forall a. Maybe a
Nothing
      Dec
_ -> Maybe Name -> Q (Maybe Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
forall a. Maybe a
Nothing
  [Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Q [Name]) -> [Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Name]
m_names

#if __GLASGOW_HASKELL__ < 709
{-# WARNING allUnits, allPrefixes "Retrieving the list of all units and prefixes in scope does not work under GHC 7.8.*. Please upgrade GHC to use these functions." #-}
#endif

-- | Gets a list of the names of all units with @Show@ instances in scope.
-- Example usage:
--
-- > $( do units <- allUnits
-- >       makeQuasiQuoter "unit" [] units )
--
allUnits :: Q [Name]
allUnits :: Q [Name]
allUnits = Name -> Q [Name]
getInstanceNames ''Unit

-- | Gets a list of the names of all unit prefixes with @Show@ instances in
-- scope. Example usage:
--
-- > $( do units    <- allUnits
-- >       prefixes <- allPrefixes
-- >       makeQuasiQuoter "unit" prefixes units )
--
allPrefixes :: Q [Name]
allPrefixes :: Q [Name]
allPrefixes = Name -> Q [Name]
getInstanceNames ''UnitPrefix