{-# LANGUAGE OverloadedStrings #-}

module Unison.PatternMatchCoverage.GrdTree
  ( GrdTree,
    GrdTreeF (..),
    pattern Leaf,
    pattern Grd,
    pattern Fork,
    prettyGrdTree,
  )
where

import Data.ListLike (ListLike)
import Unison.Prelude
import Unison.Util.Pretty
import Unison.Util.Recursion

-- | A @GrdTree@ is the simple language to desugar matches into. All
-- pattern matching constructs (/e.g./ structural pattern matching,
-- boolean guards, pattern guards, view patterns, etc) are desugared
-- into this simpler structure.
--
-- It is parameterized by the values at guard nodes, @n@, and the
-- values at the leaves, @l@. When desugaring, @n@ is
-- 'Unison.PatternMatchCoverage.PmGrd.PmGrd' and @l@ is the source
-- location. After annotating the @GrdTree@, @n@ is a refinement type
-- representing matching values and the @l@ is pairs of the
-- aforementioned refinement type and source location.
--
-- For example:
--
-- @
-- example : Optional Nat -> Nat
-- example = cases
--   None -> 0
--   Some x
--     | isEven x -> 0
--     | otherwise -> 1
-- @
--
-- is desugared into
--
-- @
--  ──┬─ None <- v0 ── srcloc
--    ├─ Some ( v1 :: ##Nat ) <- v0 ── let v2 = isEven v1 ── True <- v2 ── srcloc
--    └─ Some ( v3 :: ##Nat ) <- v0 ── srcloc
-- @
type GrdTree n l = Fix (GrdTreeF n l)

data GrdTreeF n l a
  = -- | A successful match
    LeafF l
  | -- | A constraint of some kind (structural pattern match, boolan guard, etc)
    GrdF n a
  | -- | A list of alternative matches, tried in order
    ForkF [a]
  deriving stock ((forall a b. (a -> b) -> GrdTreeF n l a -> GrdTreeF n l b)
-> (forall a b. a -> GrdTreeF n l b -> GrdTreeF n l a)
-> Functor (GrdTreeF n l)
forall a b. a -> GrdTreeF n l b -> GrdTreeF n l a
forall a b. (a -> b) -> GrdTreeF n l a -> GrdTreeF n l b
forall n l a b. a -> GrdTreeF n l b -> GrdTreeF n l a
forall n l a b. (a -> b) -> GrdTreeF n l a -> GrdTreeF n l b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall n l a b. (a -> b) -> GrdTreeF n l a -> GrdTreeF n l b
fmap :: forall a b. (a -> b) -> GrdTreeF n l a -> GrdTreeF n l b
$c<$ :: forall n l a b. a -> GrdTreeF n l b -> GrdTreeF n l a
<$ :: forall a b. a -> GrdTreeF n l b -> GrdTreeF n l a
Functor, Int -> GrdTreeF n l a -> ShowS
[GrdTreeF n l a] -> ShowS
GrdTreeF n l a -> String
(Int -> GrdTreeF n l a -> ShowS)
-> (GrdTreeF n l a -> String)
-> ([GrdTreeF n l a] -> ShowS)
-> Show (GrdTreeF n l a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall n l a.
(Show l, Show n, Show a) =>
Int -> GrdTreeF n l a -> ShowS
forall n l a. (Show l, Show n, Show a) => [GrdTreeF n l a] -> ShowS
forall n l a. (Show l, Show n, Show a) => GrdTreeF n l a -> String
$cshowsPrec :: forall n l a.
(Show l, Show n, Show a) =>
Int -> GrdTreeF n l a -> ShowS
showsPrec :: Int -> GrdTreeF n l a -> ShowS
$cshow :: forall n l a. (Show l, Show n, Show a) => GrdTreeF n l a -> String
show :: GrdTreeF n l a -> String
$cshowList :: forall n l a. (Show l, Show n, Show a) => [GrdTreeF n l a] -> ShowS
showList :: [GrdTreeF n l a] -> ShowS
Show)

prettyGrdTree :: forall n l s. (ListLike s Char, IsString s) => (n -> Pretty s) -> (l -> Pretty s) -> GrdTree n l -> Pretty s
prettyGrdTree :: forall n l s.
(ListLike s Char, IsString s) =>
(n -> Pretty s) -> (l -> Pretty s) -> GrdTree n l -> Pretty s
prettyGrdTree n -> Pretty s
prettyNode l -> Pretty s
prettyLeaf = Algebra (GrdTreeF n l) (Pretty s) -> GrdTree n l -> Pretty s
forall a. Algebra (GrdTreeF n l) a -> GrdTree n l -> a
forall t (f :: * -> *) a. Recursive t f => Algebra f a -> t -> a
cata Algebra (GrdTreeF n l) (Pretty s)
phi
  where
    phi :: Algebra (GrdTreeF n l) (Pretty s)
phi = \case
      LeafF l
l -> l -> Pretty s
prettyLeaf l
l
      GrdF n
n Pretty s
rest -> Pretty s -> [Pretty s] -> Pretty s
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
sep Pretty s
" " [n -> Pretty s
prettyNode n
n, Pretty s
"──", Pretty s
rest]
      ForkF [Pretty s]
xs -> Pretty s
"──" Pretty s -> Pretty s -> Pretty s
forall a. Semigroup a => a -> a -> a
<> Pretty s -> Pretty s
forall s. Pretty s -> Pretty s
group (Pretty s -> [Pretty s] -> Pretty s
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
sep Pretty s
"\n" ([Pretty s] -> Pretty s) -> [Pretty s] -> Pretty s
forall a b. (a -> b) -> a -> b
$ [Pretty s] -> [Pretty s]
makeTree [Pretty s]
xs)
    makeTree :: [Pretty s] -> [Pretty s]
    makeTree :: [Pretty s] -> [Pretty s]
makeTree = \case
      [] -> []
      Pretty s
x : [] -> [Pretty s -> [Pretty s] -> Pretty s
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
sep Pretty s
" " [Pretty s
"──", Pretty s
x]]
      Pretty s
x0 : Pretty s
x1 : [Pretty s]
xs ->
        Pretty s -> [Pretty s] -> Pretty s
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
sep Pretty s
" " [Pretty s
"┬─", Pretty s
x0]
          Pretty s -> [Pretty s] -> [Pretty s]
forall a. a -> [a] -> [a]
: let go :: Pretty s -> [Pretty s] -> [Pretty s]
go Pretty s
y0 = \case
                  [] -> [Pretty s -> [Pretty s] -> Pretty s
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
sep Pretty s
" " [Pretty s
"└─", Pretty s
y0]]
                  Pretty s
y1 : [Pretty s]
ys -> Pretty s
"├─ " Pretty s -> Pretty s -> Pretty s
forall a. Semigroup a => a -> a -> a
<> Pretty s
y0 Pretty s -> [Pretty s] -> [Pretty s]
forall a. a -> [a] -> [a]
: Pretty s -> [Pretty s] -> [Pretty s]
go Pretty s
y1 [Pretty s]
ys
             in [Pretty s -> Pretty s -> Pretty s
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
indent Pretty s
"  " (Pretty s -> [Pretty s] -> Pretty s
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
sep Pretty s
"\n" (Pretty s -> [Pretty s] -> [Pretty s]
forall {s}. IsString s => Pretty s -> [Pretty s] -> [Pretty s]
go Pretty s
x1 [Pretty s]
xs))]

pattern Leaf :: l -> GrdTree n l
pattern $mLeaf :: forall {r} {l} {n}. GrdTree n l -> (l -> r) -> ((# #) -> r) -> r
$bLeaf :: forall l n. l -> GrdTree n l
Leaf x = Fix (LeafF x)

pattern Grd :: n -> GrdTree n l -> GrdTree n l
pattern $mGrd :: forall {r} {n} {l}.
GrdTree n l -> (n -> GrdTree n l -> r) -> ((# #) -> r) -> r
$bGrd :: forall n l. n -> GrdTree n l -> GrdTree n l
Grd x rest = Fix (GrdF x rest)

pattern Fork :: [GrdTree n l] -> GrdTree n l
pattern $mFork :: forall {r} {n} {l}.
GrdTree n l -> ([GrdTree n l] -> r) -> ((# #) -> r) -> r
$bFork :: forall n l. [GrdTree n l] -> GrdTree n l
Fork alts = Fix (ForkF alts)

{-# COMPLETE Leaf, Grd, Fork #-}