{-# LANGUAGE LambdaCase, NoMonomorphismRestriction, FlexibleContexts, RankNTypes,
             Safe, DeriveGeneric, DeriveDataTypeable, CPP, StandaloneDeriving #-}
{-# OPTIONS_HADDOCK prune #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Parse.Units
-- Copyright   :  (C) 2014 Richard Eisenberg
-- License     :  BSD-style (see LICENSE)
-- Stability   :  experimental
-- Portability :  non-portable
--
-- This module defines a parser for unit expressions.  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.
-----------------------------------------------------------------------------

module Text.Parse.Units (
  -- * Parsing units
  UnitExp(..), parseUnit,

  -- * Symbol tables
  SymbolTable(..), PrefixTable, UnitTable, mkSymbolTable,
  unsafeMkSymbolTable, universalSymbolTable,

  lex, unitStringParser  -- these are pruned from the Haddock output
  ) where

import Prelude hiding ( lex, div )

import GHC.Generics (Generic)
import Text.Parsec         hiding ( tab )
import Text.Parsec.String
import Text.Parsec.Pos
import qualified Data.Map.Strict as Map
import qualified Data.MultiMap as MM
import Control.Monad.Reader
import Control.Arrow       hiding ( app)
import Data.Data (Data)
import Data.Maybe
import Data.Char

#if __GLASGOW_HASKELL__ < 709
import Data.Typeable ( Typeable )
#endif

----------------------------------------------------------------------
-- Basic combinators
----------------------------------------------------------------------

-- copied from GHC
partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
partitionWith a -> Either b c
_ [] = ([],[])
partitionWith a -> Either b c
f (a
x:[a]
xs) = case a -> Either b c
f a
x of
                         Left  b
b -> (b
bb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
bs, [c]
cs)
                         Right c
c -> ([b]
bs, c
cc -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
cs)
    where ([b]
bs,[c]
cs) = (a -> Either b c) -> [a] -> ([b], [c])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith a -> Either b c
f [a]
xs

----------------------------------------------------------------------
-- Extra parser combinators
----------------------------------------------------------------------

-- | @experiment p@ runs @p@. If @p@ succeeds, @experiment@ returns the
-- result of running @p@. If @p@ fails, then @experiment@ returns @Nothing@.
-- In either case, no input is consumed and @experiment@ never fails.
experiment :: Stream s m t => ParsecT s u m a -> ParsecT s u m (Maybe a)
experiment :: ParsecT s u m a -> ParsecT s u m (Maybe a)
experiment = ParsecT s u m (Maybe a) -> ParsecT s u m (Maybe a)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (ParsecT s u m (Maybe a) -> ParsecT s u m (Maybe a))
-> (ParsecT s u m a -> ParsecT s u m (Maybe a))
-> ParsecT s u m a
-> ParsecT s u m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT s u m a -> ParsecT s u m (Maybe a)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (ParsecT s u m a -> ParsecT s u m (Maybe a))
-> (ParsecT s u m a -> ParsecT s u m a)
-> ParsecT s u m a
-> ParsecT s u m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT s u m a -> ParsecT s u m a
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try

consumeAll :: (Stream s m t, Show t) => ParsecT s u m a -> ParsecT s u m a
consumeAll :: ParsecT s u m a -> ParsecT s u m a
consumeAll ParsecT s u m a
p = do
  a
result <- ParsecT s u m a
p
  ParsecT s u m ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
  a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

nochar :: Stream s m Char => Char -> ParsecT s u m ()
nochar :: Char -> ParsecT s u m ()
nochar = ParsecT s u m Char -> ParsecT s u m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT s u m Char -> ParsecT s u m ())
-> (Char -> ParsecT s u m Char) -> Char -> ParsecT s u m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char

----------------------------------------------------------------------
-- Datatypes
----------------------------------------------------------------------

data Op = NegO | MultO | DivO | PowO | OpenP | CloseP

instance Show Op where
  show :: Op -> String
show Op
NegO    = String
"-"
  show Op
MultO   = String
"*"
  show Op
DivO    = String
"/"
  show Op
PowO    = String
"^"
  show Op
OpenP   = String
"("
  show Op
CloseP  = String
")"

data Token = UnitT String
           | NumberT Integer
           | OpT Op

instance Show Token where
  show :: Token -> String
show (UnitT String
s)   = String
s
  show (NumberT Integer
i) = Integer -> String
forall a. Show a => a -> String
show Integer
i
  show (OpT Op
op)    = Op -> String
forall a. Show a => a -> String
show Op
op

-- | Parsed unit expressions, parameterized by a prefix identifier type and
-- a unit identifier type
data UnitExp pre u = Unity                     -- ^ "1"
                   | Unit (Maybe pre) u        -- ^ a unit with, perhaps, a prefix
                   | Mult (UnitExp pre u) (UnitExp pre u)
                   | Div (UnitExp pre u) (UnitExp pre u)
                   | Pow (UnitExp pre u) Integer
                   deriving (UnitExp pre u -> UnitExp pre u -> Bool
(UnitExp pre u -> UnitExp pre u -> Bool)
-> (UnitExp pre u -> UnitExp pre u -> Bool) -> Eq (UnitExp pre u)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall pre u.
(Eq pre, Eq u) =>
UnitExp pre u -> UnitExp pre u -> Bool
/= :: UnitExp pre u -> UnitExp pre u -> Bool
$c/= :: forall pre u.
(Eq pre, Eq u) =>
UnitExp pre u -> UnitExp pre u -> Bool
== :: UnitExp pre u -> UnitExp pre u -> Bool
$c== :: forall pre u.
(Eq pre, Eq u) =>
UnitExp pre u -> UnitExp pre u -> Bool
Eq, Eq (UnitExp pre u)
Eq (UnitExp pre u)
-> (UnitExp pre u -> UnitExp pre u -> Ordering)
-> (UnitExp pre u -> UnitExp pre u -> Bool)
-> (UnitExp pre u -> UnitExp pre u -> Bool)
-> (UnitExp pre u -> UnitExp pre u -> Bool)
-> (UnitExp pre u -> UnitExp pre u -> Bool)
-> (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
-> (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
-> Ord (UnitExp pre u)
UnitExp pre u -> UnitExp pre u -> Bool
UnitExp pre u -> UnitExp pre u -> Ordering
UnitExp pre u -> UnitExp pre u -> UnitExp pre u
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall pre u. (Ord pre, Ord u) => Eq (UnitExp pre u)
forall pre u.
(Ord pre, Ord u) =>
UnitExp pre u -> UnitExp pre u -> Bool
forall pre u.
(Ord pre, Ord u) =>
UnitExp pre u -> UnitExp pre u -> Ordering
forall pre u.
(Ord pre, Ord u) =>
UnitExp pre u -> UnitExp pre u -> UnitExp pre u
min :: UnitExp pre u -> UnitExp pre u -> UnitExp pre u
$cmin :: forall pre u.
(Ord pre, Ord u) =>
UnitExp pre u -> UnitExp pre u -> UnitExp pre u
max :: UnitExp pre u -> UnitExp pre u -> UnitExp pre u
$cmax :: forall pre u.
(Ord pre, Ord u) =>
UnitExp pre u -> UnitExp pre u -> UnitExp pre u
>= :: UnitExp pre u -> UnitExp pre u -> Bool
$c>= :: forall pre u.
(Ord pre, Ord u) =>
UnitExp pre u -> UnitExp pre u -> Bool
> :: UnitExp pre u -> UnitExp pre u -> Bool
$c> :: forall pre u.
(Ord pre, Ord u) =>
UnitExp pre u -> UnitExp pre u -> Bool
<= :: UnitExp pre u -> UnitExp pre u -> Bool
$c<= :: forall pre u.
(Ord pre, Ord u) =>
UnitExp pre u -> UnitExp pre u -> Bool
< :: UnitExp pre u -> UnitExp pre u -> Bool
$c< :: forall pre u.
(Ord pre, Ord u) =>
UnitExp pre u -> UnitExp pre u -> Bool
compare :: UnitExp pre u -> UnitExp pre u -> Ordering
$ccompare :: forall pre u.
(Ord pre, Ord u) =>
UnitExp pre u -> UnitExp pre u -> Ordering
$cp1Ord :: forall pre u. (Ord pre, Ord u) => Eq (UnitExp pre u)
Ord, (forall x. UnitExp pre u -> Rep (UnitExp pre u) x)
-> (forall x. Rep (UnitExp pre u) x -> UnitExp pre u)
-> Generic (UnitExp pre u)
forall x. Rep (UnitExp pre u) x -> UnitExp pre u
forall x. UnitExp pre u -> Rep (UnitExp pre u) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall pre u x. Rep (UnitExp pre u) x -> UnitExp pre u
forall pre u x. UnitExp pre u -> Rep (UnitExp pre u) x
$cto :: forall pre u x. Rep (UnitExp pre u) x -> UnitExp pre u
$cfrom :: forall pre u x. UnitExp pre u -> Rep (UnitExp pre u) x
Generic, Typeable (UnitExp pre u)
DataType
Constr
Typeable (UnitExp pre u)
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> UnitExp pre u -> c (UnitExp pre u))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (UnitExp pre u))
-> (UnitExp pre u -> Constr)
-> (UnitExp pre u -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (UnitExp pre u)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (UnitExp pre u)))
-> ((forall b. Data b => b -> b) -> UnitExp pre u -> UnitExp pre u)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> UnitExp pre u -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> UnitExp pre u -> r)
-> (forall u. (forall d. Data d => d -> u) -> UnitExp pre u -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> UnitExp pre u -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> UnitExp pre u -> m (UnitExp pre u))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> UnitExp pre u -> m (UnitExp pre u))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> UnitExp pre u -> m (UnitExp pre u))
-> Data (UnitExp pre u)
UnitExp pre u -> DataType
UnitExp pre u -> Constr
(forall b. Data b => b -> b) -> UnitExp pre u -> UnitExp pre u
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> UnitExp pre u -> c (UnitExp pre u)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (UnitExp pre u)
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (UnitExp pre u))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> UnitExp pre u -> u
forall u. (forall d. Data d => d -> u) -> UnitExp pre u -> [u]
forall pre u. (Data pre, Data u) => Typeable (UnitExp pre u)
forall pre u. (Data pre, Data u) => UnitExp pre u -> DataType
forall pre u. (Data pre, Data u) => UnitExp pre u -> Constr
forall pre u.
(Data pre, Data u) =>
(forall b. Data b => b -> b) -> UnitExp pre u -> UnitExp pre u
forall pre u u.
(Data pre, Data u) =>
Int -> (forall d. Data d => d -> u) -> UnitExp pre u -> u
forall pre u u.
(Data pre, Data u) =>
(forall d. Data d => d -> u) -> UnitExp pre u -> [u]
forall pre u r r'.
(Data pre, Data u) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> UnitExp pre u -> r
forall pre u r r'.
(Data pre, Data u) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> UnitExp pre u -> r
forall pre u (m :: * -> *).
(Data pre, Data u, Monad m) =>
(forall d. Data d => d -> m d)
-> UnitExp pre u -> m (UnitExp pre u)
forall pre u (m :: * -> *).
(Data pre, Data u, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> UnitExp pre u -> m (UnitExp pre u)
forall pre u (c :: * -> *).
(Data pre, Data u) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (UnitExp pre u)
forall pre u (c :: * -> *).
(Data pre, Data u) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> UnitExp pre u -> c (UnitExp pre u)
forall pre u (t :: * -> *) (c :: * -> *).
(Data pre, Data u, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (UnitExp pre u))
forall pre u (t :: * -> * -> *) (c :: * -> *).
(Data pre, Data u, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (UnitExp pre u))
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> UnitExp pre u -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> UnitExp pre u -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> UnitExp pre u -> m (UnitExp pre u)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> UnitExp pre u -> m (UnitExp pre u)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (UnitExp pre u)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> UnitExp pre u -> c (UnitExp pre u)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (UnitExp pre u))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (UnitExp pre u))
$cPow :: Constr
$cDiv :: Constr
$cMult :: Constr
$cUnit :: Constr
$cUnity :: Constr
$tUnitExp :: DataType
gmapMo :: (forall d. Data d => d -> m d)
-> UnitExp pre u -> m (UnitExp pre u)
$cgmapMo :: forall pre u (m :: * -> *).
(Data pre, Data u, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> UnitExp pre u -> m (UnitExp pre u)
gmapMp :: (forall d. Data d => d -> m d)
-> UnitExp pre u -> m (UnitExp pre u)
$cgmapMp :: forall pre u (m :: * -> *).
(Data pre, Data u, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> UnitExp pre u -> m (UnitExp pre u)
gmapM :: (forall d. Data d => d -> m d)
-> UnitExp pre u -> m (UnitExp pre u)
$cgmapM :: forall pre u (m :: * -> *).
(Data pre, Data u, Monad m) =>
(forall d. Data d => d -> m d)
-> UnitExp pre u -> m (UnitExp pre u)
gmapQi :: Int -> (forall d. Data d => d -> u) -> UnitExp pre u -> u
$cgmapQi :: forall pre u u.
(Data pre, Data u) =>
Int -> (forall d. Data d => d -> u) -> UnitExp pre u -> u
gmapQ :: (forall d. Data d => d -> u) -> UnitExp pre u -> [u]
$cgmapQ :: forall pre u u.
(Data pre, Data u) =>
(forall d. Data d => d -> u) -> UnitExp pre u -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> UnitExp pre u -> r
$cgmapQr :: forall pre u r r'.
(Data pre, Data u) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> UnitExp pre u -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> UnitExp pre u -> r
$cgmapQl :: forall pre u r r'.
(Data pre, Data u) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> UnitExp pre u -> r
gmapT :: (forall b. Data b => b -> b) -> UnitExp pre u -> UnitExp pre u
$cgmapT :: forall pre u.
(Data pre, Data u) =>
(forall b. Data b => b -> b) -> UnitExp pre u -> UnitExp pre u
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (UnitExp pre u))
$cdataCast2 :: forall pre u (t :: * -> * -> *) (c :: * -> *).
(Data pre, Data u, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (UnitExp pre u))
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c (UnitExp pre u))
$cdataCast1 :: forall pre u (t :: * -> *) (c :: * -> *).
(Data pre, Data u, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (UnitExp pre u))
dataTypeOf :: UnitExp pre u -> DataType
$cdataTypeOf :: forall pre u. (Data pre, Data u) => UnitExp pre u -> DataType
toConstr :: UnitExp pre u -> Constr
$ctoConstr :: forall pre u. (Data pre, Data u) => UnitExp pre u -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (UnitExp pre u)
$cgunfold :: forall pre u (c :: * -> *).
(Data pre, Data u) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (UnitExp pre u)
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> UnitExp pre u -> c (UnitExp pre u)
$cgfoldl :: forall pre u (c :: * -> *).
(Data pre, Data u) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> UnitExp pre u -> c (UnitExp pre u)
$cp1Data :: forall pre u. (Data pre, Data u) => Typeable (UnitExp pre u)
Data)

#if __GLASGOW_HASKELL__ < 709
deriving instance Typeable UnitExp
#endif

instance (Show pre, Show u) => Show (UnitExp pre u) where
  show :: UnitExp pre u -> String
show UnitExp pre u
Unity               = String
"1"
  show (Unit (Just pre
pre) u
u) = pre -> String
forall a. Show a => a -> String
show pre
pre String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :@ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ u -> String
forall a. Show a => a -> String
show u
u
  show (Unit Maybe pre
Nothing u
u)    = u -> String
forall a. Show a => a -> String
show u
u
  show (Mult UnitExp pre u
e1 UnitExp pre u
e2)        = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitExp pre u -> String
forall a. Show a => a -> String
show UnitExp pre u
e1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :* " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitExp pre u -> String
forall a. Show a => a -> String
show UnitExp pre u
e2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  show (Div UnitExp pre u
e1 UnitExp pre u
e2)         = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitExp pre u -> String
forall a. Show a => a -> String
show UnitExp pre u
e1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :/ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitExp pre u -> String
forall a. Show a => a -> String
show UnitExp pre u
e2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  show (Pow UnitExp pre u
e Integer
i)           = UnitExp pre u -> String
forall a. Show a => a -> String
show UnitExp pre u
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :^ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i

----------------------------------------------------------------------
-- Lexer
----------------------------------------------------------------------

type Lexer = Parser

unitL :: Lexer Token
unitL :: Lexer Token
unitL = String -> Token
UnitT (String -> Token)
-> ParsecT String () Identity String -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter)

opL :: Lexer Token
opL :: Lexer Token
opL = (Op -> Token) -> ParsecT String () Identity Op -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Op -> Token
OpT (ParsecT String () Identity Op -> Lexer Token)
-> ParsecT String () Identity Op -> Lexer Token
forall a b. (a -> b) -> a -> b
$
      do { Char -> ParsecT String () Identity ()
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m ()
nochar Char
'-'; Op -> ParsecT String () Identity Op
forall (m :: * -> *) a. Monad m => a -> m a
return Op
NegO    }
  ParsecT String () Identity Op
-> ParsecT String () Identity Op -> ParsecT String () Identity Op
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do { Char -> ParsecT String () Identity ()
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m ()
nochar Char
'*'; Op -> ParsecT String () Identity Op
forall (m :: * -> *) a. Monad m => a -> m a
return Op
MultO   }
  ParsecT String () Identity Op
-> ParsecT String () Identity Op -> ParsecT String () Identity Op
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do { Char -> ParsecT String () Identity ()
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m ()
nochar Char
'/'; Op -> ParsecT String () Identity Op
forall (m :: * -> *) a. Monad m => a -> m a
return Op
DivO    }
  ParsecT String () Identity Op
-> ParsecT String () Identity Op -> ParsecT String () Identity Op
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do { Char -> ParsecT String () Identity ()
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m ()
nochar Char
'^'; Op -> ParsecT String () Identity Op
forall (m :: * -> *) a. Monad m => a -> m a
return Op
PowO    }
  ParsecT String () Identity Op
-> ParsecT String () Identity Op -> ParsecT String () Identity Op
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do { Char -> ParsecT String () Identity ()
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m ()
nochar Char
'('; Op -> ParsecT String () Identity Op
forall (m :: * -> *) a. Monad m => a -> m a
return Op
OpenP   }
  ParsecT String () Identity Op
-> ParsecT String () Identity Op -> ParsecT String () Identity Op
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do { Char -> ParsecT String () Identity ()
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m ()
nochar Char
')'; Op -> ParsecT String () Identity Op
forall (m :: * -> *) a. Monad m => a -> m a
return Op
CloseP  }

numberL :: Lexer Token
numberL :: Lexer Token
numberL = (Integer -> Token
NumberT (Integer -> Token) -> (String -> Integer) -> String -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer
forall a. Read a => String -> a
read) (String -> Token)
-> ParsecT String () Identity String -> Lexer Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)

lexer1 :: Lexer Token
lexer1 :: Lexer Token
lexer1 = Lexer Token
unitL Lexer Token -> Lexer Token -> Lexer Token
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Lexer Token
opL Lexer Token -> Lexer Token -> Lexer Token
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Lexer Token
numberL

lexer :: Lexer [Token]
lexer :: Lexer [Token]
lexer = do
  ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  [Lexer [Token]] -> Lexer [Token]
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice
    [ do ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof ParsecT String () Identity ()
-> String -> ParsecT String () Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
""
         [Token] -> Lexer [Token]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    , do Token
tok <- Lexer Token
lexer1
         ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
         [Token]
toks <- Lexer [Token]
lexer
         [Token] -> Lexer [Token]
forall (m :: * -> *) a. Monad m => a -> m a
return (Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
toks)
    ]

lex :: String -> Either ParseError [Token]
lex :: String -> Either ParseError [Token]
lex = Lexer [Token] -> String -> String -> Either ParseError [Token]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Lexer [Token]
lexer String
""

----------------------------------------------------------------------
-- Symbol tables
----------------------------------------------------------------------

-- | A finite mapping from prefix spellings to prefix identifiers (of
-- unspecified type @pre@). All prefix spellings must be strictly alphabetic.
type PrefixTable pre = Map.Map String pre

-- | A mapping from unit spellings to unit identifiers (of unspecified type
-- @u@). All unit spellings must be strictly alphabetic.
type UnitTable u = String -> Maybe u

-- | A "symbol table" for the parser, mapping prefixes and units to their
-- representations.
data SymbolTable pre u = SymbolTable { SymbolTable pre u -> PrefixTable pre
prefixTable :: PrefixTable pre
                                     , SymbolTable pre u -> UnitTable u
unitTable   :: UnitTable u
                                     } deriving ((forall x. SymbolTable pre u -> Rep (SymbolTable pre u) x)
-> (forall x. Rep (SymbolTable pre u) x -> SymbolTable pre u)
-> Generic (SymbolTable pre u)
forall x. Rep (SymbolTable pre u) x -> SymbolTable pre u
forall x. SymbolTable pre u -> Rep (SymbolTable pre u) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall pre u x. Rep (SymbolTable pre u) x -> SymbolTable pre u
forall pre u x. SymbolTable pre u -> Rep (SymbolTable pre u) x
$cto :: forall pre u x. Rep (SymbolTable pre u) x -> SymbolTable pre u
$cfrom :: forall pre u x. SymbolTable pre u -> Rep (SymbolTable pre u) x
Generic)

-- | Build a 'Map' from an association list, checking for ambiguity
unambFromList :: (Ord a, Show b) => [(a,b)] -> Either [(a,[String])] (Map.Map a b)
unambFromList :: [(a, b)] -> Either [(a, [String])] (Map a b)
unambFromList [(a, b)]
list =
  let multimap :: MultiMap a b
multimap      = [(a, b)] -> MultiMap a b
forall k a. Ord k => [(k, a)] -> MultiMap k a
MM.fromList [(a, b)]
list
      assocs :: [(a, [b])]
assocs        = MultiMap a b -> [(a, [b])]
forall k a. MultiMap k a -> [(k, [a])]
MM.assocs MultiMap a b
multimap
      ([(a, [String])]
errs, [(a, b)]
goods) = ((a, [b]) -> Either (a, [String]) (a, b))
-> [(a, [b])] -> ([(a, [String])], [(a, b)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (\(a
key, [b]
vals) ->
                                       case [b]
vals of
                                         [b
val] -> (a, b) -> Either (a, [String]) (a, b)
forall a b. b -> Either a b
Right (a
key, b
val)
                                         [b]
_     -> (a, [String]) -> Either (a, [String]) (a, b)
forall a b. a -> Either a b
Left (a
key, (b -> String) -> [b] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map b -> String
forall a. Show a => a -> String
show [b]
vals)) [(a, [b])]
assocs
      result :: Map a b
result        = [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(a, b)]
goods
  in
  if [(a, [String])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, [String])]
errs then Map a b -> Either [(a, [String])] (Map a b)
forall a b. b -> Either a b
Right Map a b
result else [(a, [String])] -> Either [(a, [String])] (Map a b)
forall a b. a -> Either a b
Left [(a, [String])]
errs

-- | Build a symbol table from prefix mappings and unit mappings. The prefix mapping
-- can be empty. This function checks to make sure that the strings are not
-- inherently ambiguous and are purely alphabetic.
mkSymbolTable :: (Show pre, Show u)
              => [(String, pre)]   -- ^ Association list of prefixes
              -> [(String, u)]     -- ^ Association list of units
              -> Either String (SymbolTable pre u)
mkSymbolTable :: [(String, pre)]
-> [(String, u)] -> Either String (SymbolTable pre u)
mkSymbolTable [(String, pre)]
prefixes [(String, u)]
units =
  let bad_strings :: [String]
bad_strings = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isLetter) (((String, pre) -> String) -> [(String, pre)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, pre) -> String
forall a b. (a, b) -> a
fst [(String, pre)]
prefixes [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String, u) -> String) -> [(String, u)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, u) -> String
forall a b. (a, b) -> a
fst [(String, u)]
units) in
  if Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad_strings)
  then String -> Either String (SymbolTable pre u)
forall a b. a -> Either a b
Left (String -> Either String (SymbolTable pre u))
-> String -> Either String (SymbolTable pre u)
forall a b. (a -> b) -> a -> b
$ String
"All prefixes and units must be composed entirely of letters.\nThe following are illegal: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
bad_strings
  else
  let result :: Either [(String, [String])] (SymbolTable pre u)
result = do
        Map String pre
prefixTab <- [(String, pre)] -> Either [(String, [String])] (Map String pre)
forall a b.
(Ord a, Show b) =>
[(a, b)] -> Either [(a, [String])] (Map a b)
unambFromList [(String, pre)]
prefixes
        Map String u
unitTab   <- [(String, u)] -> Either [(String, [String])] (Map String u)
forall a b.
(Ord a, Show b) =>
[(a, b)] -> Either [(a, [String])] (Map a b)
unambFromList [(String, u)]
units
        SymbolTable pre u
-> Either [(String, [String])] (SymbolTable pre u)
forall (m :: * -> *) a. Monad m => a -> m a
return (SymbolTable pre u
 -> Either [(String, [String])] (SymbolTable pre u))
-> SymbolTable pre u
-> Either [(String, [String])] (SymbolTable pre u)
forall a b. (a -> b) -> a -> b
$ SymbolTable :: forall pre u. PrefixTable pre -> UnitTable u -> SymbolTable pre u
SymbolTable { prefixTable :: Map String pre
prefixTable = Map String pre
prefixTab, unitTable :: UnitTable u
unitTable = (String -> Map String u -> Maybe u) -> Map String u -> UnitTable u
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Map String u -> Maybe u
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map String u
unitTab }
  in ([(String, [String])] -> String)
-> Either [(String, [String])] (SymbolTable pre u)
-> Either String (SymbolTable pre u)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ((String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
error_suffix) ShowS
-> ([(String, [String])] -> String)
-> [(String, [String])]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [String]) -> String) -> [(String, [String])] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, [String]) -> String
forall x. Show x => (String, [x]) -> String
mk_error_string) Either [(String, [String])] (SymbolTable pre u)
result
  where
    mk_error_string :: Show x => (String, [x]) -> String
    mk_error_string :: (String, [x]) -> String
mk_error_string (String
k, [x]
vs) =
      String
"The label `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' is assigned to the following meanings:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
      [x] -> String
forall a. Show a => a -> String
show [x]
vs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
    error_suffix :: String
error_suffix = String
"This is ambiguous. Please fix before building a unit parser."

-- | Make a symbol table without checking for ambiguity or non-purely
-- alphabetic strings.  The prefixes must be a (potentially empty)
-- finite map, but the units mapping need not be finite.
-- Note that this is unsafe in that the resulting parser may behave
-- unpredictably. It surely won't launch the rockets, though.
unsafeMkSymbolTable :: PrefixTable pre -> UnitTable u -> SymbolTable pre u
unsafeMkSymbolTable :: PrefixTable pre -> UnitTable u -> SymbolTable pre u
unsafeMkSymbolTable = PrefixTable pre -> UnitTable u -> SymbolTable pre u
forall pre u. PrefixTable pre -> UnitTable u -> SymbolTable pre u
SymbolTable

-- | A symbol table that accepts all unit strings, but supports no prefixes.
universalSymbolTable :: SymbolTable a String
universalSymbolTable :: SymbolTable a String
universalSymbolTable = PrefixTable a -> UnitTable String -> SymbolTable a String
forall pre u. PrefixTable pre -> UnitTable u -> SymbolTable pre u
SymbolTable PrefixTable a
forall k a. Map k a
Map.empty UnitTable String
forall a. a -> Maybe a
Just


----------------------------------------------------------------------
-- Unit string parser
----------------------------------------------------------------------

-- We assume that no symbol table is inherently ambiguous!

type GenUnitStringParser pre u = ParsecT String () (Reader (SymbolTable pre u))
type UnitStringParser_UnitExp =
  forall pre u. (Show pre, Show u) => GenUnitStringParser pre u (UnitExp pre u)

-- parses just a unit (no prefix)
justUnitP :: GenUnitStringParser pre u u
justUnitP :: GenUnitStringParser pre u u
justUnitP = do
  String
full_string <- ParsecT String () (Reader (SymbolTable pre u)) String
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
  UnitTable u
units <- (SymbolTable pre u -> UnitTable u)
-> ParsecT String () (Reader (SymbolTable pre u)) (UnitTable u)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SymbolTable pre u -> UnitTable u
forall pre u. SymbolTable pre u -> UnitTable u
unitTable
  case UnitTable u
units String
full_string of
    Maybe u
Nothing -> String -> GenUnitStringParser pre u u
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
full_string String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not match any known unit")
    Just u
u  -> u -> GenUnitStringParser pre u u
forall (m :: * -> *) a. Monad m => a -> m a
return u
u

-- parses a unit and prefix, failing in the case of ambiguity
prefixUnitP :: UnitStringParser_UnitExp
prefixUnitP :: GenUnitStringParser pre u (UnitExp pre u)
prefixUnitP = do
  PrefixTable pre
prefixTab <- (SymbolTable pre u -> PrefixTable pre)
-> ParsecT String () (Reader (SymbolTable pre u)) (PrefixTable pre)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SymbolTable pre u -> PrefixTable pre
forall pre u. SymbolTable pre u -> PrefixTable pre
prefixTable
  let assocs :: [(String, pre)]
assocs = PrefixTable pre -> [(String, pre)]
forall k a. Map k a -> [(k, a)]
Map.assocs PrefixTable pre
prefixTab  -- these are in the right order
  [(pre, u)]
results <- [Maybe (pre, u)] -> [(pre, u)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (pre, u)] -> [(pre, u)])
-> ParsecT String () (Reader (SymbolTable pre u)) [Maybe (pre, u)]
-> ParsecT String () (Reader (SymbolTable pre u)) [(pre, u)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ((String, pre)
 -> ParsecT String () (Reader (SymbolTable pre u)) (Maybe (pre, u)))
-> [(String, pre)]
-> ParsecT String () (Reader (SymbolTable pre u)) [Maybe (pre, u)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ParsecT String () (Reader (SymbolTable pre u)) (pre, u)
-> ParsecT String () (Reader (SymbolTable pre u)) (Maybe (pre, u))
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
experiment (ParsecT String () (Reader (SymbolTable pre u)) (pre, u)
 -> ParsecT String () (Reader (SymbolTable pre u)) (Maybe (pre, u)))
-> ((String, pre)
    -> ParsecT String () (Reader (SymbolTable pre u)) (pre, u))
-> (String, pre)
-> ParsecT String () (Reader (SymbolTable pre u)) (Maybe (pre, u))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, pre)
-> ParsecT String () (Reader (SymbolTable pre u)) (pre, u)
forall pre u. (String, pre) -> GenUnitStringParser pre u (pre, u)
parse_one) [(String, pre)]
assocs
  String
full_string <- ParsecT String () (Reader (SymbolTable pre u)) String
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
  case [(pre, u)]
results of
    [] -> String -> GenUnitStringParser pre u (UnitExp pre u)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GenUnitStringParser pre u (UnitExp pre u))
-> String -> GenUnitStringParser pre u (UnitExp pre u)
forall a b. (a -> b) -> a -> b
$ String
"No known interpretation for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
full_string
    [(pre
pre_name, u
unit_name)] ->
      UnitExp pre u -> GenUnitStringParser pre u (UnitExp pre u)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitExp pre u -> GenUnitStringParser pre u (UnitExp pre u))
-> UnitExp pre u -> GenUnitStringParser pre u (UnitExp pre u)
forall a b. (a -> b) -> a -> b
$ Maybe pre -> u -> UnitExp pre u
forall pre u. Maybe pre -> u -> UnitExp pre u
Unit (pre -> Maybe pre
forall a. a -> Maybe a
Just pre
pre_name) u
unit_name
    [(pre, u)]
lots -> String -> GenUnitStringParser pre u (UnitExp pre u)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> GenUnitStringParser pre u (UnitExp pre u))
-> String -> GenUnitStringParser pre u (UnitExp pre u)
forall a b. (a -> b) -> a -> b
$ String
"Multiple possible interpretations for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
full_string String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                   (((pre, u) -> String) -> [(pre, u)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(pre
pre_name, u
unit_name) ->
                                 String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ pre -> String
forall a. Show a => a -> String
show pre
pre_name String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                 String
" :@ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ u -> String
forall a. Show a => a -> String
show u
unit_name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n") [(pre, u)]
lots)
  where
    parse_one :: (String, pre) -> GenUnitStringParser pre u (pre, u)
    parse_one :: (String, pre) -> GenUnitStringParser pre u (pre, u)
parse_one (String
pre, pre
name) = do
      ParsecT String () (Reader (SymbolTable pre u)) String
-> ParsecT String () (Reader (SymbolTable pre u)) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () (Reader (SymbolTable pre u)) String
 -> ParsecT String () (Reader (SymbolTable pre u)) ())
-> ParsecT String () (Reader (SymbolTable pre u)) String
-> ParsecT String () (Reader (SymbolTable pre u)) ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () (Reader (SymbolTable pre u)) String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
pre
      u
unit_name <- GenUnitStringParser pre u u
forall pre u. GenUnitStringParser pre u u
justUnitP
      (pre, u) -> GenUnitStringParser pre u (pre, u)
forall (m :: * -> *) a. Monad m => a -> m a
return (pre
name, u
unit_name)

-- parse a unit string
unitStringParser :: UnitStringParser_UnitExp
unitStringParser :: GenUnitStringParser pre u (UnitExp pre u)
unitStringParser = GenUnitStringParser pre u (UnitExp pre u)
-> GenUnitStringParser pre u (UnitExp pre u)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Maybe pre -> u -> UnitExp pre u
forall pre u. Maybe pre -> u -> UnitExp pre u
Unit Maybe pre
forall a. Maybe a
Nothing (u -> UnitExp pre u)
-> ParsecT String () (Reader (SymbolTable pre u)) u
-> GenUnitStringParser pre u (UnitExp pre u)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ParsecT String () (Reader (SymbolTable pre u)) u
forall pre u. GenUnitStringParser pre u u
justUnitP) GenUnitStringParser pre u (UnitExp pre u)
-> GenUnitStringParser pre u (UnitExp pre u)
-> GenUnitStringParser pre u (UnitExp pre u)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> GenUnitStringParser pre u (UnitExp pre u)
UnitStringParser_UnitExp
prefixUnitP

----------------------------------------------------------------------
-- Unit expression parser
----------------------------------------------------------------------

type GenUnitParser pre u = ParsecT [Token] () (Reader (SymbolTable pre u))
type UnitParser a = forall pre u. GenUnitParser pre u a
type UnitParser_UnitExp =
  forall pre u. (Show pre, Show u) => GenUnitParser pre u (UnitExp pre u)

-- move a source position past a token
updatePosToken :: SourcePos -> Token -> [Token] -> SourcePos
updatePosToken :: SourcePos -> Token -> [Token] -> SourcePos
updatePosToken SourcePos
pos (UnitT String
unit_str) [Token]
_ = SourcePos -> String -> SourcePos
updatePosString SourcePos
pos String
unit_str
updatePosToken SourcePos
pos (NumberT Integer
i) [Token]
_      = SourcePos -> String -> SourcePos
updatePosString SourcePos
pos (Integer -> String
forall a. Show a => a -> String
show Integer
i)
updatePosToken SourcePos
pos (OpT Op
_) [Token]
_          = SourcePos -> Int -> SourcePos
incSourceColumn SourcePos
pos Int
1

-- parse a Token
uToken :: (Token -> Maybe a) -> UnitParser a
uToken :: (Token -> Maybe a) -> UnitParser a
uToken Token -> Maybe a
x = (Token -> String)
-> (SourcePos -> Token -> [Token] -> SourcePos)
-> (Token -> Maybe a)
-> ParsecT [Token] () (Reader (SymbolTable pre u)) a
forall s (m :: * -> *) t a u.
Stream s m t =>
(t -> String)
-> (SourcePos -> t -> s -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s u m a
tokenPrim Token -> String
forall a. Show a => a -> String
show SourcePos -> Token -> [Token] -> SourcePos
updatePosToken Token -> Maybe a
x

-- consume an lparen
lparenP :: UnitParser ()
lparenP :: GenUnitParser pre u ()
lparenP = (Token -> Maybe ()) -> UnitParser ()
forall a. (Token -> Maybe a) -> UnitParser a
uToken ((Token -> Maybe ()) -> UnitParser ())
-> (Token -> Maybe ()) -> UnitParser ()
forall a b. (a -> b) -> a -> b
$ \case
  OpT Op
OpenP -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
  Token
_         -> Maybe ()
forall a. Maybe a
Nothing

-- consume an rparen
rparenP :: UnitParser ()
rparenP :: GenUnitParser pre u ()
rparenP = (Token -> Maybe ()) -> UnitParser ()
forall a. (Token -> Maybe a) -> UnitParser a
uToken ((Token -> Maybe ()) -> UnitParser ())
-> (Token -> Maybe ()) -> UnitParser ()
forall a b. (a -> b) -> a -> b
$ \case
  OpT Op
CloseP -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
  Token
_          -> Maybe ()
forall a. Maybe a
Nothing

-- parse a unit string
unitStringP :: String -> UnitParser_UnitExp
unitStringP :: String -> UnitParser_UnitExp
unitStringP String
str = do
  SymbolTable pre u
symbolTable <- ParsecT [Token] () (Reader (SymbolTable pre u)) (SymbolTable pre u)
forall r (m :: * -> *). MonadReader r m => m r
ask
  case (Reader (SymbolTable pre u) (Either ParseError (UnitExp pre u))
 -> SymbolTable pre u -> Either ParseError (UnitExp pre u))
-> SymbolTable pre u
-> Reader (SymbolTable pre u) (Either ParseError (UnitExp pre u))
-> Either ParseError (UnitExp pre u)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader (SymbolTable pre u) (Either ParseError (UnitExp pre u))
-> SymbolTable pre u -> Either ParseError (UnitExp pre u)
forall r a. Reader r a -> r -> a
runReader SymbolTable pre u
symbolTable (Reader (SymbolTable pre u) (Either ParseError (UnitExp pre u))
 -> Either ParseError (UnitExp pre u))
-> Reader (SymbolTable pre u) (Either ParseError (UnitExp pre u))
-> Either ParseError (UnitExp pre u)
forall a b. (a -> b) -> a -> b
$ ParsecT String () (Reader (SymbolTable pre u)) (UnitExp pre u)
-> ()
-> String
-> String
-> Reader (SymbolTable pre u) (Either ParseError (UnitExp pre u))
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> String -> s -> m (Either ParseError a)
runParserT ParsecT String () (Reader (SymbolTable pre u)) (UnitExp pre u)
UnitStringParser_UnitExp
unitStringParser () String
"" String
str of
    Left ParseError
err -> String -> GenUnitParser pre u (UnitExp pre u)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ParseError -> String
forall a. Show a => a -> String
show ParseError
err)
    Right UnitExp pre u
e  -> UnitExp pre u -> GenUnitParser pre u (UnitExp pre u)
forall (m :: * -> *) a. Monad m => a -> m a
return UnitExp pre u
e

-- parse a number, possibly negated and nested in parens
numP :: UnitParser Integer
numP :: GenUnitParser pre u Integer
numP =
  do GenUnitParser pre u ()
UnitParser ()
lparenP
     Integer
n <- GenUnitParser pre u Integer
UnitParser Integer
numP
     GenUnitParser pre u ()
UnitParser ()
rparenP
     Integer -> GenUnitParser pre u Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
n
  GenUnitParser pre u Integer
-> GenUnitParser pre u Integer -> GenUnitParser pre u Integer
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
  do (Token -> Maybe ()) -> UnitParser ()
forall a. (Token -> Maybe a) -> UnitParser a
uToken ((Token -> Maybe ()) -> UnitParser ())
-> (Token -> Maybe ()) -> UnitParser ()
forall a b. (a -> b) -> a -> b
$ \case
       OpT Op
NegO -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
       Token
_        -> Maybe ()
forall a. Maybe a
Nothing
     Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer)
-> GenUnitParser pre u Integer -> GenUnitParser pre u Integer
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` GenUnitParser pre u Integer
UnitParser Integer
numP
  GenUnitParser pre u Integer
-> GenUnitParser pre u Integer -> GenUnitParser pre u Integer
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
  do (Token -> Maybe Integer) -> UnitParser Integer
forall a. (Token -> Maybe a) -> UnitParser a
uToken ((Token -> Maybe Integer) -> UnitParser Integer)
-> (Token -> Maybe Integer) -> UnitParser Integer
forall a b. (a -> b) -> a -> b
$ \case
       NumberT Integer
i -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
       Token
_         -> Maybe Integer
forall a. Maybe a
Nothing

-- parse an exponentiation, like "^2"
powP :: GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
powP :: GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
powP = (UnitExp pre u -> UnitExp pre u)
-> GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
-> GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option UnitExp pre u -> UnitExp pre u
forall a. a -> a
id (GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
 -> GenUnitParser pre u (UnitExp pre u -> UnitExp pre u))
-> GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
-> GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
forall a b. (a -> b) -> a -> b
$ do
  (Token -> Maybe ()) -> UnitParser ()
forall a. (Token -> Maybe a) -> UnitParser a
uToken ((Token -> Maybe ()) -> UnitParser ())
-> (Token -> Maybe ()) -> UnitParser ()
forall a b. (a -> b) -> a -> b
$ \case
    OpT Op
PowO -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
    Token
_        -> Maybe ()
forall a. Maybe a
Nothing
  Integer
n <- GenUnitParser pre u Integer
UnitParser Integer
numP
  (UnitExp pre u -> UnitExp pre u)
-> GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
forall (m :: * -> *) a. Monad m => a -> m a
return ((UnitExp pre u -> UnitExp pre u)
 -> GenUnitParser pre u (UnitExp pre u -> UnitExp pre u))
-> (UnitExp pre u -> UnitExp pre u)
-> GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
forall a b. (a -> b) -> a -> b
$ (UnitExp pre u -> Integer -> UnitExp pre u)
-> Integer -> UnitExp pre u -> UnitExp pre u
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitExp pre u -> Integer -> UnitExp pre u
forall pre u. UnitExp pre u -> Integer -> UnitExp pre u
Pow Integer
n

-- parse a unit, possibly with an exponent
unitP :: UnitParser_UnitExp
unitP :: GenUnitParser pre u (UnitExp pre u)
unitP =
  do Integer
n <- GenUnitParser pre u Integer
UnitParser Integer
numP
     case Integer
n of
       Integer
1 -> UnitExp pre u -> GenUnitParser pre u (UnitExp pre u)
forall (m :: * -> *) a. Monad m => a -> m a
return UnitExp pre u
forall pre u. UnitExp pre u
Unity
       Integer
_ -> String -> GenUnitParser pre u (UnitExp pre u)
forall s (m :: * -> *) t u a.
Stream s m t =>
String -> ParsecT s u m a
unexpected (String -> GenUnitParser pre u (UnitExp pre u))
-> String -> GenUnitParser pre u (UnitExp pre u)
forall a b. (a -> b) -> a -> b
$ String
"number " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
n
  GenUnitParser pre u (UnitExp pre u)
-> GenUnitParser pre u (UnitExp pre u)
-> GenUnitParser pre u (UnitExp pre u)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
  do String
unit_str <- (Token -> Maybe String) -> UnitParser String
forall a. (Token -> Maybe a) -> UnitParser a
uToken ((Token -> Maybe String) -> UnitParser String)
-> (Token -> Maybe String) -> UnitParser String
forall a b. (a -> b) -> a -> b
$ \case
       UnitT String
unit_str -> UnitTable String
forall a. a -> Maybe a
Just String
unit_str
       Token
_              -> Maybe String
forall a. Maybe a
Nothing
     UnitExp pre u
u <- String -> UnitParser_UnitExp
unitStringP String
unit_str
     UnitExp pre u -> UnitExp pre u
maybe_pow <- GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
forall pre u. GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
powP
     UnitExp pre u -> GenUnitParser pre u (UnitExp pre u)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitExp pre u -> GenUnitParser pre u (UnitExp pre u))
-> UnitExp pre u -> GenUnitParser pre u (UnitExp pre u)
forall a b. (a -> b) -> a -> b
$ UnitExp pre u -> UnitExp pre u
maybe_pow UnitExp pre u
u

-- parse a "unit factor": either a juxtaposed sequence of units
-- or a paranthesized unit exp.
unitFactorP :: UnitParser_UnitExp
unitFactorP :: GenUnitParser pre u (UnitExp pre u)
unitFactorP =
  do GenUnitParser pre u ()
UnitParser ()
lparenP
     UnitExp pre u
unitExp <- GenUnitParser pre u (UnitExp pre u)
UnitParser_UnitExp
parser
     GenUnitParser pre u ()
UnitParser ()
rparenP
     UnitExp pre u -> GenUnitParser pre u (UnitExp pre u)
forall (m :: * -> *) a. Monad m => a -> m a
return UnitExp pre u
unitExp
  GenUnitParser pre u (UnitExp pre u)
-> GenUnitParser pre u (UnitExp pre u)
-> GenUnitParser pre u (UnitExp pre u)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
  ((UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
-> [UnitExp pre u] -> UnitExp pre u
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 UnitExp pre u -> UnitExp pre u -> UnitExp pre u
forall pre u. UnitExp pre u -> UnitExp pre u -> UnitExp pre u
Mult ([UnitExp pre u] -> UnitExp pre u)
-> ParsecT [Token] () (Reader (SymbolTable pre u)) [UnitExp pre u]
-> GenUnitParser pre u (UnitExp pre u)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` GenUnitParser pre u (UnitExp pre u)
-> ParsecT [Token] () (Reader (SymbolTable pre u)) [UnitExp pre u]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 GenUnitParser pre u (UnitExp pre u)
UnitParser_UnitExp
unitP)

-- parse * or /
opP :: GenUnitParser pre u (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
opP :: GenUnitParser
  pre u (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
opP = (Token -> Maybe (UnitExp pre u -> UnitExp pre u -> UnitExp pre u))
-> UnitParser (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
forall a. (Token -> Maybe a) -> UnitParser a
uToken ((Token -> Maybe (UnitExp pre u -> UnitExp pre u -> UnitExp pre u))
 -> UnitParser (UnitExp pre u -> UnitExp pre u -> UnitExp pre u))
-> (Token
    -> Maybe (UnitExp pre u -> UnitExp pre u -> UnitExp pre u))
-> UnitParser (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
forall a b. (a -> b) -> a -> b
$ \case
        OpT Op
MultO -> (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
-> Maybe (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
forall a. a -> Maybe a
Just UnitExp pre u -> UnitExp pre u -> UnitExp pre u
forall pre u. UnitExp pre u -> UnitExp pre u -> UnitExp pre u
Mult
        OpT Op
DivO  -> (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
-> Maybe (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
forall a. a -> Maybe a
Just UnitExp pre u -> UnitExp pre u -> UnitExp pre u
forall pre u. UnitExp pre u -> UnitExp pre u -> UnitExp pre u
Div
        Token
_         -> Maybe (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
forall a. Maybe a
Nothing

-- parse a whole unit expression
parser :: UnitParser_UnitExp
parser :: GenUnitParser pre u (UnitExp pre u)
parser = GenUnitParser pre u (UnitExp pre u)
-> ParsecT
     [Token]
     ()
     (Reader (SymbolTable pre u))
     (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
-> UnitExp pre u
-> GenUnitParser pre u (UnitExp pre u)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a
-> ParsecT s u m (a -> a -> a) -> a -> ParsecT s u m a
chainl GenUnitParser pre u (UnitExp pre u)
UnitParser_UnitExp
unitFactorP ParsecT
  [Token]
  ()
  (Reader (SymbolTable pre u))
  (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
forall pre u.
GenUnitParser
  pre u (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
opP UnitExp pre u
forall pre u. UnitExp pre u
Unity

-- | Parse a unit expression, interpreted with respect the given symbol table.
-- Returns either an error message or the successfully-parsed unit expression.
parseUnit :: (Show pre, Show u)
          => SymbolTable pre u -> String -> Either String (UnitExp pre u)
parseUnit :: SymbolTable pre u -> String -> Either String (UnitExp pre u)
parseUnit SymbolTable pre u
tab String
s = (ParseError -> String)
-> Either ParseError (UnitExp pre u)
-> Either String (UnitExp pre u)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ParseError -> String
forall a. Show a => a -> String
show (Either ParseError (UnitExp pre u)
 -> Either String (UnitExp pre u))
-> Either ParseError (UnitExp pre u)
-> Either String (UnitExp pre u)
forall a b. (a -> b) -> a -> b
$ do
  [Token]
toks <- String -> Either ParseError [Token]
lex String
s
  (Reader (SymbolTable pre u) (Either ParseError (UnitExp pre u))
 -> SymbolTable pre u -> Either ParseError (UnitExp pre u))
-> SymbolTable pre u
-> Reader (SymbolTable pre u) (Either ParseError (UnitExp pre u))
-> Either ParseError (UnitExp pre u)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader (SymbolTable pre u) (Either ParseError (UnitExp pre u))
-> SymbolTable pre u -> Either ParseError (UnitExp pre u)
forall r a. Reader r a -> r -> a
runReader SymbolTable pre u
tab (Reader (SymbolTable pre u) (Either ParseError (UnitExp pre u))
 -> Either ParseError (UnitExp pre u))
-> Reader (SymbolTable pre u) (Either ParseError (UnitExp pre u))
-> Either ParseError (UnitExp pre u)
forall a b. (a -> b) -> a -> b
$ ParsecT [Token] () (Reader (SymbolTable pre u)) (UnitExp pre u)
-> ()
-> String
-> [Token]
-> Reader (SymbolTable pre u) (Either ParseError (UnitExp pre u))
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> String -> s -> m (Either ParseError a)
runParserT (ParsecT [Token] () (Reader (SymbolTable pre u)) (UnitExp pre u)
-> ParsecT [Token] () (Reader (SymbolTable pre u)) (UnitExp pre u)
forall s (m :: * -> *) t u a.
(Stream s m t, Show t) =>
ParsecT s u m a -> ParsecT s u m a
consumeAll ParsecT [Token] () (Reader (SymbolTable pre u)) (UnitExp pre u)
UnitParser_UnitExp
parser) () String
"" [Token]
toks