content: {-# LANGUAGE OverloadedStrings #-}
  {-# OPTIONS_GHC -Wno-x-partial #-}
  
  module Type.Error
    ( Type (..),
      Super (..),
      Extension (..),
      iteratedDealias,
      toDoc,
      Problem (..),
      Direction (..),
      toComparison,
      isInt,
      isFloat,
      isString,
      isChar,
      isArray,
    )
  where
  
  import Data.Bag qualified as Bag
  import Data.Map qualified as Map
  import Data.Name qualified as Name
  import Gren.ModuleName qualified as ModuleName
  import Reporting.Doc qualified as D
  import Reporting.Render.Type qualified as RT
  import Reporting.Render.Type.Localizer qualified as L
  
  -- ERROR TYPES
  
  data Type
    = Lambda Type Type [Type]
    | Infinite
    | Error
    | FlexVar Name.Name
    | FlexSuper Super Name.Name
    | RigidVar Name.Name
    | RigidSuper Super Name.Name
    | Type ModuleName.Canonical Name.Name [Type]
    | Record (Map.Map Name.Name Type) Extension
    | Alias ModuleName.Canonical Name.Name [(Name.Name, Type)] Type
  
  data Super
    = Number
    | Comparable
    | Appendable
    | CompAppend
    deriving (Eq)
  
  data Extension
    = Closed
    | FlexOpen Name.Name
    | RigidOpen Name.Name
  
  iteratedDealias :: Type -> Type
  iteratedDealias tipe =
    case tipe of
      Alias _ _ _ real ->
        iteratedDealias real
      _ ->
        tipe
  
  -- TO DOC
  
  toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc
  toDoc localizer ctx tipe =
    case tipe of
      Lambda a b cs ->
        RT.lambda
          ctx
          (toDoc localizer RT.Func a)
          (toDoc localizer RT.Func b)
          (map (toDoc localizer RT.Func) cs)
      Infinite ->
        "∞"
      Error ->
        "?"
      FlexVar name ->
        D.fromName name
      FlexSuper _ name ->
        D.fromName name
      RigidVar name ->
        D.fromName name
      RigidSuper _ name ->
        D.fromName name
      Type home name args ->
        RT.apply
          ctx
          (L.toDoc localizer home name)
          (map (toDoc localizer RT.App) args)
      Record fields ext ->
        RT.record (fieldsToDocs localizer fields) (extToDoc ext)
      Alias home name args _ ->
        aliasToDoc localizer ctx home name args
  
  aliasToDoc :: L.Localizer -> RT.Context -> ModuleName.Canonical -> Name.Name -> [(Name.Name, Type)] -> D.Doc
  aliasToDoc localizer ctx home name args =
    RT.apply
      ctx
      (L.toDoc localizer home name)
      (map (toDoc localizer RT.App . snd) args)
  
  fieldsToDocs :: L.Localizer -> Map.Map Name.Name Type -> [(D.Doc, D.Doc)]
  fieldsToDocs localizer fields =
    Map.foldrWithKey (addField localizer) [] fields
  
  addField :: L.Localizer -> Name.Name -> Type -> [(D.Doc, D.Doc)] -> [(D.Doc, D.Doc)]
  addField localizer fieldName fieldType docs =
    let f = D.fromName fieldName
        t = toDoc localizer RT.None fieldType
     in (f, t) : docs
  
  extToDoc :: Extension -> Maybe D.Doc
  extToDoc ext =
    case ext of
      Closed -> Nothing
      FlexOpen x -> Just (D.fromName x)
      RigidOpen x -> Just (D.fromName x)
  
  -- DIFF
  
  data Diff a
    = Diff a a Status
  
  data Status
    = Similar
    | Different (Bag.Bag Problem)
  
  data Problem
    = IntFloat
    | StringFromInt
    | StringFromFloat
    | StringToInt
    | StringToFloat
    | AnythingToBool
    | AnythingFromMaybe
    | ArityMismatch Int Int
    | BadFlexSuper Direction Super Name.Name Type
    | BadRigidVar Name.Name Type
    | BadRigidSuper Super Name.Name Type
    | FieldTypo Name.Name [Name.Name]
    | FieldsMissing [Name.Name]
  
  data Direction = Have | Need
  
  instance Functor Diff where
    fmap func (Diff a b status) =
      Diff (func a) (func b) status
  
  instance Applicative Diff where
    pure a =
      Diff a a Similar
  
    (<*>) (Diff aFunc bFunc status1) (Diff aArg bArg status2) =
      Diff (aFunc aArg) (bFunc bArg) (merge status1 status2)
  
  merge :: Status -> Status -> Status
  merge status1 status2 =
    case status1 of
      Similar ->
        status2
      Different problems1 ->
        case status2 of
          Similar ->
            status1
          Different problems2 ->
            Different (Bag.append problems1 problems2)
  
  -- COMPARISON
  
  toComparison :: L.Localizer -> Type -> Type -> (D.Doc, D.Doc, [Problem])
  toComparison localizer tipe1 tipe2 =
    case toDiff localizer RT.None tipe1 tipe2 of
      Diff doc1 doc2 Similar ->
        (doc1, doc2, [])
      Diff doc1 doc2 (Different problems) ->
        (doc1, doc2, Bag.toList problems)
  
  toDiff :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
  toDiff localizer ctx tipe1 tipe2 =
    case (tipe1, tipe2) of
      (Error, Error) -> same localizer ctx tipe1
      (Infinite, Infinite) -> same localizer ctx tipe1
      (FlexVar x, FlexVar y) | x == y -> same localizer ctx tipe1
      (FlexSuper _ x, FlexSuper _ y) | x == y -> same localizer ctx tipe1
      (RigidVar x, RigidVar y) | x == y -> same localizer ctx tipe1
      (RigidSuper _ x, RigidSuper _ y) | x == y -> same localizer ctx tipe1
      (FlexVar _, _) -> similar localizer ctx tipe1 tipe2
      (_, FlexVar _) -> similar localizer ctx tipe1 tipe2
      (FlexSuper s _, t) | isSuper s t -> similar localizer ctx tipe1 tipe2
      (t, FlexSuper s _) | isSuper s t -> similar localizer ctx tipe1 tipe2
      (Lambda a b cs, Lambda x y zs) ->
        if length cs == length zs
          then
            RT.lambda ctx
              <$> toDiff localizer RT.Func a x
              <*> toDiff localizer RT.Func b y
              <*> sequenceA (zipWith (toDiff localizer RT.Func) cs zs)
          else
            let f = toDoc localizer RT.Func
             in different
                  (D.dullyellow (RT.lambda ctx (f a) (f b) (map f cs)))
                  (D.dullyellow (RT.lambda ctx (f x) (f y) (map f zs)))
                  (Bag.one (ArityMismatch (2 + length cs) (2 + length zs)))
      (Record fields1 ext1, Record fields2 ext2) ->
        diffRecord localizer fields1 ext1 fields2 ext2
      (Type home1 name1 args1, Type home2 name2 args2)
        | home1 == home2 && name1 == name2 ->
            RT.apply ctx (L.toDoc localizer home1 name1)
              <$> sequenceA (zipWith (toDiff localizer RT.App) args1 args2)
      (Alias home1 name1 args1 _, Alias home2 name2 args2 _)
        | home1 == home2 && name1 == name2 ->
            RT.apply ctx (L.toDoc localizer home1 name1)
              <$> sequenceA (zipWith (toDiff localizer RT.App) (map snd args1) (map snd args2))
      -- start trying to find specific problems
  
      (Type home1 name1 args1, Type home2 name2 args2)
        | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
            different
              (nameClashToDoc ctx localizer home1 name1 args1)
              (nameClashToDoc ctx localizer home2 name2 args2)
              Bag.empty
      (Type home name [t1], t2)
        | isMaybe home name && isSimilar (toDiff localizer ctx t1 t2) ->
            different
              (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t1])
              (toDoc localizer ctx t2)
              (Bag.one AnythingFromMaybe)
      (t1, Type home name [t2])
        | isArray home name && isSimilar (toDiff localizer ctx t1 t2) ->
            different
              (toDoc localizer ctx t1)
              (RT.apply ctx (D.dullyellow (L.toDoc localizer home name)) [toDoc localizer RT.App t2])
              Bag.empty
      (Alias home1 name1 args1 t1, t2) ->
        case diffAliasedRecord localizer t1 t2 of
          Just (Diff _ doc2 status) ->
            Diff (D.dullyellow (aliasToDoc localizer ctx home1 name1 args1)) doc2 status
          Nothing ->
            case t2 of
              Type home2 name2 args2
                | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
                    different
                      (nameClashToDoc ctx localizer home1 name1 (map snd args1))
                      (nameClashToDoc ctx localizer home2 name2 args2)
                      Bag.empty
              _ ->
                different
                  (D.dullyellow (toDoc localizer ctx tipe1))
                  (D.dullyellow (toDoc localizer ctx tipe2))
                  Bag.empty
      (t1, Alias home2 name2 args2 t2) ->
        case diffAliasedRecord localizer t1 t2 of
          Just (Diff doc1 _ status) ->
            Diff doc1 (D.dullyellow (aliasToDoc localizer ctx home2 name2 args2)) status
          Nothing ->
            case t1 of
              Type home1 name1 args1
                | L.toChars localizer home1 name1 == L.toChars localizer home2 name2 ->
                    different
                      (nameClashToDoc ctx localizer home1 name1 args1)
                      (nameClashToDoc ctx localizer home2 name2 (map snd args2))
                      Bag.empty
              _ ->
                different
                  (D.dullyellow (toDoc localizer ctx tipe1))
                  (D.dullyellow (toDoc localizer ctx tipe2))
                  Bag.empty
      pair ->
        let doc1 = D.dullyellow (toDoc localizer ctx tipe1)
            doc2 = D.dullyellow (toDoc localizer ctx tipe2)
         in different doc1 doc2 $
              case pair of
                (RigidVar x, other) -> Bag.one $ BadRigidVar x other
                (FlexSuper s x, other) -> Bag.one $ BadFlexSuper Have s x other
                (RigidSuper s x, other) -> Bag.one $ BadRigidSuper s x other
                (other, RigidVar x) -> Bag.one $ BadRigidVar x other
                (other, FlexSuper s x) -> Bag.one $ BadFlexSuper Need s x other
                (other, RigidSuper s x) -> Bag.one $ BadRigidSuper s x other
                (Type home1 name1 [], Type home2 name2 [])
                  | isInt home1 name1 && isFloat home2 name2 -> Bag.one IntFloat
                  | isFloat home1 name1 && isInt home2 name2 -> Bag.one IntFloat
                  | isInt home1 name1 && isString home2 name2 -> Bag.one StringFromInt
                  | isFloat home1 name1 && isString home2 name2 -> Bag.one StringFromFloat
                  | isString home1 name1 && isInt home2 name2 -> Bag.one StringToInt
                  | isString home1 name1 && isFloat home2 name2 -> Bag.one StringToFloat
                  | isBool home2 name2 -> Bag.one AnythingToBool
                (_, _) ->
                  Bag.empty
  
  -- DIFF HELPERS
  
  same :: L.Localizer -> RT.Context -> Type -> Diff D.Doc
  same localizer ctx tipe =
    let doc = toDoc localizer ctx tipe
     in Diff doc doc Similar
  
  similar :: L.Localizer -> RT.Context -> Type -> Type -> Diff D.Doc
  similar localizer ctx t1 t2 =
    Diff (toDoc localizer ctx t1) (toDoc localizer ctx t2) Similar
  
  different :: a -> a -> Bag.Bag Problem -> Diff a
  different a b problems =
    Diff a b (Different problems)
  
  isSimilar :: Diff a -> Bool
  isSimilar (Diff _ _ status) =
    case status of
      Similar -> True
      Different _ -> False
  
  -- IS TYPE?
  
  isBool :: ModuleName.Canonical -> Name.Name -> Bool
  isBool home name =
    home == ModuleName.basics && name == Name.bool
  
  isInt :: ModuleName.Canonical -> Name.Name -> Bool
  isInt home name =
    home == ModuleName.basics && name == Name.int
  
  isFloat :: ModuleName.Canonical -> Name.Name -> Bool
  isFloat home name =
    home == ModuleName.basics && name == Name.float
  
  isString :: ModuleName.Canonical -> Name.Name -> Bool
  isString home name =
    home == ModuleName.string && name == Name.string
  
  isChar :: ModuleName.Canonical -> Name.Name -> Bool
  isChar home name =
    home == ModuleName.char && name == Name.char
  
  isMaybe :: ModuleName.Canonical -> Name.Name -> Bool
  isMaybe home name =
    home == ModuleName.maybe && name == Name.maybe
  
  isArray :: ModuleName.Canonical -> Name.Name -> Bool
  isArray home name =
    home == ModuleName.array && name == Name.array
  
  -- IS SUPER?
  
  isSuper :: Super -> Type -> Bool
  isSuper super tipe =
    case iteratedDealias tipe of
      Type h n args ->
        case super of
          Number -> isInt h n || isFloat h n
          Comparable -> isInt h n || isFloat h n || isString h n || isChar h n || isArray h n && isSuper super (head args)
          Appendable -> isString h n || isArray h n
          CompAppend -> isString h n || isArray h n && isSuper Comparable (head args)
      _ ->
        False
  
  -- NAME CLASH
  
  nameClashToDoc :: RT.Context -> L.Localizer -> ModuleName.Canonical -> Name.Name -> [Type] -> D.Doc
  nameClashToDoc ctx localizer (ModuleName.Canonical _ home) name args =
    RT.apply
      ctx
      (D.yellow (D.fromName home) <> D.dullyellow ("." <> D.fromName name))
      (map (toDoc localizer RT.App) args)
  
  -- DIFF ALIASED RECORD
  
  diffAliasedRecord :: L.Localizer -> Type -> Type -> Maybe (Diff D.Doc)
  diffAliasedRecord localizer t1 t2 =
    case (iteratedDealias t1, iteratedDealias t2) of
      (Record fields1 ext1, Record fields2 ext2) ->
        Just (diffRecord localizer fields1 ext1 fields2 ext2)
      _ ->
        Nothing
  
  -- RECORD DIFFS
  
  diffRecord :: L.Localizer -> Map.Map Name.Name Type -> Extension -> Map.Map Name.Name Type -> Extension -> Diff D.Doc
  diffRecord localizer fields1 ext1 fields2 ext2 =
    let toUnknownDocs field tipe =
          (D.dullyellow (D.fromName field), toDoc localizer RT.None tipe)
  
        toOverlapDocs field t1 t2 =
          (,) (D.fromName field) <$> toDiff localizer RT.None t1 t2
  
        left = Map.mapWithKey toUnknownDocs (Map.difference fields1 fields2)
        both = Map.intersectionWithKey toOverlapDocs fields1 fields2
        right = Map.mapWithKey toUnknownDocs (Map.difference fields2 fields1)
  
        fieldsDiff =
          Map.elems
            <$> if Map.null left && Map.null right
              then sequenceA both
              else
                Map.union
                  <$> sequenceA both
                  <*> Diff left right (Different Bag.empty)
  
        (Diff doc1 doc2 status) =
          RT.record
            <$> fieldsDiff
            <*> extToDiff ext1 ext2
     in Diff doc1 doc2 $
          merge status $
            case (hasFixedFields ext1, hasFixedFields ext2) of
              (True, True) ->
                case Map.lookupMin left of
                  Just (f, _) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
                  Nothing ->
                    if Map.null right
                      then Similar
                      else Different $ Bag.one $ FieldsMissing (Map.keys right)
              (False, True) ->
                case Map.lookupMin left of
                  Just (f, _) -> Different $ Bag.one $ FieldTypo f (Map.keys fields2)
                  Nothing -> Similar
              (True, False) ->
                case Map.lookupMin right of
                  Just (f, _) -> Different $ Bag.one $ FieldTypo f (Map.keys fields1)
                  Nothing -> Similar
              (False, False) ->
                Similar
  
  hasFixedFields :: Extension -> Bool
  hasFixedFields ext =
    case ext of
      Closed -> True
      FlexOpen _ -> False
      RigidOpen _ -> True
  
  -- DIFF RECORD EXTENSION
  
  extToDiff :: Extension -> Extension -> Diff (Maybe D.Doc)
  extToDiff ext1 ext2 =
    let status = extToStatus ext1 ext2
        extDoc1 = extToDoc ext1
        extDoc2 = extToDoc ext2
     in case status of
          Similar ->
            Diff extDoc1 extDoc2 status
          Different _ ->
            Diff (D.dullyellow <$> extDoc1) (D.dullyellow <$> extDoc2) status
  
  extToStatus :: Extension -> Extension -> Status
  extToStatus ext1 ext2 =
    case ext1 of
      Closed ->
        case ext2 of
          Closed -> Similar
          FlexOpen _ -> Similar
          RigidOpen _ -> Different Bag.empty
      FlexOpen _ ->
        Similar
      RigidOpen x ->
        case ext2 of
          Closed -> Different Bag.empty
          FlexOpen _ -> Similar
          RigidOpen y ->
            if x == y
              then Similar
              else Different $ Bag.one $ BadRigidVar x (RigidVar y)
  