units-2.3: Tests/Parser.hs

{- Test the unit parser
   Copyright (c) 2014 Richard Eisenberg
-}

{-# LANGUAGE TemplateHaskell #-}

module Tests.Parser where

import Prelude hiding ( lex, exp )

import Data.Metrology.Parser
import Data.Metrology.SI

import Language.Haskell.TH
import Data.Generics

import Test.Tasty
import Test.Tasty.HUnit

leftOnly :: Either a b -> Maybe a
leftOnly (Left a) = Just a
leftOnly (Right _) = Nothing

----------------------------------------------------------------------
-- TH functions
----------------------------------------------------------------------

stripModules :: Data a => a -> a
stripModules = everywhere (mkT (mkName . nameBase))

pprintUnqualified :: (Ppr a, Data a) => a -> String
pprintUnqualified = pprint . stripModules

testSymbolTable :: SymbolTable Name Name
Right testSymbolTable =
   mkSymbolTable (stripModules [ ("k", ''Kilo)
                               , ("da", ''Deca)
                               , ("m", ''Milli)
                               , ("d", ''Deci) ])
                 (stripModules [ ("m", ''Meter)
                               , ("s", ''Second)
                               , ("min", ''Minute)
                               , ("am", ''Ampere) ])

----------------------------------------------------------------------
-- Overall parser
----------------------------------------------------------------------

parseUnitTest :: String -> String
parseUnitTest s =
  case parseUnitExp testSymbolTable s of
    Left _    -> "error"
    Right exp -> pprintUnqualified exp

parseTestCases :: [(String, String)]
parseTestCases =
  [ ("m", "undefined :: Meter")
  , ("s", "undefined :: Second")
  , ("ms", "(:@) (undefined :: Milli) (undefined :: Second)")
  , ("mm", "(:@) (undefined :: Milli) (undefined :: Meter)")
  , ("mmm", "error")
  , ("km", "(:@) (undefined :: Kilo) (undefined :: Meter)")
  , ("m s", "(:*) (undefined :: Meter) (undefined :: Second)")
  , ("m/s", "(:/) (undefined :: Meter) (undefined :: Second)")
  , ("m/s^2", "(:/) (undefined :: Meter) ((:^) (undefined :: Second) (sSucc (sSucc sZero)))")
  , ("s/m m", "(:/) (undefined :: Second) ((:*) (undefined :: Meter) (undefined :: Meter))")
  , ("s s/m m", "(:/) ((:*) (undefined :: Second) (undefined :: Second)) ((:*) (undefined :: Meter) (undefined :: Meter))")
  , ("s*s/m*m", "(:*) ((:/) ((:*) (undefined :: Second) (undefined :: Second)) (undefined :: Meter)) (undefined :: Meter)")
  , ("s*s/(m*m)", "(:/) ((:*) (undefined :: Second) (undefined :: Second)) ((:*) (undefined :: Meter) (undefined :: Meter))")
  , ("m^-1", "(:^) (undefined :: Meter) (sPred sZero)")
  , ("m^(-1)", "(:^) (undefined :: Meter) (sPred sZero)")
  , ("m^(-(1))", "(:^) (undefined :: Meter) (sPred sZero)")
  , ("1", "Number")
  , ("1/s", "(:/) Number (undefined :: Second)")
  , ("m 1 m", "(:*) ((:*) (undefined :: Meter) Number) (undefined :: Meter)")
  , ("  ", "Number")
  , ("", "Number")
  ]

parseUnitTests :: TestTree
parseUnitTests = testGroup "ParseUnit" $
  map (\(str, out) -> testCase ("`" ++ str ++ "'") $ parseUnitTest str @?= out)
    parseTestCases

parseUnitTestT :: String -> String
parseUnitTestT s =
  case parseUnitType testSymbolTable s of
    Left _    -> "error"
    Right exp -> pprintUnqualified exp

parseTestCasesT :: [(String, String)]
parseTestCasesT =
  [ ("m", "Meter")
  , ("s", "Second")
  , ("ms", ":@ Milli Second")
  , ("mm", ":@ Milli Meter")
  , ("mmm", "error")
  , ("km", ":@ Kilo Meter")
  , ("m s", ":* Meter Second")
  , ("m/s", ":/ Meter Second")
  , ("m/s^2", ":/ Meter (:^ Second (Succ (Succ Zero)))")
  , ("s/m m", ":/ Second (:* Meter Meter)")
  , ("s s/m m", ":/ (:* Second Second) (:* Meter Meter)")
  , ("s*s/m*m", ":* (:/ (:* Second Second) Meter) Meter")
  , ("s*s/(m*m)", ":/ (:* Second Second) (:* Meter Meter)")
  , ("m^-1", ":^ Meter (Pred Zero)")
  , ("m^(-1)", ":^ Meter (Pred Zero)")
  , ("m^(-(1))", ":^ Meter (Pred Zero)")
  , ("1", "Number")
  , ("1/s", ":/ Number Second")
  , ("m 1 m", ":* (:* Meter Number) Meter")
  , ("  ", "Number")
  , ("", "Number")
  ]

parseUnitTestsT :: TestTree
parseUnitTestsT = testGroup "ParseUnitType" $
  map (\(str, out) -> testCase ("`" ++ str ++ "'") $ parseUnitTestT str @?= out)
    parseTestCasesT

----------------------------------------------------------------------
-- Conclusion
----------------------------------------------------------------------

tests :: TestTree
tests = testGroup "Parser"
  [ parseUnitTests
  , parseUnitTestsT
  ]