Read.hs

{-# OPTIONS -fno-implicit-prelude #-}
{- |
Copyright   :  (c) Henning Thielemann 2004
License     :  GPL

Maintainer  :  numericprelude@henning-thielemann.de
Stability   :  provisional
Portability :  multi-parameter type classes (VectorSpace.hs)

Convert a human readable string to a physical value.
-}

module Number.Physical.Read where

import qualified Number.Physical        as Value
import qualified Number.Physical.UnitDatabase as Db
import qualified Algebra.VectorSpace as VectorSpace
-- import Algebra.Module((*>))
import qualified Algebra.Field       as Field
import qualified Data.Map as Map
import Data.Map (Map)
import Text.ParserCombinators.Parsec
import Control.Monad(liftM)

import PreludeBase
import NumericPrelude

mulPrec :: Int
mulPrec = 7

-- How to handle the 'prec' argument?
readsNat :: (Enum i, Ord i, Read v, VectorSpace.C a v) =>
   Db.T i a -> Int -> ReadS (Value.T i v)
readsNat db prec =
   readParen (prec>=mulPrec)
      (map (\(x, rest) ->
             let (Value.Cons cu c, rest') = readUnitPart (createDict db) rest
             in  (Value.Cons cu (c *> x), rest'))
       .
       readsPrec mulPrec)

readUnitPart :: (Ord i, Field.C a) =>
   Map String (Value.T i a)
      -> String -> (Value.T i a, String)
readUnitPart dict str =
   let parseUnit =
          do p    <- parseProduct
             rest <- many anyChar
             return (product (map (\(unit,n) ->
                        Map.findWithDefault
                           (error ("unknown unit '" ++ unit ++ "'")) unit dict
                           ^ n) p),
                     rest)
   in  case parse parseUnit "unit" str of
          Left  msg -> error (show msg)
          Right val -> val


{-| This function could also return the value,
    but a list of pairs (String, Integer) is easier for testing. -}
parseProduct :: Parser [(String, Integer)]
parseProduct =
   skipMany space >>
      ((do p <- ignoreSpace parsePower
           t <- parseProductTail
           return (p : t)) <|>
       parseProductTail)

parseProductTail :: Parser [(String, Integer)]
parseProductTail =
   let parseTail c f = 
         do ignoreSpace (char c)
            p <- ignoreSpace parsePower
            t <- parseProductTail
            return (f p : t)
   in  parseTail '*' id <|>
       parseTail '/' (\(x,n) -> (x,-n)) <|>
       return []

parsePower :: Parser (String, Integer)
parsePower =
   do w <- ignoreSpace (many1 (letter <|> char '\181'))
      e <- liftM read (ignoreSpace (char '^') >> many1 digit) <|> return 1
      return (w,e)

{- Turns a parser into one that ignores subsequent whitespaces. -}
ignoreSpace :: Parser a -> Parser a
ignoreSpace p =
   do x <- p
      skipMany space
      return x


createDict :: Db.T i a -> Map String (Value.T i a)
createDict db =
   Map.fromList (concatMap
      (\Db.UnitSet {Db.unit = xu, Db.scales = s}
           -> map (\Db.Scale {Db.symbol = sym, Db.magnitude = x}
                       -> (sym, Value.Cons xu x)) s) db)