content: -----------------------------------------------------------------------------
  -- |
  -- 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 tab s = to_exp `liftM` parseUnit tab s   -- the Either monad
    where
      to_exp Unity                  = ConE 'Number
      to_exp (Unit (Just pre) unit) = ConE '(:@) `AppE` of_type pre `AppE` of_type unit
      to_exp (Unit Nothing unit)    = of_type unit
      to_exp (Mult e1 e2)           = ConE '(:*) `AppE` to_exp e1 `AppE` to_exp e2
      to_exp (Div e1 e2)            = ConE '(:/) `AppE` to_exp e1 `AppE` to_exp e2
      to_exp (Pow e i)              = ConE '(:^) `AppE` to_exp e `AppE` mk_sing i
  
      of_type :: Name -> Exp
      of_type n = (VarE 'undefined) `SigE` (ConT n)
  
      mk_sing :: Integer -> Exp
      mk_sing n
        | n < 0     = VarE 'sPred `AppE` mk_sing (n + 1)
        | n > 0     = VarE 'sSucc `AppE` mk_sing (n - 1)
        | otherwise = VarE 'sZero
  
  parseUnitType :: SymbolTable Name Name -> String -> Either String Type
  parseUnitType tab s = to_type `liftM` parseUnit tab s   -- the Either monad
    where
      to_type Unity                  = ConT ''Number
      to_type (Unit (Just pre) unit) = ConT ''(:@) `AppT` ConT pre `AppT` ConT unit
      to_type (Unit Nothing unit)    = ConT unit
      to_type (Mult e1 e2)           = ConT ''(:*) `AppT` to_type e1 `AppT` to_type e2
      to_type (Div e1 e2)            = ConT ''(:/) `AppT` to_type e1 `AppT` to_type e2
      to_type (Pow e i)              = ConT ''(:^) `AppT` to_type e `AppT` mk_z i
  
      mk_z :: Integer -> Type
      mk_z n
        | n < 0     = ConT ''Pred `AppT` mk_z (n + 1)
        | n > 0     = ConT ''Succ `AppT` mk_z (n - 1)
        | otherwise = ConT 'Zero   -- single quote as it's a data constructor!
  
  ----------------------------------------------------------------------
  -- QuasiQuoters
  ----------------------------------------------------------------------
  
  emptyQQ :: QuasiQuoter
  emptyQQ = QuasiQuoter { quoteExp = \_ -> fail "No quasi-quoter for expressions"
                        , quotePat = \_ -> fail "No quasi-quoter for patterns"
                        , quoteType = \_ -> fail "No quasi-quoter for types"
                        , quoteDec = \_ -> fail "No quasi-quoter for declarations" }
  
  errorQQ :: String -> QuasiQuoter
  errorQQ msg = QuasiQuoter { quoteExp = \_ -> fail msg
                            , quotePat = \_ -> fail msg
                            , quoteType = \_ -> fail msg
                            , quoteDec = \_ -> fail 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 qq_name_str prefix_names unit_names = do
    mapM_ checkIsType prefix_names
    mapM_ checkIsType unit_names
    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
                        } |]
    return [ SigD qq_name (ConT ''QuasiQuoter)
           , ValD (VarP qq_name) (NormalB qq) []]
    where
      qq_name = mkName qq_name_str
  
      mk_pair :: Name -> Q Exp   -- Exp is of type (String, Name)
      mk_pair n = [| (show (undefined :: $( return $ ConT n )), n) |]
  
      sym_tab :: Q Exp           -- Exp is of type (Either String SymbolTable)
      sym_tab = do
        prefix_pairs <- mapM mk_pair prefix_names
        unit_pairs   <- mapM mk_pair unit_names
        [| mkSymbolTable $( return $ ListE prefix_pairs ) $( return $ ListE unit_pairs ) |]
  
  ----------------------------------------------------------------------
  -- Getting instances
  ----------------------------------------------------------------------
  
  getInstanceNames :: Name -> Q [Name]
  getInstanceNames class_name = do
    ClassI _ insts <- reify class_name
    m_names <- forM insts $ \inst ->
      case inst of
        InstanceD
  #if __GLASGOW_HASKELL__ >= 711
          _
  #endif
            _ ((ConT class_name') `AppT` (ConT unit_name)) []
          |  class_name == class_name'
          -> do show_insts <- reifyInstances ''Show [ConT unit_name]
                case show_insts of
                  [_show_inst] -> return $ Just unit_name
                  _            -> return Nothing
        _ -> return Nothing
    return $ catMaybes 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 = 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 = getInstanceNames ''UnitPrefix
  