content: {-# OPTIONS_GHC -Wall #-}
  {-# LANGUAGE OverloadedStrings #-}
  module Reporting.Render.Type
    ( Context(..)
    , lambda
    , apply
    , tuple
    , record
    , vrecordSnippet
    , vrecord
    , srcToDoc
    , canToDoc
    )
    where
  
  
  import qualified Data.Maybe as Maybe
  import qualified Data.Name as Name
  
  import qualified AST.Source as Src
  import qualified AST.Canonical as Can
  import qualified Reporting.Annotation as A
  import qualified Reporting.Doc as D
  import Reporting.Doc ( Doc, (<+>), (<>) )
  import qualified Reporting.Render.Type.Localizer as L
  
  
  
  -- TO DOC
  
  
  data Context
    = None
    | Func
    | App
  
  
  lambda :: Context -> Doc -> Doc -> [Doc] -> Doc
  lambda context arg1 arg2 args =
    let
      lambdaDoc =
        D.align $ D.sep (arg1 : map ("->" <+>) (arg2:args))
    in
    case context of
      None -> lambdaDoc
      Func -> D.cat [ "(", lambdaDoc, ")" ]
      App  -> D.cat [ "(", lambdaDoc, ")" ]
  
  
  apply :: Context -> Doc -> [Doc] -> Doc
  apply context name args =
    case args of
      [] ->
        name
  
      _:_ ->
        let
          applyDoc =
            D.hang 4 (D.sep (name : args))
        in
        case context of
          App  -> D.cat [ "(", applyDoc, ")" ]
          Func -> applyDoc
          None -> applyDoc
  
  
  tuple :: Doc -> Doc -> [Doc] -> Doc
  tuple a b cs =
    let
      entries =
        zipWith (<+>) ("(" : repeat ",") (a:b:cs)
    in
    D.align $ D.sep [ D.cat entries, ")" ]
  
  
  record :: [(Doc, Doc)] -> Maybe Doc -> Doc
  record entries maybeExt =
    case (map entryToDoc entries, maybeExt) of
      ([], Nothing) ->
          "{}"
  
      (fields, Nothing) ->
          D.align $ D.sep $
            [ D.cat (zipWith (<+>) ("{" : repeat ",") fields)
            , "}"
            ]
  
      (fields, Just ext) ->
          D.align $ D.sep $
            [ D.hang 4 $ D.sep $
                [ "{" <+> ext
                , D.cat (zipWith (<+>) ("|" : repeat ",") fields)
                ]
            , "}"
            ]
  
  
  entryToDoc :: (Doc, Doc) -> Doc
  entryToDoc (fieldName, fieldType) =
    D.hang 4 (D.sep [ fieldName <+> ":", fieldType ])
  
  
  vrecordSnippet :: (Doc, Doc) -> [(Doc, Doc)] -> Doc
  vrecordSnippet entry entries =
    let
      field  = "{" <+> entryToDoc entry
      fields = zipWith (<+>) (repeat ",") (map entryToDoc entries ++ ["..."])
    in
    D.vcat (field : fields ++ ["}"])
  
  
  vrecord :: [(Doc, Doc)] -> Maybe Doc -> Doc
  vrecord entries maybeExt =
    case (map entryToDoc entries, maybeExt) of
      ([], Nothing) ->
        "{}"
  
      (fields, Nothing) ->
        D.vcat $
          zipWith (<+>) ("{" : repeat ",") fields ++ ["}"]
  
      (fields, Just ext) ->
        D.vcat
          [ D.hang 4 $ D.vcat $
              [ "{" <+> ext
              , D.cat (zipWith (<+>) ("|" : repeat ",") fields)
              ]
          , "}"
          ]
  
  
  
  -- SOURCE TYPE TO DOC
  
  
  srcToDoc :: Context -> Src.Type -> Doc
  srcToDoc context (A.At _ tipe) =
    case tipe of
      Src.TLambda arg1 result ->
        let
          (arg2, rest) = collectSrcArgs result
        in
        lambda context
          (srcToDoc Func arg1)
          (srcToDoc Func arg2)
          (map (srcToDoc Func) rest)
  
      Src.TVar name ->
        D.fromName name
  
      Src.TType _ name args ->
        apply context
          (D.fromName name)
          (map (srcToDoc App) args)
  
      Src.TTypeQual _ home name args ->
        apply context
          (D.fromName home <> "." <> D.fromName name)
          (map (srcToDoc App) args)
  
      Src.TRecord fields ext ->
        record
          (map srcFieldToDocs fields)
          (fmap (D.fromName . A.toValue) ext)
  
      Src.TUnit ->
        "()"
  
      Src.TTuple a b cs ->
        tuple
          (srcToDoc None a)
          (srcToDoc None b)
          (map (srcToDoc None) cs)
  
  
  srcFieldToDocs :: (A.Located Name.Name, Src.Type) -> (Doc, Doc)
  srcFieldToDocs (A.At _ fieldName, fieldType) =
    ( D.fromName fieldName
    , srcToDoc None fieldType
    )
  
  
  collectSrcArgs :: Src.Type -> (Src.Type, [Src.Type])
  collectSrcArgs tipe =
    case tipe of
      A.At _ (Src.TLambda a result) ->
        let
          (b, cs) = collectSrcArgs result
        in
        (a, b:cs)
  
      _ ->
        (tipe, [])
  
  
  
  -- CANONICAL TYPE TO DOC
  
  
  canToDoc :: L.Localizer -> Context -> Can.Type -> Doc
  canToDoc localizer context tipe =
    case tipe of
      Can.TLambda arg1 result ->
        let
          (arg2, rest) = collectArgs result
        in
        lambda context
          (canToDoc localizer Func arg1)
          (canToDoc localizer Func arg2)
          (map (canToDoc localizer Func) rest)
  
      Can.TVar name ->
        D.fromName name
  
      Can.TType home name args ->
        apply context
          (L.toDoc localizer home name)
          (map (canToDoc localizer App) args)
  
      Can.TRecord fields ext ->
        record
          (map (canFieldToDoc localizer) (Can.fieldsToList fields))
          (fmap D.fromName ext)
  
      Can.TUnit ->
        "()"
  
      Can.TTuple a b maybeC ->
        tuple
          (canToDoc localizer None a)
          (canToDoc localizer None b)
          (map (canToDoc localizer None) (Maybe.maybeToList maybeC))
  
      Can.TAlias home name args _ ->
        apply context
          (L.toDoc localizer home name)
          (map (canToDoc localizer App . snd) args)
  
  
  canFieldToDoc :: L.Localizer -> (Name.Name, Can.Type) -> (Doc, Doc)
  canFieldToDoc localizer (name, tipe) =
    ( D.fromName name
    , canToDoc localizer None tipe
    )
  
  
  collectArgs :: Can.Type -> (Can.Type, [Can.Type])
  collectArgs tipe =
    case tipe of
      Can.TLambda a rest ->
        let
          (b, cs) = collectArgs rest
        in
        (a, b:cs)
  
      _ ->
        (tipe, [])
  