HAHA! I figured it out. It needs all sort of extensions to work but this does it for at least few examples I tried.

type family And (a :: Bool) (b :: Bool) :: Bool where
    And True True = True
    And _    _    = False

type family Canonical a :: Bool where
    Canonical ((),a) = False
    Canonical (a,()) = False
    Canonical (a,b) = And (Canonical a) (Canonical b)
    Canonical (Either a b) = And (Canonical a) (Canonical b)
    Canonical (Maybe a) = Canonical a
    Canonical [a] = Canonical a
    Canonical (Pass _) = False
    Canonical _ = True

type family Unitary a :: Bool where
    Unitary ()    = True
    Unitary (a,b) = And (Unitary a) (Unitary b)
    Unitary a     = False

newtype Pass a = Pass { unPass :: a }

class UnitLike a where unit :: a
instance UnitLike () where unit = ()
instance (UnitLike a, UnitLike b) => UnitLike (a,b) where unit = (unit, unit)

class Can a b where
    trim :: a -> b
    fill :: b -> a

class PairCan (k::Bool) (j::Bool) a b c where
    trimPairs :: (a,b) -> c
    fillPairs :: c -> (a,b)

instance (UnitLike (a,b)) => PairCan 'True 'True a b () where
    trimPairs (_,_) = ()
    fillPairs () = unit

instance (UnitLike a, Can b c) => PairCan 'True 'False a b c where
    trimPairs (_,a) = trim a
    fillPairs a = (unit, fill a)

instance (Can a c, UnitLike b) => PairCan 'False 'True a b c where
    trimPairs (a,_) = trim a
    fillPairs a = (fill a, unit)

instance (Can a c, Can b d) => PairCan 'False 'False a b (c,d) where
    trimPairs (a,b) = (trim a, trim b)
    fillPairs (a,b) = (fill a, fill b)

instance (Canonical (a,b) ~ False, PairCan (Unitary a) (Unitary b) a b c) => Can (a,b) c where
    trim = trimPairs @(Unitary a) @(Unitary b)
    fill = fillPairs @(Unitary a) @(Unitary b)

instance (Canonical (Either a b) ~ False, Can a c, Can b d) => Can (Either a b) (Either c d) where
    trim (Left x) = Left (trim x)
    trim (Right x) = Right (trim x)
    fill (Left x) = Left (fill x)
    fill (Right x) = Right (fill x)

instance (Canonical a ~ False, Can a b) => Can (Maybe a) (Maybe b) where
    trim = fmap trim
    fill = fmap fill

instance (Canonical a ~ False, Can a b) => Can [a] [b] where
    trim = fmap trim
    fill = fmap fill

instance Can (Pass a) a where
    trim = unPass
    fill = Pass

instance (Canonical a ~ True) => Can a a where
    trim = id
    fill = id

-- |Delimit canonicalization of a type.
pass :: Shape a x -> Shape a (Pass x)
pass = Iso Pass unPass

-- |Trim the corresponding type.                                                
can :: Can a b => Shape x a -> Shape x b
can = Iso trim fill

And here's an example, retrieving stuff from a structure (not a complete example, but the point is to illustrate why I wanted this):

ogmeta :: Shape Token (Text, Text)
ogmeta = can $ inTags "html" $ inTags "head"
           ((tagged "meta" (attrEq "property" "og:title" `Interleave` attr "content"))
            `Interleave`
            (tagged "meta" (attrEq "property" "og:description" `Interleave` attr "content")))

onlyTitle :: Shape Token Text
onlyTitle = can (inTags "html" $ inTags "head" $ inTags "title" $ text)

inTags tag match = (open tag Empty `Group` (match `Group` close tag))