Eval.hs

{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Module:      Data.Geo.Jord.Eval
-- Copyright:   (c) 2018 Cedric Liegeois
-- License:     BSD3
-- Maintainer:  Cedric Liegeois <ofmooseandmen@yahoo.fr>
-- Stability:   experimental
-- Portability: portable
--
-- Types and functions for evaluating expressions in textual form.
--
module Data.Geo.Jord.Eval
    ( Value(..)
    , Vault
    , Result
    , emptyVault
    , eval
    , functions
    , insert
    , delete
    , lookup
    ) where

import Control.Monad.Fail
import Data.Bifunctor
import Data.Geo.Jord.Angle
import Data.Geo.Jord.GreatCircle
import Data.Geo.Jord.LatLong
import Data.Geo.Jord.Length
import Data.Geo.Jord.NVector
import Data.Geo.Jord.Position
import Data.List hiding (delete, insert, lookup)
import Data.Maybe
import Prelude hiding (fail, lookup)
import Text.ParserCombinators.ReadP
import Text.Read (readMaybe)

-- | A value accepted and returned by 'eval'.
data Value
    = Ang Angle -- ^ 'Angle'
    | AngDec Double -- ^ 'Angle' in decimal degrees
    | Bool Bool -- ^ boolean
    | Double Double -- ^ double
    | Len Length -- ^ 'Length'
    | Gc GreatCircle -- ^ 'GreatCircle'
    | Ll LatLong -- ^ 'LatLong'
    | Lls [LatLong] -- ^ list of 'LatLong'
    | LlDec (Double, Double) -- ^ latitude and longitude in decimal degrees
    | LlsDec [(Double, Double)] -- ^ list of latitude and longitude in decimal degrees
    | Vec NVector -- ^ 'NVector'
    | Vecs [NVector] -- ^ list of 'NVector's
    deriving (Eq, Show)

-- | 'Either' an error or a 'Value'.
type Result = Either String Value

-- | A location for 'Value's to be shared by successive evalations.
newtype Vault =
    Vault [(String, Value)]

-- | An empty 'Vault'.
emptyVault :: Vault
emptyVault = Vault []

instance MonadFail (Either String) where
    fail = Left

-- | Evaluates @s@, an expression of the form @"(f x y ..)"@.
--
-- >>> eval "finalBearing (destination (antipode 54°N,154°E) 54° 1000m) 54°N,154°E"
-- 126°
--
-- @f@ must be one of the supported 'functions' and each parameter @x@, @y@, .. , is either another function call
-- or a 'String' parameter. Parameters are either resolved by name using the 'Resolve'
-- function @r@ or if it returns 'Nothing', 'read' to an 'Angle', a 'Length' or a 'LatLong'.
--
-- If the evaluation is successful, returns the resulting 'Value' ('Right') otherwise
-- a description of the error ('Left').
--
-- @
--     vault = emptyVault
--     angle = eval "finalBearing 54N154E 54S154W" vault -- Right Ang
--     length = eval "distance (antipode 54N154E) 54S154W" vault -- Right Len
--     -- parameter resolution from vault
--     a1 = eval "finalBearing 54N154E 54S154W" vault
--     vault = insert "a1" vault
--     a2 = eval "(finalBearing a1 54S154W)" vault
-- @
--
-- All returned positions are 'LatLong' by default, to get back a 'NVector' the
-- expression must be wrapped by 'toNVector'.
--
-- @
--     dest = eval "destination 54°N,154°E 54° 1000m" -- Right Ll
--     dest = eval "toNVector (destination 54°N,154°E 54° 1000m)" -- Right Vec
-- @
--
-- Every function call must be wrapped between parentheses, however they can be ommitted for the top level call.
--
-- @
--     angle = eval "finalBearing 54N154E 54S154W" -- Right Ang
--     angle = eval "(finalBearing 54N154E 54S154W)" -- Right Ang
--     length = eval "distance (antipode 54N154E) 54S154W" -- Right Len
--     length = eval "distance antipode 54N154E 54S154W" -- Left String
-- @
--
eval :: String -> Vault -> Result
eval s r =
    case expr s of
        Left err -> Left err
        Right (rvec, ex) -> convert (evalExpr ex r) rvec

convert :: Result -> Bool -> Result
convert r True = r
convert r False =
    case r of
        Right (Vec v) -> Right (Ll (fromNVector v))
        Right (Vecs vs) -> Right (Lls (map fromNVector vs))
        oth -> oth

-- | All supported functions:
--
--     * 'antipode'
--
--     * 'crossTrackDistance'
--
--     * 'decimalDegrees'
--
--     * 'destination'
--
--     * 'distance'
--
--     * 'finalBearing'
--
--     * 'greatCircle'
--
--     * 'initialBearing'
--
--     * 'interpolate'
--
--     * 'intersections'
--
--     * 'isInside'
--
--     * 'mean'
--
--     * 'latLong'
--
--     * 'latLongDecimal'
--
--     * 'readLatLong'
--
--     * 'toDecimalDegrees'
--
--     * 'toKilometres'
--
--     * 'toMetres'
--
--     * 'toNauticalMiles'
--
--     * 'toNVector'
--
functions :: [String]
functions =
    [ "antipode"
    , "crossTrackDistance"
    , "destination"
    , "decimalDegrees"
    , "distance"
    , "finalBearing"
    , "greatCircle"
    , "initialBearing"
    , "interpolate"
    , "intersections"
    , "isInside"
    , "latLong"
    , "latLongDecimal"
    , "mean"
    , "readLatLong"
    , "toDecimalDegrees"
    , "toKilometres"
    , "toMetres"
    , "toNauticalMiles"
    , "toNVector"
    ]

-- | @insert k v vault@ inserts value @v@ for key @k@. Overwrites any previous value.
insert :: String -> Value -> Vault -> Vault
insert k v vault = Vault (e ++ [(k, v)])
  where
    Vault e = delete k vault

-- | @lookup k vault@ looks up the value of key @k@ in the vault.
lookup :: String -> Vault -> Maybe Value
lookup k (Vault es) = fmap snd (find (\e -> fst e == k) es)

-- | @delete k vault@ deletes key @k@ from the vault.
delete :: String -> Vault -> Vault
delete k (Vault es) = Vault (filter (\e -> fst e /= k) es)

expr :: (MonadFail m) => String -> m (Bool, Expr)
expr s = do
    ts <- tokenise s
    ast <- parse ts
    fmap (\a -> (expectVec ts, a)) (transform ast)

expectVec :: [Token] -> Bool
expectVec (_:Func "toNVector":_) = True
expectVec _ = False

evalExpr :: Expr -> Vault -> Result
evalExpr (Param p) vault =
    case lookup p vault of
        Just (Ll ll) -> Right (Vec (toNVector ll))
        Just v -> Right v
        Nothing -> tryRead p
evalExpr (Antipode a) vault =
    case evalExpr a vault of
        (Right (Vec p)) -> Right (Vec (antipode p))
        r -> Left ("Call error: antipode " ++ showErr [r])
evalExpr (CrossTrackDistance a b) vault =
    case [evalExpr a vault, evalExpr b vault] of
        [Right (Vec p), Right (Gc gc)] -> Right (Len (crossTrackDistance p gc))
        r -> Left ("Call error: crossTrackDistance " ++ showErr r)
evalExpr (DecimalDegrees d) _ = Right (Ang (decimalDegrees d))
evalExpr (Destination a b c) vault =
    case [evalExpr a vault, evalExpr b vault, evalExpr c vault] of
        [Right (Vec p), Right (Ang a'), Right (Len l)] -> Right (Vec (destination p a' l))
        r -> Left ("Call error: destination " ++ showErr r)
evalExpr (Distance a b) vault =
    case [evalExpr a vault, evalExpr b vault] of
        [Right (Vec p1), Right (Vec p2)] -> Right (Len (distance p1 p2))
        r -> Left ("Call error: distance " ++ showErr r)
evalExpr (FinalBearing a b) vault =
    case [evalExpr a vault, evalExpr b vault] of
        [Right (Vec p1), Right (Vec p2)] -> Right (Ang (finalBearing p1 p2))
        r -> Left ("Call error: finalBearing " ++ showErr r)
evalExpr (GreatCircleSC a b) vault =
    case [evalExpr a vault, evalExpr b vault] of
        [Right (Vec p1), Right (Vec p2)] -> bimap id Gc (greatCircleE p1 p2)
        [Right (Vec p), Right (Ang a')] -> Right (Gc (greatCircleBearing p a'))
        r -> Left ("Call error: greatCircle " ++ showErr r)
evalExpr (InitialBearing a b) vault =
    case [evalExpr a vault, evalExpr b vault] of
        [Right (Vec p1), Right (Vec p2)] -> Right (Ang (initialBearing p1 p2))
        r -> Left ("Call error: initialBearing " ++ showErr r)
evalExpr (Interpolate a b c) vault =
    case [evalExpr a vault, evalExpr b vault] of
        [Right (Vec p1), Right (Vec p2)] -> Right (Vec (interpolate p1 p2 c))
        r -> Left ("Call error: interpolate " ++ showErr r)
evalExpr (Intersections a b) vault =
    case [evalExpr a vault, evalExpr b vault] of
        [Right (Gc gc1), Right (Gc gc2)] ->
            maybe
                (Right (Vecs []))
                (\is -> Right (Vecs [fst is, snd is]))
                (intersections gc1 gc2 :: Maybe (NVector, NVector))
        r -> Left ("Call error: intersections " ++ showErr r)
evalExpr (IsInside as) vault =
    let m = map (`evalExpr` vault) as
        ps = [p | Right (Vec p) <- m]
     in if length m == length ps && length ps > 3
            then Right (Bool (isInside (head ps) (tail ps)))
            else Left ("Call error: isInside " ++ showErr m)
evalExpr (Mean as) vault =
    let m = map (`evalExpr` vault) as
        ps = [p | Right (Vec p) <- m]
     in if length m == length ps
            then maybe (Left ("Call error: mean " ++ showErr m)) (Right . Vec) (mean ps)
            else Left ("Call error: mean " ++ showErr m)
evalExpr (LatLong a b) vault =
    case [evalExpr a vault, evalExpr b vault] of
        [Right (Ang lat), Right (Ang lon)] ->
            bimap (\e -> "Call error: latLong : " ++ e) (Vec . toNVector) (latLongE lat lon)
        r -> Left ("Call error: latLong " ++ showErr r)
evalExpr (LatLongDecimal a b) _ =
    bimap (\e -> "Call error: LatLongDecimal : " ++ e) (Vec . toNVector) (latLongDecimalE a b)
evalExpr (ReadLatLong s) _ =
    bimap (\e -> "Call error: readLatLong : " ++ e) (Vec . toNVector) (readLatLongE s)
evalExpr (ToDecimalDegrees e) vault =
    case evalExpr e vault of
        (Right (Ang a)) -> Right (AngDec (toDecimalDegrees a))
        (Right (Ll p)) -> Right (LlDec (toDecimalDegrees' p))
        (Right (Lls ps)) -> Right (LlsDec (map toDecimalDegrees' ps))
        (Right (Vec p)) -> Right (LlDec ((toDecimalDegrees' . fromNVector) p))
        (Right (Vecs ps)) -> Right (LlsDec (map (toDecimalDegrees' . fromNVector) ps))
        r -> Left ("Call error: toDecimalDegrees" ++ showErr [r])
evalExpr (ToKilometres e) vault =
    case evalExpr e vault of
        (Right (Len l)) -> Right (Double (toKilometres l))
        r -> Left ("Call error: toKilometres" ++ showErr [r])
evalExpr (ToMetres e) vault =
    case evalExpr e vault of
        (Right (Len l)) -> Right (Double (toMetres l))
        r -> Left ("Call error: toMetres" ++ showErr [r])
evalExpr (ToNauticalMiles e) vault =
    case evalExpr e vault of
        (Right (Len l)) -> Right (Double (toNauticalMiles l))
        r -> Left ("Call error: toNauticalMiles" ++ showErr [r])
evalExpr (ToNVector a) vault =
    case evalExpr a vault of
        r@(Right (Vec _)) -> r
        r -> Left ("Call error: toNVector " ++ showErr [r])

showErr :: [Result] -> String
showErr rs = " > " ++ intercalate " & " (map (either id show) rs)

tryRead :: String -> Result
tryRead s =
    case r of
        [a@(Right (Ang _)), _, _] -> a
        [_, l@(Right (Len _)), _] -> l
        [_, _, Right (Ll ll)] -> Right (Vec (toNVector ll))
        _ -> Left ("couldn't read " ++ s)
  where
    r = map ($ s) [readE readAngleE Ang, readE readLengthE Len, readE readLatLongE Ll]

readE :: (String -> Either String a) -> (a -> Value) -> String -> Either String Value
readE p v s = bimap id v (p s)

------------------------------------------
--  Lexical Analysis: String -> [Token] --
------------------------------------------
data Token
    = Paren Char
    | Func String
    | Str String
    deriving (Show)

tokenise :: (MonadFail m) => String -> m [Token]
tokenise s
    | null r = fail ("Lexical error: " ++ s)
    | (e, "") <- last r = return (wrap e)
    | otherwise = fail ("Lexical error: " ++ snd (last r))
  where
    r = readP_to_S tokens s

-- | wraps top level expression between () if needed.
wrap :: [Token] -> [Token]
wrap ts
    | null ts = ts
    | (Paren '(') <- head ts = ts
    | otherwise = Paren '(' : ts ++ [Paren ')']

tokens :: ReadP [Token]
tokens = many1 token

token :: ReadP Token
token = (<++) ((<++) paren func) str

paren :: ReadP Token
paren = (<++) parenO parenC

parenO :: ReadP Token
parenO = do
    optional (char ' ')
    c <- char '('
    return (Paren c)

parenC :: ReadP Token
parenC = do
    c <- char ')'
    optional (char ' ')
    return (Paren c)

func :: ReadP Token
func = do
    n <- choice (map string functions)
    _ <- char ' '
    return (Func n)

str :: ReadP Token
str = do
    optional (char ' ')
    v <- munch1 (\c -> c /= '(' && c /= ')' && c /= ' ')
    if v `elem` functions
        then pfail
        else return (Str v)

-----------------------------------------
--  Syntactic Analysis: [Token] -> Ast --
-----------------------------------------
data Ast
    = Call String
           [Ast]
    | Lit String
    deriving (Show)

-- | syntax is (f x y) where x and y can be function themselves.
parse :: (MonadFail m) => [Token] -> m Ast
parse ts = fmap fst (walk ts)

walk :: (MonadFail m) => [Token] -> m (Ast, [Token])
walk [] = fail "Syntax error: empty"
walk (h:t)
    | (Str s) <- h = return (Lit s, t)
    | (Paren '(') <- h = walkFunc t
    | otherwise = fail ("Syntax error: expected String or '(' but got " ++ show h)

walkFunc :: (MonadFail m) => [Token] -> m (Ast, [Token])
walkFunc [] = fail "Syntax error: '(' unexpected"
walkFunc (h:t)
    | (Func n) <- h = walkParams n t []
    | otherwise = fail ("Syntax error: expected Function but got " ++ show h)

walkParams :: (MonadFail m) => String -> [Token] -> [Ast] -> m (Ast, [Token])
walkParams _ [] _ = fail "Syntax error: ')' not found"
walkParams n ts@(h:t) acc
    | (Paren ')') <- h = return (Call n (reverse acc), t)
    | otherwise = do
        (el, t') <- walk ts
        walkParams n t' (el : acc)

-------------------------------------
--  Semantic Analysis: Ast -> Expr --
-------------------------------------
data Expr
    = Param String
    | Antipode Expr
    | CrossTrackDistance Expr
                         Expr
    | DecimalDegrees Double
    | Destination Expr
                  Expr
                  Expr
    | Distance Expr
               Expr
    | FinalBearing Expr
                   Expr
    | GreatCircleSC Expr
                    Expr
    | InitialBearing Expr
                     Expr
    | Interpolate Expr
                  Expr
                  Double
    | Intersections Expr
                    Expr
    | IsInside [Expr]
    | Mean [Expr]
    | LatLong Expr
              Expr
    | LatLongDecimal Double
                     Double
    | ReadLatLong String
    | ToDecimalDegrees Expr
    | ToKilometres Expr
    | ToMetres Expr
    | ToNauticalMiles Expr
    | ToNVector Expr
    deriving (Show)

transform :: (MonadFail m) => Ast -> m Expr
transform (Call "antipode" [e]) = fmap Antipode (transform e)
transform (Call "crossTrackDistance" [e1, e2]) = do
    p <- transform e1
    gc <- transform e2
    return (CrossTrackDistance p gc)
transform (Call "decimalDegrees" [Lit s]) = fmap DecimalDegrees (readDouble s)
transform (Call "destination" [e1, e2, e3]) = do
    p1 <- transform e1
    p2 <- transform e2
    p3 <- transform e3
    return (Destination p1 p2 p3)
transform (Call "distance" [e1, e2]) = do
    p1 <- transform e1
    p2 <- transform e2
    return (Distance p1 p2)
transform (Call "finalBearing" [e1, e2]) = do
    p1 <- transform e1
    p2 <- transform e2
    return (FinalBearing p1 p2)
transform (Call "greatCircle" [e1, e2]) = do
    p1 <- transform e1
    p2 <- transform e2
    return (GreatCircleSC p1 p2)
transform (Call "initialBearing" [e1, e2]) = do
    p1 <- transform e1
    p2 <- transform e2
    return (InitialBearing p1 p2)
transform (Call "interpolate" [e1, e2, Lit s]) = do
    p1 <- transform e1
    p2 <- transform e2
    d <- readDouble s
    if d >= 0.0 && d <= 1.0
        then return (Interpolate p1 p2 d)
        else fail "Semantic error: interpolate expects [0..1] as last argument"
transform (Call "intersections" [e1, e2]) = do
    gc1 <- transform e1
    gc2 <- transform e2
    return (Intersections gc1 gc2)
transform (Call "isInside" e) = do
    ps <- mapM transform e
    return (IsInside ps)
transform (Call "latLong" [e1, e2]) = do
    gc1 <- transform e1
    gc2 <- transform e2
    return (LatLong gc1 gc2)
transform (Call "latLongDecimal" [Lit s1, Lit s2]) = do
    d1 <- readDouble s1
    d2 <- readDouble s2
    return (LatLongDecimal d1 d2)
transform (Call "mean" e) = do
    ps <- mapM transform e
    return (Mean ps)
transform (Call "readLatLong" [Lit s]) = return (ReadLatLong s)
transform (Call "toDecimalDegrees" [e]) = fmap ToDecimalDegrees (transform e)
transform (Call "toKilometres" [e]) = fmap ToKilometres (transform e)
transform (Call "toMetres" [e]) = fmap ToMetres (transform e)
transform (Call "toNauticalMiles" [e]) = fmap ToNauticalMiles (transform e)
transform (Call "toNVector" [e]) = fmap ToNVector (transform e)
transform (Call f e) = fail ("Semantic error: " ++ f ++ " does not accept " ++ show e)
transform (Lit s) = return (Param s)

readDouble :: (MonadFail m) => String -> m Double
readDouble s =
    case readMaybe s of
        Just d -> return d
        Nothing -> fail ("Unparsable double: " ++ s)