content: {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE KindSignatures #-}
  {-# LANGUAGE ViewPatterns #-}
  {-# LANGUAGE Strict #-}
  {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE LambdaCase #-}
  
  -- |
  
  module Duet.Printer where
  
  import           Data.Char
  import           Data.List
  import qualified Data.Map.Strict as M
  import           Duet.Types
  import           Text.Printf
  
  class PrintableType (t :: * -> *) where
    printType :: Printable i => Print i l -> SpecialTypes i -> t i -> String
  
  instance PrintableType (Predicate Type) where
    printType = printPredicate
  
  class (Eq a, Identifiable a) => Printable a where
    printit :: Print i l -> a -> String
  
  instance Printable Name where
    printit printer =
      \case
        PrimopName primop -> printPrimop primop
        ValueName i string ->
          string ++
          (if printNameDetails printer
             then "[value:" ++ show i ++ "]"
             else "")
        TypeName i string ->
          string ++
          (if printNameDetails printer
             then "[type:" ++ show i ++ "]"
             else "")
        ConstructorName i string ->
          string ++
          (if printNameDetails printer
             then "[constructor:" ++ show i ++ "]"
             else "")
        ForallName i -> "g" ++ show i
        DictName i string ->
          string ++
          (if printNameDetails printer
             then "[dict:" ++ show i ++ "]"
             else "")
        ClassName i s ->
          s ++
          (if printNameDetails printer
             then "[class:" ++ show i ++ "]"
             else "")
        MethodName i s ->
          s ++
          (if printNameDetails printer
             then "[method:" ++ show i ++ "]"
             else "")
  
  printPrimop :: Primop -> [Char]
  printPrimop =
    \case
      PrimopIntegerSubtract -> "subtract"
      PrimopIntegerTimes -> "times"
      PrimopIntegerPlus -> "plus"
      PrimopRationalSubtract -> "subtract"
      PrimopRationalTimes -> "times"
      PrimopRationalPlus -> "plus"
      PrimopRationalDivide -> "divide"
      PrimopStringAppend -> "append"
      PrimopStringDrop -> "drop"
      PrimopStringTake -> "take"
  
  instance Printable Identifier where
    printit _ =
      \case
        Identifier string -> string
  
  defaultPrint :: Print i b
  defaultPrint =
    Print
    { printDictionaries = False
    , printTypes = const Nothing
    , printNameDetails = False
    }
  
  data Print i l = Print
    { printTypes :: (l -> Maybe (SpecialTypes i, TypeSignature Type i ()))
    , printDictionaries :: Bool
    , printNameDetails :: Bool
    }
  
  printDataType :: (Printable i, PrintableType t) => Print i l -> SpecialTypes i -> DataType t i -> String
  printDataType printer specialTypes (DataType name vars cons) =
    "data " ++ printit printer name ++ " " ++ unwords (map (printTypeVariable printer) vars) ++ "\n  = " ++
      intercalate "\n  | " (map (printConstructor printer specialTypes) cons)
  
  printConstructor :: (Printable i, PrintableType t) => Print i l ->  SpecialTypes i -> DataTypeConstructor t i -> [Char]
  printConstructor printer specialTypes (DataTypeConstructor name fields) =
    printit printer name ++ " " ++ unwords (map (printType printer specialTypes) fields)
  
  printTypeSignature
    :: (Printable i, Printable j)
    => Print i l ->  SpecialTypes i -> TypeSignature Type i j -> String
  printTypeSignature printer specialTypes (TypeSignature thing scheme) =
    printit printer thing ++ " :: " ++ printScheme printer specialTypes scheme
  
  printIdentifier :: Printable j => Print i l ->  j -> String
  printIdentifier printer = printit printer
  
  printImplicitlyTypedBinding
    :: (Printable i, PrintableType t)
    => Print i l -> ImplicitlyTypedBinding t i l -> String
  printImplicitlyTypedBinding printer (ImplicitlyTypedBinding _ (i, _) [alt]) =
    printIdentifier printer i ++ " " ++ printAlternative printer alt
  printImplicitlyTypedBinding _ _ = ""
  
  printExplicitlyTypedBinding
    :: (Printable i, PrintableType t)
    => Print i l -> SpecialTypes i -> ExplicitlyTypedBinding t i l -> String
  printExplicitlyTypedBinding printer specialTypes (ExplicitlyTypedBinding _ (i, _) scheme [alt]) =
    printIdentifier printer i ++ " :: " ++ printScheme printer specialTypes scheme ++ "\n" ++
    printIdentifier printer i ++ " " ++ printAlternative printer alt
  printExplicitlyTypedBinding _ _ _ = ""
  
  printAlternative :: (Printable i, PrintableType t) => Print i l -> Alternative t i l -> [Char]
  printAlternative printer (Alternative _ patterns expression) =
    concat (map (\p->printPattern printer p ++ " ") patterns) ++ "= " ++ printExpression printer expression
  
  printPattern :: (Printable i, PrintableType t) => Print i l ->  Pattern t i l -> [Char]
  printPattern printer =
    \case
      BangPattern p -> "!" ++ printPattern printer p
      VariablePattern _ i -> printIdentifier printer i
      WildcardPattern _ s -> s
      AsPattern _ i p -> printIdentifier printer i ++ "@" ++ printPattern printer p
      LiteralPattern _ l -> printLiteral l
      ConstructorPattern _ i pats ->
        printIdentifier printer i ++ " " ++ unwords (map (printPattern printer) pats)
  
  printExpression :: (Printable i, PrintableType t) => Print i l -> (Expression t i l) -> String
  printExpression printer e =
    wrapType
      (case e of
         LiteralExpression _ l -> printLiteral l
         VariableExpression _ i -> printIdentifier printer i
         ConstantExpression _ i -> printIdentifier printer i
         ConstructorExpression _ i -> printIdentifier printer i
         ParensExpression _ e -> "(" <> (printExpression printer e) <> ")"
         CaseExpression _ e alts ->
           "case " ++
           indent 5 (printExpressionIfPred printer e) ++
           " of\n" ++ indented (intercalate "\n" (map (printAlt printer) alts))
         ApplicationExpression _ f x ->
           case x of
             VariableExpression _ (nonrenamableName -> Just (DictName {}))
               | not (printDictionaries printer) -> printExpressionAppOp printer f
             _ ->
               if any (== '\n') inner || any (== '\n') prefix
                 then prefix ++ "\n" ++ indented inner
                 else prefix ++ " " ++ indent (length prefix + 1) inner
               where prefix = printExpressionAppOp printer f
                     inner = printExpressionAppArg printer x
         LambdaExpression _ (Alternative _ args e) ->
           if null filteredArgs
             then inner
             else if any (== '\n') inner
                    then "\\" ++ prefix ++ "->\n" ++ indented inner
                    else "\\" ++
                         prefix ++ "-> " ++ indent (length prefix + 4) inner
           where inner = (printExpression printer e)
                 filteredArgs = filter dictPred args
                 prefix =
                   concat (map (\x -> printPattern printer x ++ " ") filteredArgs)
                 dictPred =
                   if printDictionaries printer
                     then const True
                     else \case
                            VariablePattern _ (nonrenamableName -> Just (DictName {})) ->
                              False
                            _ -> True
         IfExpression _ a b c ->
           "if " ++
           printExpressionIfPred printer a ++
           " then " ++
           printExpression printer b ++ " else " ++ printExpression printer c
         InfixExpression _ f (o, ov) x ->
           printExpressionAppArg printer f ++
           " " ++
           (if printDictionaries printer
              then "`" ++ printExpression printer ov ++ "`"
              else o) ++
           " " ++ printExpressionAppArg printer x
         _ -> "<TODO>")
    where
      wrapType x =
        case printTypes printer (expressionLabel e) of
          (Nothing) -> x
          (Just (specialTypes, TypeSignature _ ty)) ->
            "(" ++
            parens x ++ " :: " ++ printScheme printer specialTypes ty ++ ")"
            where parens k =
                    if any isSpace k
                      then "(" ++ k ++ ")"
                      else k
  
  printAlt
    :: (PrintableType t, Printable i)
    => Print i l -> (CaseAlt t i l) -> [Char]
  printAlt printer =
    \(CaseAlt _ p e') ->
      let inner = printExpression printer e'
      in if any (== '\n') inner
           then printPat printer p ++ " ->\n" ++ indented inner
           else printPat printer p ++ " -> " ++ indent 2 inner
  
  indented :: String -> [Char]
  indented x = intercalate "\n" (map ("  "++) (lines x))
  
  indent :: Int -> String -> [Char]
  indent n = intercalate ("\n" ++ replicate n ' ') . lines
  
  lined :: [[Char]] -> [Char]
  lined = intercalate "\n  "
  
  printPat :: (Printable i, PrintableType t) => Print i l ->  Pattern t i l -> String
  printPat printer=
    \case
      BangPattern p -> "!" ++ printPat printer p
      VariablePattern _ i -> printit printer i
      ConstructorPattern _ i ps ->
        printit printer i ++
        (if null ps
           then ""
           else " " ++ unwords (map inner ps))
      WildcardPattern{} -> "_"
      AsPattern _ ident p -> printit printer ident ++ "@" ++ printPat printer p
      LiteralPattern _ l -> printLiteral l
    where
      inner =
        \case
          BangPattern p -> "!" ++ inner p
          VariablePattern _ i -> printit printer i
          WildcardPattern _ s -> s
          ConstructorPattern _ i ps
            | null ps -> printit printer i
            | otherwise ->
              "(" ++ printit printer i ++ " " ++ unwords (map inner ps) ++ ")"
          AsPattern _ ident p -> printit printer ident ++ "@" ++ printPat printer p
          LiteralPattern _ l -> printLiteral l
  
  printExpressionAppArg :: (Printable i, PrintableType t) => Print i l ->(Expression t i l) -> String
  printExpressionAppArg printer =
    \case
      e@(ApplicationExpression {})
        | nodict e -> paren (printExpression printer e)
      e@(IfExpression {}) -> paren (printExpression printer e)
      e@(InfixExpression {}) -> paren (printExpression printer e)
      e@(LambdaExpression {}) -> paren (printExpression printer e)
      e@(CaseExpression {}) -> paren (printExpression printer e)
      e -> printExpression printer e
    where
      nodict =
        \case
          ApplicationExpression _ _ (VariableExpression _ (nonrenamableName -> Just (DictName {})))
            | not (printDictionaries printer) -> False
          _ -> True
  
  printExpressionIfPred :: (Printable i, PrintableType t) => Print i l -> (Expression t i l) -> String
  printExpressionIfPred printer=
    \case
      e@(IfExpression {}) -> paren (printExpression printer e)
      e@(LambdaExpression {}) -> paren (printExpression printer e)
      e@(CaseExpression {}) -> paren (printExpression printer e)
      e -> printExpression printer e
  
  printExpressionAppOp :: (Printable i, PrintableType t) => Print i l -> (Expression t i l) -> String
  printExpressionAppOp printer=
    \case
      e@(IfExpression {}) -> paren (printExpression printer e)
      e@(LambdaExpression {}) -> paren (printExpression printer e)
      e@(CaseExpression {}) -> paren (printExpression printer e)
      e -> printExpression printer e
  
  paren :: [Char] -> [Char]
  paren e = "("  ++ indent 1 e ++ ")"
  
  printLiteral :: Literal -> String
  printLiteral (IntegerLiteral i) = show i
  printLiteral (RationalLiteral i) = printf "%f" (fromRational i :: Double)
  printLiteral (StringLiteral x) = show x
  printLiteral (CharacterLiteral x) = show x
  
  printScheme :: (Printable i, PrintableType t, PrintableType t1) => Print i l -> SpecialTypes i -> Scheme t i t1 -> [Char]
  printScheme printer specialTypes (Forall kinds qualifiedType') =
    (if null kinds
       then ""
       else "forall " ++
            unwords
              (zipWith
                 (\_i k ->
                    printTypeVariable
                      (Print
                       { printTypes = const Nothing
                       , printDictionaries = False
                       , printNameDetails = printNameDetails printer
                       })
                      k)
                 [0 :: Int ..]
                 kinds) ++
            ". ") ++
    printQualifiedType specialTypes qualifiedType'
    where
      printQualifiedType specialTypes (Qualified predicates typ) =
        case predicates of
          [] -> printType printer specialTypes typ
          _ ->
            "(" ++
            intercalate
              ", "
              (map (printPredicate printer specialTypes) predicates) ++
            ") => " ++ printType printer specialTypes typ
  
  
  printClass :: Printable i => Print i l -> SpecialTypes i -> Class Type i l -> String
  printClass printer specialTypes (Class vars supers instances i methods) =
    "class " ++
    printSupers printer specialTypes supers ++
    printit printer i ++
    " " ++
    unwords (map (printTypeVariable printer) vars) ++ " where\n  " ++
    intercalate "\n  " (map (printMethod printer specialTypes) (M.toList methods)) ++
    "\n" ++ intercalate "\n" (map (printInstance printer specialTypes) instances)
  
  printMethod :: Printable i =>  Print i l -> SpecialTypes i -> (i, Scheme Type i Type) -> String
  printMethod printer specialTypes (i, scheme) =
    printit printer i ++ " :: " ++ printScheme printer specialTypes scheme
  
  printInstance :: Printable i => Print i l -> SpecialTypes i -> Instance Type i l -> String
  printInstance printer specialTypes (Instance scheme _) =
    "instance " ++
    printScheme printer specialTypes scheme
  
  printSupers :: Printable i => Print i l -> SpecialTypes i -> [Predicate Type i] -> [Char]
  printSupers printer specialTypes supers
    | null supers = ""
    | otherwise =
      "(" ++ intercalate ", " (map (printPredicate printer specialTypes) supers) ++ ") => "
  
  
  printPredicate :: (Printable i, PrintableType t) => Print i l -> SpecialTypes i -> Predicate t i -> [Char]
  printPredicate printer specialTypes (IsIn identifier types) =
    printIdentifier printer identifier ++
    " " ++ unwords (map (wrap . printType printer specialTypes) types)
    where wrap x = if any isSpace x
                      then "(" ++ x ++ ")"
                      else x
  
  printKind :: Kind -> [Char]
  printKind =
    \case
      StarKind -> "Type"
      FunctionKind x' y -> printKind x' ++ " -> " ++ printKind y
  
  printTypeSansParens :: (Printable i) => Print i l ->  SpecialTypes i -> Type i -> [Char]
  printTypeSansParens printer specialTypes =
    \case
      ApplicationType (ApplicationType func x') y'
        | func == ConstructorType (specialTypesFunction specialTypes) ->
          printType printer specialTypes x' ++
          " -> " ++ printTypeSansParens printer specialTypes y'
      o -> printType printer specialTypes o
  
  instance PrintableType Type where
    printType printer specialTypes =
      \case
        VariableType v -> printTypeVariable printer v
        ConstructorType tyCon -> printTypeConstructor printer tyCon
        ApplicationType (ApplicationType func x') y
          | func == ConstructorType (specialTypesFunction specialTypes) ->
            "(" ++
            printType printer specialTypes x' ++
            " -> " ++ printTypeSansParens printer specialTypes y ++ ")"
      -- ApplicationType list ty | list == specialTypesList specialTypes ->
      --   "[" ++ printTypeSansParens specialTypes ty ++ "]"
        ApplicationType x' y ->
          printType printer specialTypes x' ++ " " ++ printTypeArg y
        -- GenericType int -> "g" ++ show int
      where
        printTypeArg =
          \case
            x@ApplicationType {} -> "(" ++ printType printer specialTypes x ++ ")"
            x -> printType printer specialTypes x
  
  instance PrintableType UnkindedType where
    printType printer specialTypes =
      \case
        UnkindedTypeVariable v -> printIdentifier printer v
        UnkindedTypeConstructor tyCon -> printIdentifier printer tyCon
        UnkindedTypeApp x' y ->
          "(" ++ printType printer specialTypes x' ++ " " ++ printType printer specialTypes y ++ ")"
  
  printTypeConstructor :: Printable j => Print i l -> TypeConstructor j -> String
  printTypeConstructor printer (TypeConstructor identifier kind) =
    case kind of
      StarKind -> printIdentifier printer identifier
      FunctionKind {} -> printIdentifier printer identifier
          -- _ -> "(" ++ printIdentifier identifier ++ " :: " ++ printKind kind ++ ")"
  
  printTypeVariable :: Printable i => Print i l -> TypeVariable i -> String
  printTypeVariable printer (TypeVariable identifier kind) =
    case kind of
      StarKind -> printIdentifier printer identifier
      _ -> "(" ++ printIdentifier printer identifier ++ " :: " ++ printKind kind ++ ")"
  
  curlyQuotes :: [Char] -> [Char]
  curlyQuotes t = "‘" <> t <> "’"
  