-- | Fundamental facilities for constructing type error messages.
module Language.Futhark.TypeChecker.Error
  ( -- * Breadcrumbs
    BreadCrumbs,
    hasNoBreadCrumbs,
    matchingField,
    matchingConstructor,
    matching,
  )
where

import Futhark.Util.Pretty
import Language.Futhark

-- | A piece of information that describes what process the type
-- checker currently performing.  This is used to give better error
-- messages for unification errors.
data BreadCrumb
  = MatchingFields [Name]
  | MatchingConstructor Name
  | Matching (Doc ())

instance Pretty BreadCrumb where
  pretty :: forall ann. BreadCrumb -> Doc ann
pretty (MatchingFields [Name]
fields) =
    Doc ann
"When matching types of record field"
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
dquotes ([Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"." ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ (Name -> Doc ann) -> [Name] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Name -> Doc ann
pretty [Name]
fields)
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
dot
  pretty (MatchingConstructor Name
c) =
    Doc ann
"When matching types of constructor" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
dquotes (Name -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Name -> Doc ann
pretty Name
c) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
dot
  pretty (Matching Doc ()
s) =
    Doc () -> Doc ann
forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
s

-- | Unification failures can occur deep down inside complicated types
-- (consider nested records). We leave breadcrumbs behind us so we can
-- report the path we took to find the mismatch. When combining
-- breadcrumbs with the 'Semigroup' instance, put the innermost
-- breadcrumbs to the left.
newtype BreadCrumbs = BreadCrumbs [BreadCrumb]

instance Semigroup BreadCrumbs where
  BreadCrumbs (MatchingFields [Name]
xs : [BreadCrumb]
bcs1) <> :: BreadCrumbs -> BreadCrumbs -> BreadCrumbs
<> BreadCrumbs (MatchingFields [Name]
ys : [BreadCrumb]
bcs2) =
    [BreadCrumb] -> BreadCrumbs
BreadCrumbs ([BreadCrumb] -> BreadCrumbs) -> [BreadCrumb] -> BreadCrumbs
forall a b. (a -> b) -> a -> b
$ [Name] -> BreadCrumb
MatchingFields ([Name]
ys [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> [Name]
xs) BreadCrumb -> [BreadCrumb] -> [BreadCrumb]
forall a. a -> [a] -> [a]
: [BreadCrumb]
bcs1 [BreadCrumb] -> [BreadCrumb] -> [BreadCrumb]
forall a. Semigroup a => a -> a -> a
<> [BreadCrumb]
bcs2
  BreadCrumbs [BreadCrumb]
bcs1 <> BreadCrumbs [BreadCrumb]
bcs2 =
    [BreadCrumb] -> BreadCrumbs
BreadCrumbs ([BreadCrumb] -> BreadCrumbs) -> [BreadCrumb] -> BreadCrumbs
forall a b. (a -> b) -> a -> b
$ [BreadCrumb]
bcs1 [BreadCrumb] -> [BreadCrumb] -> [BreadCrumb]
forall a. Semigroup a => a -> a -> a
<> [BreadCrumb]
bcs2

instance Monoid BreadCrumbs where
  mempty :: BreadCrumbs
mempty = [BreadCrumb] -> BreadCrumbs
BreadCrumbs []

-- | Is the path empty?
hasNoBreadCrumbs :: BreadCrumbs -> Bool
hasNoBreadCrumbs :: BreadCrumbs -> Bool
hasNoBreadCrumbs (BreadCrumbs []) = Bool
True
hasNoBreadCrumbs BreadCrumbs
_ = Bool
False

-- | Matching a record field.
matchingField :: Name -> BreadCrumbs
matchingField :: Name -> BreadCrumbs
matchingField Name
f = [BreadCrumb] -> BreadCrumbs
BreadCrumbs [[Name] -> BreadCrumb
MatchingFields [Name
f]]

-- | Matching a constructor.
matchingConstructor :: Name -> BreadCrumbs
matchingConstructor :: Name -> BreadCrumbs
matchingConstructor Name
c = [BreadCrumb] -> BreadCrumbs
BreadCrumbs [Name -> BreadCrumb
MatchingConstructor Name
c]

-- | Matching anything.
matching :: Doc () -> BreadCrumbs
matching :: Doc () -> BreadCrumbs
matching Doc ()
d = [BreadCrumb] -> BreadCrumbs
BreadCrumbs [Doc () -> BreadCrumb
Matching Doc ()
d]

instance Pretty BreadCrumbs where
  pretty :: forall ann. BreadCrumbs -> Doc ann
pretty (BreadCrumbs []) = Doc ann
forall a. Monoid a => a
mempty
  pretty (BreadCrumbs [BreadCrumb]
bcs) = Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall a. [Doc a] -> Doc a
stack ((BreadCrumb -> Doc ann) -> [BreadCrumb] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map BreadCrumb -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. BreadCrumb -> Doc ann
pretty [BreadCrumb]
bcs)