{-# 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
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 :: 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 (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 = 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 = MetaTerm -> Text
go MetaTerm
mt
needsParens :: MetaTerm -> Bool
needsParens (MT.RWApp (Op Text
op) [MetaTerm]
_) = Text
op Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> 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
$c== :: Relation -> Relation -> Bool
== :: Relation -> Relation -> Bool
$c/= :: Relation -> Relation -> Bool
/= :: 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
$cfrom :: forall x. Relation -> Rep Relation x
from :: forall x. Relation -> Rep Relation x
$cto :: forall x. Rep Relation x -> Relation
to :: forall x. Rep Relation x -> Relation
Generic, Eq Relation
Eq Relation =>
(Int -> Relation -> Int) -> (Relation -> Int) -> Hashable Relation
Int -> Relation -> Int
Relation -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Relation -> Int
hashWithSalt :: Int -> Relation -> Int
$chash :: Relation -> Int
hash :: 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 = [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