{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Functor.Base.EDN
( ValueF(..)
) where
import Data.Functor.Foldable
( Base
, Recursive(..)
, Corecursive(..)
)
import Data.Text (Text)
import GHC.Generics (Generic)
import qualified Data.Vector as V
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.EDN.AST.Types (Tagged(..), Value(..))
type TextTag = Maybe (Text, Text)
data ValueF f
= NilF TextTag
| BooleanF TextTag Bool
| StringF TextTag Text
| CharacterF TextTag Char
| SymbolF TextTag Text Text
| KeywordF TextTag Text
| IntegerF TextTag Int
| FloatingF TextTag Double
| ListF TextTag [f]
| VecF TextTag (V.Vector f)
| MapF TextTag [(f, f)]
| SetF TextTag [f]
deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
type instance Base (Tagged Text Value) = ValueF
instance Recursive (Tagged Text Value) where
project = \case
NoTag v -> projectV Nothing v
Tagged ns n v -> projectV (Just (ns, n)) v
where
projectV t = \case
Nil -> NilF t
Boolean b -> BooleanF t b
String s -> StringF t s
Character c -> CharacterF t c
Symbol ns n -> SymbolF t ns n
Keyword n -> KeywordF t n
Integer i -> IntegerF t i
Floating f -> FloatingF t f
List xs -> ListF t xs
Vec v -> VecF t v
Map m -> MapF t (M.toList m)
Set s -> SetF t (S.toList s)
instance Corecursive (Tagged Text Value) where
embed = \case
NilF t -> embedT t Nil
BooleanF t b -> embedT t $ Boolean b
StringF t s -> embedT t $ String s
CharacterF t c -> embedT t $ Character c
SymbolF t ns n -> embedT t $ Symbol ns n
KeywordF t k -> embedT t $ Keyword k
IntegerF t i -> embedT t $ Integer i
FloatingF t f -> embedT t $ Floating f
ListF t xs -> embedT t $ List xs
VecF t v -> embedT t $ Vec v
MapF t ps -> embedT t $ Map (M.fromList ps)
SetF t xs -> embedT t $ Set (S.fromList xs)
where
embedT t v = case t of
Nothing -> NoTag v
Just (ns, n) -> Tagged ns n v