Merge remote-tracking branch 'origin/master' into machines-to-streaming

Author: Patrick Thomson

semantic.cabal

@@ -272,6 +272,7 @@ library
                      -- Serialization
                      , Serializing.Format
                      , Serializing.SExpression
+                     , Serializing.SExpression.Precise
                      , Tags.Taggable
                      , Tags.Tagging
                      -- Custom Prelude

src/Serializing/SExpression/Precise.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
+module Serializing.SExpression.Precise
+( serializeSExpression
+) where
+
+import Data.ByteString.Builder
+import Data.Foldable (fold)
+import Data.List (intersperse)
+import Data.Text (Text)
+import GHC.Generics
+
+serializeSExpression :: ToSExpression t => t -> Builder
+serializeSExpression t = toSExpression t 0 <> "\n"
+
+
+nl :: Int -> Builder
+nl n | n <= 0    = ""
+     | otherwise = "\n"
+
+pad :: Int -> Builder
+pad n = stringUtf8 (replicate (2 * n) ' ')
+
+
+class ToSExpression t where
+  toSExpression :: t -> Int -> Builder
+
+instance (ToSExpressionWithStrategy strategy t, strategy ~ ToSExpressionStrategy t) => ToSExpression t where
+  toSExpression = toSExpressionWithStrategy @strategy undefined
+
+
+data Strategy = Generic | Show
+
+type family ToSExpressionStrategy t :: Strategy where
+  ToSExpressionStrategy Text = 'Show
+  ToSExpressionStrategy _    = 'Generic
+
+class ToSExpressionWithStrategy (strategy :: Strategy) t where
+  toSExpressionWithStrategy :: proxy strategy -> t -> Int -> Builder
+
+instance Show t => ToSExpressionWithStrategy 'Show t where
+  toSExpressionWithStrategy _ t _ = stringUtf8 (show t)
+
+instance (Generic t, GToSExpression (Rep t)) => ToSExpressionWithStrategy 'Generic t where
+  toSExpressionWithStrategy _ t n = nl n <> pad n <> "(" <> fold (intersperse " " (gtoSExpression (from t) n)) <> ")"
+
+
+class GToSExpression f where
+  gtoSExpression :: f (Int -> Builder) -> (Int -> [Builder])
+
+instance GToSExpression f => GToSExpression (M1 D d f) where
+  gtoSExpression = gtoSExpression . unM1
+
+instance (GToSExpression f, GToSExpression g) => GToSExpression (f :+: g) where
+  gtoSExpression (L1 l) = gtoSExpression l
+  gtoSExpression (R1 r) = gtoSExpression r
+
+instance (Constructor c, GToSExpression f) => GToSExpression (M1 C c f) where
+  gtoSExpression m n = stringUtf8 (conName m) : gtoSExpression (unM1 m) (n + 1)
+
+instance (GToSExpression f, GToSExpression g) => GToSExpression (f :*: g) where
+  gtoSExpression (l :*: r) = gtoSExpression l <> gtoSExpression r
+
+instance GToSExpression U1 where
+  gtoSExpression _ _ = []
+
+instance GToSExpression f => GToSExpression (M1 S s f) where
+  gtoSExpression = gtoSExpression . unM1 -- FIXME: show the selector name, if any
+
+instance ToSExpression k => GToSExpression (K1 R k) where
+  gtoSExpression k = pure . toSExpression (unK1 k)

test/Data/Functor/Listable.hs

@@ -104,13 +104,6 @@ liftCons4 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier d] -> (a -> b -> c -> d -
 liftCons4 tiers1 tiers2 tiers3 tiers4 f = mapT (uncurry4 f) (tiers1 >< tiers2 >< tiers3 >< tiers4) `addWeight` 1
   where uncurry4 f (a, (b, (c, d))) = f a b c d
 
--- | Lifts a quinary constructor to a list of tiers, given lists of tiers for its arguments.
---
---   Commonly used in the definition of 'Listable1' and 'Listable2' instances.
-_liftCons5 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier d] -> [Tier e] -> (a -> b -> c -> d -> e -> f) -> [Tier f]
-_liftCons5 tiers1 tiers2 tiers3 tiers4 tiers5 f = mapT (uncurry5 f) (tiers1 >< tiers2 >< tiers3 >< tiers4 >< tiers5) `addWeight` 1
-  where uncurry5 f (a, (b, (c, (d, e)))) = f a b c d e
-
 -- | Lifts a senary constructor to a list of tiers, given lists of tiers for its arguments.
 --
 --   Commonly used in the definition of 'Listable1' and 'Listable2' instances.