symantic/Language/Symantic/Typing/Document.hs

   1 {-# LANGUAGE PolyKinds #-}
   2 {-# LANGUAGE TypeInType #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Language.Symantic.Typing.Document where
   5
   6 import Data.Function (id)
   7 import Data.Map.Strict (Map)
   8 import Data.Maybe (fromMaybe)
   9 import Data.Monoid (Monoid(..))
  10 import Data.Semigroup (Semigroup(..))
  11 import Data.Set (Set)
  12 import Data.Text (Text)
  13 import Data.Typeable
  14 import qualified Data.List as L
  15 import qualified Data.Map.Strict as Map
  16 import qualified Data.Set as Set
  17 import qualified Data.Text as T
  18 import qualified Symantic.Document as Doc
  19
  20 import Language.Symantic.Grammar
  21 import Language.Symantic.Typing.Kind
  22 import Language.Symantic.Typing.Variable
  23 import Language.Symantic.Typing.Module
  24 import Language.Symantic.Typing.Type
  25
  26 -- * Type 'Config_Doc_Type'
  27 data Config_Doc_Type
  28  =   Config_Doc_Type
  29  {   config_Doc_Type_vars_numbering :: Bool
  30      -- ^ Style of /type variables/:
  31      --
  32      -- * if 'True': use name and position (as in @a0@ then @a1@)
  33      -- * if 'False': use name, and a counter when names collide (as in @a@ then @a1@)
  34      --
  35      -- NOTE: if the name is empty, a 'freshName' is taken from 'poolNames'.
  36  ,   config_Doc_Type_imports :: Imports NameTy
  37  }
  38
  39 config_Doc_Type :: Config_Doc_Type
  40 config_Doc_Type =
  41         Config_Doc_Type
  42          { config_Doc_Type_vars_numbering = True
  43          , config_Doc_Type_imports        = mempty
  44          }
  45
  46 -- * Document 'Type'
  47 docType ::
  48  forall src vs t d.
  49  Semigroup d =>
  50  Doc.From (Doc.Word Char) d =>
  51  Doc.From (Doc.Word Text) d =>
  52  Doc.Spaceable d =>
  53  Doc.Colorable16 d =>
  54  Config_Doc_Type ->
  55  Precedence ->
  56  Type src vs t -> d
  57 docType conf@Config_Doc_Type{config_Doc_Type_imports=imps} pr ty =
  58         let (v2n, _) = var2Name conf mempty ty in
  59         go v2n (infixB SideL pr, SideL) ty
  60         where
  61         go ::
  62          forall kx (x::kx).
  63          Map IndexVar Name -> -- names of variables
  64          (Infix, Side) ->
  65          Type src vs x -> d
  66         -- Var
  67         go v2n _po (TyVar _src _n v) =
  68                 let iv = indexVar v in
  69                 case Map.lookup iv v2n of
  70                  Nothing -> error "[BUG] docType: variable name missing"
  71                  Just n -> Doc.from (Doc.Word n)
  72         -- Const
  73         go _v2n _po (TyConst _src _vs c@Const{}) =
  74                 (if isNameTyOp c then docParen else id) $
  75                 docConst imps c
  76         -- [] Const
  77         go v2n _po (TyApp _ (TyConst _ _ f@Const{}) a)
  78          | Just HRefl <- proj_ConstKi @(K []) @[] f =
  79                 Doc.between (Doc.from (Doc.Word '[')) (Doc.from (Doc.Word ']')) $
  80                 go v2n (infixB SideL 0, SideL) a
  81         -- Infix Const
  82         go v2n po (TyApp _ (TyApp _ (TyConst _ _ f@Const{}) a) b)
  83          -- () =>
  84          | Just HRefl <- proj_ConstKiTy @Constraint @(()::Constraint) a
  85          , Just HRefl <- proj_ConstKi @(K (#>)) @(#>) f =
  86                 go v2n po b
  87          | Just (Fixity2 op) <- fixityOf f =
  88                 (if isPairNeeded po op then docParen else id) $
  89                 go v2n (op, SideL) a <>
  90                 prettyConst f <>
  91                 go v2n (op, SideR) b
  92                 where
  93                 d_op :: Text -> d
  94                 d_op = Doc.yellower . Doc.from . Doc.Word
  95                 prettyConst :: forall k c. Const src (c::k) -> d
  96                 prettyConst c | Just HRefl <- proj_ConstKi @(K (#>)) @(#>) c = Doc.space <> d_op "=>" <> Doc.space
  97                 prettyConst c | Just HRefl <- proj_ConstKi @(K (#))  @(#)  c = d_op "," <> Doc.space
  98                 prettyConst c | Just HRefl <- proj_ConstKi @(K (,))  @(,)  c = d_op "," <> Doc.space
  99                 prettyConst c@Const{}
 100                  | r <- typeRepTyCon (typeRep c)
 101                  , tyConName   r =="#~"
 102                  , tyConModule r =="Language.Symantic.Typing.Type"
 103                  -- XXX: module name must be in sync with where (#~) is defined.
 104                  -- NOTE: cannot use 'proj_ConstKi' here
 105                  -- because (#~) has a polymorphic kind.
 106                  = Doc.space <> d_op "~" <> Doc.space
 107                  | otherwise = Doc.space <> d_op (docConst imps c) <> Doc.space
 108         -- TyApp
 109         go v2n po (TyApp _src f a) =
 110                 let op = infixL 11 in
 111                 (if isPairNeeded po op then docParen else id) $
 112                 go v2n (op, SideL) f <>
 113                 Doc.space <>
 114                 go v2n (op, SideR) a
 115         -- TyFam
 116         go v2n po (TyFam _src _len fam args) =
 117                 let op = infixL 11 in
 118                 (if isPairNeeded po op then docParen else id) $
 119                 docConst imps fam <>
 120                 foldlTys (\t acc ->
 121                         Doc.space <> go v2n (op, SideL) t <> acc
 122                  ) args mempty
 123
 124 -- | Return a 'Map' associating a distinct 'Name'
 125 -- for all the variables of the given 'Type'.
 126 var2Name ::
 127  Config_Doc_Type ->
 128  (Map IndexVar Name, Names) ->
 129  Type src vs t ->
 130  (Map IndexVar Name, Names)
 131 var2Name _cfg st TyConst{} = st
 132 var2Name cfg st@(v2n, ns) (TyVar _src (NameVar n) v) =
 133         let iv = indexVar v in
 134         case Map.lookup iv v2n of
 135          Just{} -> st
 136          Nothing ->
 137                 let n' =
 138                         if config_Doc_Type_vars_numbering cfg && not (T.null n)
 139                         then n <> T.pack (show iv)
 140                         else freshifyName ns n in
 141                 let v2n' = Map.insert iv n' v2n in
 142                 let ns'  = Set.insert n' ns in
 143                 (v2n', ns')
 144 var2Name cfg st (TyApp _src f a) = var2Name cfg (var2Name cfg st f) a
 145 var2Name cfg st (TyFam _src _len _fam as) = foldlTys (flip $ var2Name cfg) as st
 146
 147 -- ** Type 'Names'
 148 type Names = Set Name
 149
 150 -- | Return given 'Name' renamed a bit to avoid
 151 -- conflicting with any given 'Names'.
 152 freshifyName :: Names -> Name -> Name
 153 freshifyName ns "" = freshName ns
 154 freshifyName ns n =
 155         let ints = [1..] :: [Int] in
 156         L.head
 157          [ fresh
 158          | suffix <- "" : (show <$> ints)
 159          , fresh <- [n <> T.pack suffix]
 160          , fresh `Set.notMember` ns
 161          ]
 162
 163 freshName :: Names -> Name
 164 freshName ns = L.head $ poolNames L.\\ Set.toList ns
 165
 166 -- | Infinite list of unique 'Name's:
 167 -- @a, b, .., z, a1, b1 .., z1, a2, ..@
 168 poolNames :: [Name]
 169 poolNames =
 170         [ T.singleton n     | n <- ['a'..'z'] ] <>
 171         [ T.pack (n:show i) | n <- ['a'..'z']
 172                             , i <- [1 :: Int ..] ]
 173
 174 -- * Document 'Types'
 175 docTypes ::
 176  forall src vs ts d.
 177  Semigroup d =>
 178  Doc.From (Doc.Word Char) d =>
 179  Doc.From (Doc.Word Text) d =>
 180  Doc.Spaceable d =>
 181  Doc.Colorable16 d =>
 182  Config_Doc_Type ->
 183  Types src vs ts -> d
 184 docTypes conf tys =
 185         d_op (Doc.from (Doc.Word '[')) <> go tys <> d_op (Doc.from (Doc.Word ']'))
 186         where
 187         d_op = Doc.yellower
 188         go :: forall xs. Types src vs xs -> d
 189         go TypesZ = mempty
 190         go (TypesS t0 (TypesS t1 ts)) =
 191                 docType conf 10 t0 <>
 192                 d_op (Doc.from (Doc.Word ',')) <> Doc.space <>
 193                 docType conf 10 t1 <>
 194                 go ts
 195         go (TypesS t ts) = docType conf 10 t <> go ts
 196
 197 -- * Document 'Const'
 198 docConst ::
 199  Monoid d =>
 200  Doc.From (Doc.Word Char) d =>
 201  Doc.From (Doc.Word Text) d =>
 202  Imports NameTy -> Const src c -> d
 203 docConst imps c@Const{} =
 204         docMod docNameTy $
 205         maybe mn (`Mod` n) $
 206         revlookupImports f (m `Mod` n) imps
 207         where
 208         f = fixyOfFixity $ Fixity2 infixN5 `fromMaybe` fixityOf c
 209         mn@(m `Mod` n) = nameTyOf c
 210
 211 -- * Document 'NameTy'
 212 docNameTy :: Doc.From (Doc.Word Text) d => NameTy -> d
 213 docNameTy (NameTy t) = Doc.from (Doc.Word t)
 214
 215 -- * Document 'Mod'
 216 docMod ::
 217  Monoid d =>
 218  Doc.From (Doc.Word Char) d =>
 219  Doc.From (Doc.Word Text) d =>
 220  (a -> d) -> Mod a -> d
 221 docMod a2d ([] `Mod` a) = a2d a
 222 docMod a2d (m `Mod`  a) = docPathMod m <> (Doc.from (Doc.Word '.')) <> a2d a
 223
 224 -- * Document 'PathMod'
 225 docPathMod ::
 226  Monoid d =>
 227  Doc.From (Doc.Word Char) d =>
 228  Doc.From (Doc.Word Text) d =>
 229  PathMod -> d
 230 docPathMod (p::PathMod) =
 231         mconcat $
 232         L.intersperse (Doc.from (Doc.Word '.')) $
 233         (\(NameMod n) -> Doc.from (Doc.Word n)) <$> p
 234
 235 docParen :: Doc.Spaceable d => Doc.From (Doc.Word Char) d => d -> d
 236 docParen = Doc.between (Doc.from (Doc.Word '(')) (Doc.from (Doc.Word ')'))
 237
 238 {-
 239 docModules ::
 240  Source src =>
 241  Doc.Textable d =>
 242  Doc.Colorable16 d =>
 243  Doc.Decorationable d =>
 244  ReadTe src ss =>
 245  Sym.Modules src ss -> d
 246 docModules (Sym.Modules mods) =
 247         Map.foldrWithKey
 248          (\p m doc -> docModule p m <> doc)
 249          mempty
 250          mods
 251
 252 docModule ::
 253  forall src ss d.
 254  Source src =>
 255  Doc.Textable d =>
 256  Doc.Colorable16 d =>
 257  Doc.Decorationable d =>
 258  ReadTe src ss =>
 259  Sym.PathMod -> Sym.Module src ss -> d
 260 docModule m Sym.Module
 261  { Sym.module_infix
 262  , Sym.module_prefix
 263  , Sym.module_postfix
 264  } =
 265         go docFixityInfix   module_infix <>
 266         go docFixityPrefix  module_prefix <>
 267         go docFixityPostfix module_postfix
 268         where
 269         go :: (fixy -> d) -> ModuleFixy src ss fixy -> d
 270         go docFixy =
 271                 Map.foldrWithKey
 272                  (\n Sym.Tokenizer
 273                          { Sym.token_fixity
 274                          , Sym.token_term = t
 275                          } doc ->
 276                         docPathTe m n <>
 277                         docFixy token_fixity <>
 278                         Doc.space <> Doc.bold (Doc.yellower "::") <> Doc.space <>
 279                         docTokenTerm (t Sym.noSource) <>
 280                         Doc.eol <> doc)
 281                  mempty
 282
 283 docTokenTerm ::
 284  forall src ss d.
 285  Source src =>
 286  Doc.Textable d =>
 287  Doc.Colorable16 d =>
 288  ReadTe src ss =>
 289  Sym.Token_Term src ss -> d
 290 docTokenTerm t =
 291         let n2t = name2typeInj @ss in
 292         case Sym.readTerm n2t CtxTyZ (G.BinTree0 t) of
 293          Left{} -> error "[BUG] docTokenTerm: readTerm failed"
 294          Right (Sym.TermVT te) ->
 295                 Sym.docType Sym.config_doc_type
 296                  { config_Doc_Type_vars_numbering = False
 297                  } 0 $ Sym.typeOfTerm te
 298
 299 docFixityInfix :: (Doc.Decorationable t, Doc.Colorable16 t, Doc.Textable t) => Infix -> t
 300 docFixityInfix = \case
 301          Sym.Infix Nothing 5 -> mempty
 302          Sym.Infix a p ->
 303                 let docAssoc = \case
 304                          Sym.AssocL -> "l"
 305                          Sym.AssocR -> "r"
 306                          Sym.AssocB Sym.SideL -> "l"
 307                          Sym.AssocB Sym.SideR -> "r" in
 308                 Doc.magenta $ " infix" <> maybe mempty docAssoc a <>
 309                 Doc.space <> Doc.bold (Doc.bluer (Doc.int p))
 310 docFixityPrefix :: (Doc.Decorationable t, Doc.Colorable16 t, Doc.Textable t) => Unifix -> t
 311 docFixityPrefix p = Doc.magenta $ " prefix "  <> Doc.bold (Doc.bluer (Doc.int $ Sym.unifix_prece p))
 312 docFixityPostfix :: (Doc.Decorationable t, Doc.Colorable16 t, Doc.Textable t) => Unifix -> t
 313 docFixityPostfix p = Doc.magenta $ " postfix " <> Doc.bold (Doc.bluer (Doc.int $ Sym.unifix_prece p))
 314
 315 docPathTe ::
 316  Doc.Textable d =>
 317  Doc.Colorable16 d =>
 318  Sym.PathMod -> Sym.NameTe -> d
 319 docPathTe (ms::Sym.PathMod) (Sym.NameTe n) =
 320         Doc.catH $
 321         L.intersperse (Doc.charH '.') $
 322         ((\(Sym.NameMod m) -> Doc.textH m) <$> ms) <>
 323         [(if isOp n then id else Doc.yellower) $ Doc.text n]
 324         where
 325         isOp = T.all $ \case '_' -> True; '\'' -> True; c -> Char.isAlphaNum c
 326 -}