{-# 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 (liftM, void)
import Control.Monad.Reader (MonadReader(..), Reader, asks, runReader)
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 :: forall a b c. (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
bforall a. a -> [a] -> [a]
:[b]
bs, [c]
cs)
                         Right c
c -> ([b]
bs, c
cforall a. a -> [a] -> [a]
:[c]
cs)
    where ([b]
bs,[c]
cs) = 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 :: forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
experiment = forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall s (m :: * -> *) t u a.
(Stream s m t, Show t) =>
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
  forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
  forall (m :: * -> *) a. Monad m => a -> m a
return a
result

nochar :: Stream s m Char => Char -> ParsecT s u m ()
nochar :: forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m ()
nochar = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall a. Show a => a -> String
show Integer
i
  show (OpT Op
op)    = 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
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, UnitExp pre u -> UnitExp pre u -> Ordering
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
Ord, 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, UnitExp pre u -> DataType
UnitExp pre u -> Constr
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 {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 (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 e. (Data d, Data e) => c (t d e))
-> Maybe (c (UnitExp pre u))
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(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 (m :: * -> *).
MonadPlus m =>
(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 (m :: * -> *).
Monad m =>
(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 :: forall u. 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 u. (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 :: forall r r'.
(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 :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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)
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) = forall a. Show a => a -> String
show pre
pre forall a. [a] -> [a] -> [a]
++ String
" :@ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show u
u
  show (Unit Maybe pre
Nothing u
u)    = forall a. Show a => a -> String
show u
u
  show (Mult UnitExp pre u
e1 UnitExp pre u
e2)        = String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UnitExp pre u
e1 forall a. [a] -> [a] -> [a]
++ String
" :* " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UnitExp pre u
e2 forall a. [a] -> [a] -> [a]
++ String
")"
  show (Div UnitExp pre u
e1 UnitExp pre u
e2)         = String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UnitExp pre u
e1 forall a. [a] -> [a] -> [a]
++ String
" :/ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UnitExp pre u
e2 forall a. [a] -> [a] -> [a]
++ String
")"
  show (Pow UnitExp pre u
e Integer
i)           = forall a. Show a => a -> String
show UnitExp pre u
e forall a. [a] -> [a] -> [a]
++ String
" :^ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
i

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

type Lexer = Parser

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

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

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

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

lex :: String -> Either ParseError [Token]
lex :: String -> Either ParseError [Token]
lex = 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 { forall pre u. SymbolTable pre u -> PrefixTable pre
prefixTable :: PrefixTable pre
                                     , forall pre u. SymbolTable pre u -> UnitTable u
unitTable   :: UnitTable u
                                     } deriving (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 :: forall a b.
(Ord a, Show b) =>
[(a, b)] -> Either [(a, [String])] (Map a b)
unambFromList [(a, b)]
list =
  let multimap :: MultiMap a b
multimap      = forall k a. Ord k => [(k, a)] -> MultiMap k a
MM.fromList [(a, b)]
list
      assocs :: [(a, [b])]
assocs        = forall k a. MultiMap k a -> [(k, [a])]
MM.assocs MultiMap a b
multimap
      ([(a, [String])]
errs, [(a, b)]
goods) = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (\(a
key, [b]
vals) ->
                                       case [b]
vals of
                                         [b
val] -> forall a b. b -> Either a b
Right (a
key, b
val)
                                         [b]
_     -> forall a b. a -> Either a b
Left (a
key, forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [b]
vals)) [(a, [b])]
assocs
      result :: Map a b
result        = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(a, b)]
goods
  in
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, [String])]
errs then forall a b. b -> Either a b
Right Map a b
result else 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 :: forall pre u.
(Show pre, Show u) =>
[(String, pre)]
-> [(String, u)] -> Either String (SymbolTable pre u)
mkSymbolTable [(String, pre)]
prefixes [(String, u)]
units =
  let bad_strings :: [String]
bad_strings = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isLetter) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, pre)]
prefixes forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, u)]
units) in
  if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad_strings)
  then forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"All prefixes and units must be composed entirely of letters.\nThe following are illegal: " forall a. [a] -> [a] -> [a]
++ 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 <- forall a b.
(Ord a, Show b) =>
[(a, b)] -> Either [(a, [String])] (Map a b)
unambFromList [(String, pre)]
prefixes
        Map String u
unitTab   <- forall a b.
(Ord a, Show b) =>
[(a, b)] -> Either [(a, [String])] (Map a b)
unambFromList [(String, u)]
units
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SymbolTable { prefixTable :: Map String pre
prefixTable = Map String pre
prefixTab, unitTable :: UnitTable u
unitTable = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map String u
unitTab }
  in forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ((forall a. [a] -> [a] -> [a]
++ String
error_suffix) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 :: forall x. Show x => (String, [x]) -> String
mk_error_string (String
k, [x]
vs) =
      String
"The label `" forall a. [a] -> [a] -> [a]
++ String
k forall a. [a] -> [a] -> [a]
++ String
"' is assigned to the following meanings:\n" forall a. [a] -> [a] -> [a]
++
      forall a. Show a => a -> String
show [x]
vs 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 :: forall pre u. PrefixTable pre -> UnitTable u -> SymbolTable pre u
unsafeMkSymbolTable = 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 :: forall a. SymbolTable a String
universalSymbolTable = forall pre u. PrefixTable pre -> UnitTable u -> SymbolTable pre u
SymbolTable forall k a. Map k a
Map.empty 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 :: forall pre u. GenUnitStringParser pre u u
justUnitP = do
  String
full_string <- forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
  UnitTable u
units <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall pre u. SymbolTable pre u -> UnitTable u
unitTable
  case UnitTable u
units String
full_string of
    Maybe u
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
full_string forall a. [a] -> [a] -> [a]
++ String
" does not match any known unit")
    Just 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 :: UnitStringParser_UnitExp
prefixUnitP = do
  PrefixTable pre
prefixTab <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall pre u. SymbolTable pre u -> PrefixTable pre
prefixTable
  let assocs :: [(String, pre)]
assocs = forall k a. Map k a -> [(k, a)]
Map.assocs PrefixTable pre
prefixTab  -- these are in the right order
  [(pre, u)]
results <- forall a. [Maybe a] -> [a]
catMaybes forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
experiment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pre u. (String, pre) -> GenUnitStringParser pre u (pre, u)
parse_one) [(String, pre)]
assocs
  String
full_string <- forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
  case [(pre, u)]
results of
    [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"No known interpretation for " forall a. [a] -> [a] -> [a]
++ String
full_string
    [(pre
pre_name, u
unit_name)] ->
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall pre u. Maybe pre -> u -> UnitExp pre u
Unit (forall a. a -> Maybe a
Just pre
pre_name) u
unit_name
    [(pre, u)]
lots -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Multiple possible interpretations for " forall a. [a] -> [a] -> [a]
++ String
full_string forall a. [a] -> [a] -> [a]
++ String
":\n" forall a. [a] -> [a] -> [a]
++
                   (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(pre
pre_name, u
unit_name) ->
                                 String
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show pre
pre_name forall a. [a] -> [a] -> [a]
++
                                 String
" :@ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show u
unit_name forall a. [a] -> [a] -> [a]
++ String
"\n") [(pre, u)]
lots)
  where
    parse_one :: (String, pre) -> GenUnitStringParser pre u (pre, u)
    parse_one :: forall pre u. (String, pre) -> GenUnitStringParser pre u (pre, u)
parse_one (String
pre, pre
name) = do
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
pre
      u
unit_name <- forall pre u. GenUnitStringParser pre u u
justUnitP
      forall (m :: * -> *) a. Monad m => a -> m a
return (pre
name, u
unit_name)

-- parse a unit string
unitStringParser :: UnitStringParser_UnitExp
unitStringParser :: UnitStringParser_UnitExp
unitStringParser = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall pre u. Maybe pre -> u -> UnitExp pre u
Unit forall a. Maybe a
Nothing forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall pre u. GenUnitStringParser pre u u
justUnitP) forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> 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 (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 :: forall a. (Token -> Maybe a) -> UnitParser a
uToken Token -> Maybe a
x = 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 forall a. Show a => a -> String
show SourcePos -> Token -> [Token] -> SourcePos
updatePosToken Token -> Maybe a
x

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

-- consume an rparen
rparenP :: UnitParser ()
rparenP :: UnitParser ()
rparenP = forall a. (Token -> Maybe a) -> UnitParser a
uToken forall a b. (a -> b) -> a -> b
$ \case
  OpT Op
CloseP -> forall a. a -> Maybe a
Just ()
  Token
_          -> 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 <- forall r (m :: * -> *). MonadReader r m => m r
ask
  case forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader SymbolTable pre u
symbolTable forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> String -> s -> m (Either ParseError a)
runParserT UnitStringParser_UnitExp
unitStringParser () String
"" String
str of
    Left ParseError
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show ParseError
err)
    Right UnitExp pre u
e  -> 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 :: UnitParser Integer
numP =
  do UnitParser ()
lparenP
     Integer
n <- UnitParser Integer
numP
     UnitParser ()
rparenP
     forall (m :: * -> *) a. Monad m => a -> m a
return Integer
n
  forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
  do forall a. (Token -> Maybe a) -> UnitParser a
uToken forall a b. (a -> b) -> a -> b
$ \case
       OpT Op
NegO -> forall a. a -> Maybe a
Just ()
       Token
_        -> forall a. Maybe a
Nothing
     forall a. Num a => a -> a
negate forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` UnitParser Integer
numP
  forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
  do forall a. (Token -> Maybe a) -> UnitParser a
uToken forall a b. (a -> b) -> a -> b
$ \case
       NumberT Integer
i -> forall a. a -> Maybe a
Just Integer
i
       Token
_         -> forall a. Maybe a
Nothing

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

-- parse a unit, possibly with an exponent
unitP :: UnitParser_UnitExp
unitP :: UnitParser_UnitExp
unitP =
  do Integer
n <- UnitParser Integer
numP
     case Integer
n of
       Integer
1 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall pre u. UnitExp pre u
Unity
       Integer
_ -> forall s (m :: * -> *) t u a.
Stream s m t =>
String -> ParsecT s u m a
unexpected forall a b. (a -> b) -> a -> b
$ String
"number " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
n
  forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
  do String
unit_str <- forall a. (Token -> Maybe a) -> UnitParser a
uToken forall a b. (a -> b) -> a -> b
$ \case
       UnitT String
unit_str -> forall a. a -> Maybe a
Just String
unit_str
       Token
_              -> forall a. Maybe a
Nothing
     UnitExp pre u
u <- String -> UnitParser_UnitExp
unitStringP String
unit_str
     UnitExp pre u -> UnitExp pre u
maybe_pow <- forall pre u. GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
powP
     forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: UnitParser_UnitExp
unitFactorP =
  do UnitParser ()
lparenP
     UnitExp pre u
unitExp <- UnitParser_UnitExp
parser
     UnitParser ()
rparenP
     forall (m :: * -> *) a. Monad m => a -> m a
return UnitExp pre u
unitExp
  forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
  (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall pre u. UnitExp pre u -> UnitExp pre u -> UnitExp pre u
Mult forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 UnitParser_UnitExp
unitP)

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

-- parse a whole unit expression
parser :: UnitParser_UnitExp
parser :: UnitParser_UnitExp
parser = 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 UnitParser_UnitExp
unitFactorP forall pre u.
GenUnitParser
  pre u (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
opP 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 :: forall pre u.
(Show pre, Show u) =>
SymbolTable pre u -> String -> Either String (UnitExp pre u)
parseUnit SymbolTable pre u
tab String
s = forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ do
  [Token]
toks <- String -> Either ParseError [Token]
lex String
s
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader SymbolTable pre u
tab forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> String -> s -> m (Either ParseError a)
runParserT (forall s (m :: * -> *) t u a.
(Stream s m t, Show t) =>
ParsecT s u m a -> ParsecT s u m a
consumeAll UnitParser_UnitExp
parser) () String
"" [Token]
toks