{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}


module Language.REST.Types (
    prettyPrint
  , PPArgs(..)
  , Relation(..)
  , toOrderedSet
  ) where

import GHC.Generics (Generic)
import Prelude hiding (GT, EQ)

import           Data.Hashable
import qualified Data.List as L
import qualified Data.HashSet as S
import qualified Data.Set as OS
import qualified Data.Text as T
import           Text.Printf

import           Language.REST.Op
import           Language.REST.MetaTerm as MT

-- | Arguments used for pretty-printing terms
data PPArgs = PPArgs
  {
    -- | A list of pairs @(search, rep)@. If any operator starts with @search@
    --   for some element in the list, during the printing the operator is
    --   printed with the corresponding @rep@ in place of @search@.
    PPArgs -> [(Text, Text)]
ppReplace  :: [(T.Text, T.Text)]

    -- | A list of pairs @(search, rep)@. If any operator matches @search@, then it's
    --   corresponding term is printed in infix style with operator @rep@.
  , PPArgs -> [(Text, Text)]
ppInfixOps :: [(T.Text, T.Text)]

    -- | Used to override printing for some terms. When @ppCustom m = Just s@, then @m@
    --   be printed as @s@.
  , PPArgs -> MetaTerm -> Maybe Text
ppCustom   :: MetaTerm -> Maybe T.Text
  }

prettyPrint :: ToMetaTerm a => PPArgs -> a -> String
prettyPrint :: forall a. ToMetaTerm a => PPArgs -> a -> String
prettyPrint (PPArgs [(Text, Text)]
substs [(Text, Text)]
infixOps MetaTerm -> Maybe Text
custom) a
t = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ MetaTerm -> Text
go forall a b. (a -> b) -> a -> b
$ MetaTerm -> MetaTerm
replaceAll forall a b. (a -> b) -> a -> b
$ forall a. ToMetaTerm a => a -> MetaTerm
toMetaTerm a
t where

  replace :: Text -> Text
replace Text
s | Just (Text
from, Text
to) <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((Text -> Text -> Bool
`T.isPrefixOf` Text
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Text)]
substs
            = Text -> Text -> Text
T.append Text
to forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop (Text -> Int
T.length Text
from) Text
s
  replace Text
s  = Text
s

  replaceAll :: MT.MetaTerm -> MT.MetaTerm
  replaceAll :: MetaTerm -> MetaTerm
replaceAll (MT.Var String
x)            = String -> MetaTerm
MT.Var String
x
  replaceAll (MT.RWApp (Op Text
op) [MetaTerm]
ts) = Op -> [MetaTerm] -> MetaTerm
MT.RWApp (Text -> Op
Op (Text -> Text
replace Text
op)) (forall a b. (a -> b) -> [a] -> [b]
map MetaTerm -> MetaTerm
replaceAll [MetaTerm]
ts)



  go :: MT.MetaTerm -> T.Text
  go :: MetaTerm -> Text
go (MT.Var String
x) = String -> Text
T.pack String
x
  go MetaTerm
mt | Just Text
s <- MetaTerm -> Maybe Text
custom MetaTerm
mt    = Text
s
  go (MT.RWApp (Op Text
op) [MetaTerm
t1, MetaTerm
t2]) | Just Text
op' <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Text
op [(Text, Text)]
infixOps
    = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%s %s %s" (MetaTerm -> Text
goParens MetaTerm
t1) Text
op' (MetaTerm -> Text
goParens MetaTerm
t2)
  go (MT.RWApp (Op Text
op) [])       = Text
op
  go (MT.RWApp (Op Text
op) [MetaTerm]
xs)       = [Text] -> Text
T.concat [Text
op, Text
"(" , Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map MetaTerm -> Text
go [MetaTerm]
xs) , Text
")"]

  goParens :: MetaTerm -> Text
goParens MetaTerm
mt | MetaTerm -> Bool
needsParens MetaTerm
mt = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"(%s)" (MetaTerm -> Text
go MetaTerm
mt)
  goParens MetaTerm
mt       = MetaTerm -> Text
go MetaTerm
mt

  needsParens :: MetaTerm -> Bool
needsParens (MT.RWApp (Op Text
op) [MetaTerm]
_) = Text
op forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Text)]
infixOps
  needsParens MetaTerm
_                    = Bool
False

data Relation = GT | GTE | EQ deriving (Relation -> Relation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Relation -> Relation -> Bool
$c/= :: Relation -> Relation -> Bool
== :: Relation -> Relation -> Bool
$c== :: Relation -> Relation -> Bool
Eq, forall x. Rep Relation x -> Relation
forall x. Relation -> Rep Relation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Relation x -> Relation
$cfrom :: forall x. Relation -> Rep Relation x
Generic, Eq Relation
Int -> Relation -> Int
Relation -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Relation -> Int
$chash :: Relation -> Int
hashWithSalt :: Int -> Relation -> Int
$chashWithSalt :: Int -> Relation -> Int
Hashable)

instance Show Relation where
  show :: Relation -> String
show Relation
GT  = String
">"
  show Relation
GTE = String
"≥"
  show Relation
EQ  = String
"≅"


toOrderedSet :: (Eq a, Hashable a, Ord a) => S.HashSet a -> OS.Set a
toOrderedSet :: forall a. (Eq a, Hashable a, Ord a) => HashSet a -> Set a
toOrderedSet = forall a. Ord a => [a] -> Set a
OS.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashSet a -> [a]
S.toList