fix: better pathPieceJoined

src/Utils/PathPiece.hs

@@ -9,6 +9,7 @@ module Utils.PathPiece
   , pathPieceJSON, pathPieceJSONKey
   , pathPieceBinary
   , pathPieceHttpApiData
+  , pathPieceJoined
   ) where
 
 import ClassyPrelude.Yesod
@@ -43,6 +44,9 @@ import Data.Generics.Product.Types
 
 import Web.HttpApiData
 
+import Data.ByteString.Lazy.Base32
+import qualified Data.CaseInsensitive as CI
+
 
 mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp)
 mkFiniteFromPathPiece finiteType = do
@@ -94,6 +98,45 @@ finitePathPiece finiteType verbs = do
         [ clause [] (normalB $ return finExp) [] ]
       ]
 
+pathPieceJoined :: Text -> Prism' Text [Text]
+pathPieceJoined sep = prism' joinPP splitPP
+  where
+    b32Prefix = "b32."
+    
+    textable :: [Text] -> Bool
+    textable ts = maybe False (not . (b32Prefix `Text.isPrefixOf`)) (ts ^? _head)
+               && all (textable' . Text.splitOn sep) ts
+      where textable' ts' = not (all Text.null ts')
+                         && maybe False (not . Text.null) (ts' ^? _last)
+                         && maybe False (not . Text.null) (ts' ^? _head)
+                         && not (consecutiveNulls ts')
+                         && all textable'' ts'
+            textable'' t = none (`Text.isSuffixOf` t) [ Text.dropEnd i sep | i <- [0..(Text.length sep - 1)]]
+                        && none (`Text.isPrefixOf` t) [ Text.drop i sep | i <- [0..(Text.length sep - 1)]]
+            consecutiveNulls (x1:x2:xs) | Text.null x1, Text.null x2 = True
+                                        | otherwise = consecutiveNulls $ x2 : xs
+            consecutiveNulls _ = False
+    
+    joinPP :: [Text] -> Text
+    joinPP ts | textable ts
+              = Text.intercalate sep $ map (Text.replace sep (sep <> sep)) ts
+              | otherwise
+              = b32Prefix <> CI.foldCase (toStrict . encodeBase32Unpadded $ Binary.encode ts)
+    splitPP :: Text -> Maybe [Text]
+    splitPP t | Just b <- Text.stripPrefix b32Prefix t
+              = if | Right bin <- decodeBase32 . fromStrict $ encodeUtf8 b
+                   , Right (onull -> True, _, ts) <- Binary.decodeOrFail bin
+                     -> Just ts
+                   | otherwise
+                     -> Nothing
+              | otherwise = assertM' textable . go [] $ Text.splitOn sep t
+      where go :: [Text] -> [Text] -> [Text]
+            go acc [] = acc
+            go acc (x1:x2:x3:xs) | Text.null x2 = go acc $ (x1 <> sep <> x3) : xs
+            go acc (x:xs) = x : go acc xs
+
+            assertM' p x = x <$ guard (p x)
+
 derivePathPiece :: Name -> (Text -> Text) -> Text -> DecsQ
 derivePathPiece adt mangle joinPP = do
   let mangle' = TH.lift . mangle . pack . nameBase
@@ -102,16 +145,16 @@ derivePathPiece adt mangle joinPP = do
   let
     toClause ConstructorInfo{..} = do
       vars <- mapM (const $ newName "x") constructorFields
-      clause [conP constructorName $ map varP vars] (normalB [e|Text.intercalate joinPP $ $(mangle' constructorName) : $(listE $ map (\v -> [e|toPathPiece $(varE v)|]) vars)|]) []
+      clause [conP constructorName $ map varP vars] (normalB [e|review (pathPieceJoined joinPP) $ $(mangle' constructorName) : $(listE $ map (\v -> [e|toPathPiece $(varE v)|]) vars)|]) []
     fromClause = do
       constrName <- newName "c"
       argsName <- newName "args"
-      clause [viewP [e|Text.splitOn joinPP|] $ infixP (varP constrName) '(:) (varP argsName)]
+      clause [viewP [e|preview (pathPieceJoined joinPP)|] $ conP 'Just [infixP (varP constrName) '(:) (varP argsName)]]
              (normalB [e|HashMap.lookup $(varE constrName) $(varE mapName) >>= ($ $(varE argsName))|])
              []
     finDecs =
       [ pragInlD mapName NoInline FunLike AllPhases
-      , sigD mapName $ forallT [] (cxt iCxt) [t|HashMap Text ([Text] -> Maybe $(typ))|]
+      , sigD mapName $ forallT [] (cxt iCxt) [t|HashMap Text ([Text] -> Maybe $typ)|]
       , funD mapName
         [ clause [] (normalB finClause) [] ]
       ]
@@ -139,7 +182,7 @@ derivePathPiece adt mangle joinPP = do
     tvarName (PlainTV n) = n
     tvarName (KindedTV n _) = n
   sequence . (finDecs ++ ) . pure $
-    instanceD (cxt iCxt) [t|PathPiece $(typ)|]
+    instanceD (cxt iCxt) [t|PathPiece $typ|]
       [ funD 'toPathPiece
           (map toClause datatypeCons)
       , funD 'fromPathPiece
@@ -194,13 +237,13 @@ tuplePathPiece tupleDim = do
 
   t <- newName "t"
 
-  instanceD tCxt [t|PathPiece $(tupleType)|]
+  instanceD tCxt [t|PathPiece $tupleType|]
     [ funD 'toPathPiece
-      [ clause [tupP $ map varP xs] (normalB [e|Text.intercalate tupleSeparator $(listE $ map (appE [e|toPathPiece|] . varE) xs)|]) []
+      [ clause [tupP $ map varP xs] (normalB [e|review (pathPieceJoined tupleSeparator) $(listE $ map (appE [e|toPathPiece|] . varE) xs)|]) []
       ]
     , funD 'fromPathPiece
       [ clause [varP t] (normalB . doE $ concat
-                         [ pure $ bindS (listP $ map varP xs) [e|return $ Text.splitOn tupleSeparator $(varE t)|]
+                         [ pure $ bindS (listP $ map varP xs) [e|preview (pathPieceJoined tupleSeparator) $(varE t)|]
                          , [ bindS (varP x') [e|fromPathPiece $(varE x)|] | (x, x') <- zip xs xs' ]
                          , pure $ noBindS [e|return $(tupE $ map varE xs')|]
                          ]) []

test/Utils/PathPieceSpec.hs

@@ -0,0 +1,18 @@
+module Utils.PathPieceSpec where
+
+import TestImport
+
+import Utils.PathPiece
+
+
+spec :: Spec
+spec = describe "pathPieceJoined" $ do
+  it "is a prism" . property $ \(NonEmpty (pack -> joinPP)) -> isPrism $ pathPieceJoined joinPP
+  it "behaves as expected on some examples" $ do
+    let test xs t = do
+          review (pathPieceJoined "--") xs `shouldBe` t
+          preview (pathPieceJoined "--") t `shouldBe` Just xs
+    test ["foo", "bar"] "foo--bar"
+    test ["foo--bar", "baz"] "foo----bar--baz"
+    test ["baz", "foo--bar"] "baz--foo----bar"
+    test ["baz--quux", "foo--bar"] "baz----quux--foo----bar"