{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# 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

data PPArgs = PPArgs
  { PPArgs -> [(Text, Text)]
ppReplace  :: [(T.Text, T.Text)]
  , PPArgs -> [(Text, Text)]
ppInfixOps :: [(T.Text, T.Text)]
  , PPArgs -> MetaTerm -> Maybe Text
ppCustom   :: MetaTerm -> Maybe T.Text
  }

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

  replace :: Text -> Text
replace Text
s | Just (Text
from, Text
to) <- ((Text, Text) -> Bool) -> [(Text, Text)] -> Maybe (Text, Text)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((Text -> Text -> Bool
`T.isPrefixOf` Text
s) (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) [(Text, Text)]
substs
            = Text -> Text -> Text
T.append Text
to (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop (Text -> Int
T.length Text
from) Text
s
  replace Text
s | Bool
otherwise = 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)) ((MetaTerm -> MetaTerm) -> [MetaTerm] -> [MetaTerm]
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' <- Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Text
op [(Text, Text)]
infixOps
    = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text -> Text -> Text -> String
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
", " ((MetaTerm -> Text) -> [MetaTerm] -> [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 (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text -> String
forall r. PrintfType r => String -> r
printf String
"(%s)" (MetaTerm -> Text
go MetaTerm
mt)
  goParens MetaTerm
mt | Bool
otherwise      = MetaTerm -> Text
go MetaTerm
mt

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

data Relation = GT | GTE | EQ deriving (Relation -> Relation -> Bool
(Relation -> Relation -> Bool)
-> (Relation -> Relation -> Bool) -> Eq Relation
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. Relation -> Rep Relation x)
-> (forall x. Rep Relation x -> Relation) -> Generic Relation
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, Int -> Relation -> Int
Relation -> Int
(Int -> Relation -> Int) -> (Relation -> Int) -> Hashable Relation
forall 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 :: HashSet a -> Set a
toOrderedSet = [a] -> Set a
forall a. Ord a => [a] -> Set a
OS.fromList ([a] -> Set a) -> (HashSet a -> [a]) -> HashSet a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet a -> [a]
forall a. HashSet a -> [a]
S.toList