Sync symantic with symantic-document.

diff --git a/symantic/Language/Symantic/Typing/Document.hs b/symantic/Language/Symantic/Typing/Document.hs
index ff7c4b879605ffd8c97c770ed124427551d939e2..765efaac428f4e65426c150837d3a4147241026e 100644 (file)
--- a/symantic/Language/Symantic/Typing/Document.hs
+++ b/symantic/Language/Symantic/Typing/Document.hs
@@ -14,7 +14,7 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Text as T
 
-import qualified Language.Symantic.Document as D
+import qualified Language.Symantic.Document.Sym as Doc
 import Language.Symantic.Grammar
 import Language.Symantic.Typing.Kind
 import Language.Symantic.Typing.Variable
@@ -45,8 +45,8 @@ config_Doc_Type =
 docType ::
  forall src vs t d.
  Semigroup d =>
- D.Doc_Text d =>
- D.Doc_Color d =>
+ Doc.Textable d =>
+ Doc.Colorable d =>
  Config_Doc_Type ->
  Precedence ->
  Type src vs t -> d
@@ -64,10 +64,10 @@ docType conf@Config_Doc_Type{config_Doc_Type_imports=imps} pr ty =
                let iv = indexVar v in
                case Map.lookup iv v2n of
                 Nothing -> error "[BUG] docType: variable name missing"
-                Just n -> D.textH n
+                Just n -> Doc.textH n
        -- Const
        go _v2n _po (TyConst _src _vs c@Const{}) =
-               (if isNameTyOp c then D.paren else id) $
+               (if isNameTyOp c then docParen else id) $
                docConst imps c
        -- [] Const
        go v2n _po (TyApp _ (TyConst _ _ f@Const{}) a)
@@ -80,16 +80,16 @@ docType conf@Config_Doc_Type{config_Doc_Type_imports=imps} pr ty =
         , Just HRefl <- proj_ConstKi @(K (#>)) @(#>) f =
                go v2n po b
         | Just (Fixity2 op) <- fixityOf f =
-               (if needsParenInfix po op then D.paren else id) $
+               (if needsParenInfix po op then docParen else id) $
                go v2n (op, SideL) a <>
                prettyConst f <>
                go v2n (op, SideR) b
                where
-               d_op = D.yellower
+               d_op = Doc.yellower
                prettyConst :: forall k c. Const src (c::k) -> d
-               prettyConst c | Just HRefl <- proj_ConstKi @(K (#>)) @(#>) c = D.space <> d_op "=>" <> D.space
-               prettyConst c | Just HRefl <- proj_ConstKi @(K (#))  @(#)  c = d_op "," <> D.space
-               prettyConst c | Just HRefl <- proj_ConstKi @(K (,))  @(,)  c = d_op "," <> D.space
+               prettyConst c | Just HRefl <- proj_ConstKi @(K (#>)) @(#>) c = Doc.space <> d_op "=>" <> Doc.space
+               prettyConst c | Just HRefl <- proj_ConstKi @(K (#))  @(#)  c = d_op "," <> Doc.space
+               prettyConst c | Just HRefl <- proj_ConstKi @(K (,))  @(,)  c = d_op "," <> Doc.space
                prettyConst c@Const{}
                 | r <- typeRepTyCon (typeRep c)
                 , tyConName   r =="#~"
@@ -97,23 +97,23 @@ docType conf@Config_Doc_Type{config_Doc_Type_imports=imps} pr ty =
                 -- XXX: module name must be in sync with where (#~) is defined.
                 -- NOTE: cannot use 'proj_ConstKi' here
                 -- because (#~) has a polymorphic kind.
-                = D.space <> d_op "~" <> D.space
-                | otherwise = D.space <> d_op (docConst imps c) <> D.space
+                = Doc.space <> d_op "~" <> Doc.space
+                | otherwise = Doc.space <> d_op (docConst imps c) <> Doc.space
        -- TyApp
        go v2n po (TyApp _src f a) =
                let op = infixL 11 in
-               (if needsParenInfix po op then D.paren else id) $
+               (if needsParenInfix po op then docParen else id) $
                go v2n (op, SideL) f <>
-               D.space <>
+               Doc.space <>
                go v2n (op, SideR) a
        -- TyFam
        go v2n po (TyFam _src _len fam args) =
                let op = infixL 11 in
-               (if needsParenInfix po op then D.paren else id) $
+               (if needsParenInfix po op then docParen else id) $
                docConst imps fam <>
                foldlTys (\t acc ->
-                       D.space <> go v2n (op, SideL) t <> acc
-                ) args D.empty
+                       Doc.space <> go v2n (op, SideL) t <> acc
+                ) args Doc.empty
 
 -- | Return a 'Map' associating a distinct 'Name'
 -- for all the variables of the given 'Type'.
@@ -169,25 +169,25 @@ poolNames =
 docTypes ::
  forall src vs ts d.
  Semigroup d =>
- D.Doc_Text d =>
- D.Doc_Color d =>
+ Doc.Textable d =>
+ Doc.Colorable d =>
  Config_Doc_Type ->
  Types src vs ts -> d
 docTypes conf tys =
-       d_op (D.charH '[') <> go tys <> d_op (D.charH ']')
+       d_op (Doc.charH '[') <> go tys <> d_op (Doc.charH ']')
        where
-       d_op = D.yellower
+       d_op = Doc.yellower
        go :: forall xs. Types src vs xs -> d
-       go TypesZ = D.empty
+       go TypesZ = Doc.empty
        go (TypesS t0 (TypesS t1 ts)) =
                docType conf 10 t0 <>
-               d_op (D.charH ',') <> D.space <>
+               d_op (Doc.charH ',') <> Doc.space <>
                docType conf 10 t1 <>
                go ts
        go (TypesS t ts) = docType conf 10 t <> go ts
 
 -- * Document 'Const'
-docConst :: D.Doc_Text d => Imports NameTy -> Const src c -> d
+docConst :: Doc.Textable d => Imports NameTy -> Const src c -> d
 docConst imps c@Const{} =
        docMod docNameTy $
        maybe mn (`Mod` n) $
@@ -197,42 +197,44 @@ docConst imps c@Const{} =
        mn@(m `Mod` n) = nameTyOf c
 
 -- * Document 'NameTy'
-docNameTy :: D.Doc_Text d => NameTy -> d
-docNameTy (NameTy t) = D.textH t
+docNameTy :: Doc.Textable d => NameTy -> d
+docNameTy (NameTy t) = Doc.textH t
 
 -- * Document 'Mod'
-docMod :: D.Doc_Text d => (a -> d) -> Mod a -> d
+docMod :: Doc.Textable d => (a -> d) -> Mod a -> d
 docMod a2d ([] `Mod` a) = a2d a
-docMod a2d (m `Mod`  a) = docPathMod m <> (D.charH '.') <> a2d a
+docMod a2d (m `Mod`  a) = docPathMod m <> (Doc.charH '.') <> a2d a
 
 -- * Document 'PathMod'
-docPathMod :: D.Doc_Text d => PathMod -> d
+docPathMod :: Doc.Textable d => PathMod -> d
 docPathMod (p::PathMod) =
-       D.catH $
-       L.intersperse (D.charH '.') $
-       (\(NameMod n) -> D.textH n) <$> p
+       Doc.catH $
+       L.intersperse (Doc.charH '.') $
+       (\(NameMod n) -> Doc.textH n) <$> p
 
+docParen :: Doc.Textable d => d -> d
+docParen = Doc.between "(" ")"
 
 {-
 docModules ::
  Source src =>
- D.Doc_Text d =>
- D.Doc_Color d =>
- D.Doc_Decoration d =>
+ Doc.Textable d =>
+ Doc.Colorable d =>
+ Doc.Decorationable d =>
  ReadTe src ss =>
  Sym.Modules src ss -> d
 docModules (Sym.Modules mods) =
        Map.foldrWithKey
         (\p m doc -> docModule p m <> doc)
-        D.empty
+        Doc.empty
         mods
 
 docModule ::
  forall src ss d.
  Source src =>
- D.Doc_Text d =>
- D.Doc_Color d =>
- D.Doc_Decoration d =>
+ Doc.Textable d =>
+ Doc.Colorable d =>
+ Doc.Decorationable d =>
  ReadTe src ss =>
  Sym.PathMod -> Sym.Module src ss -> d
 docModule m Sym.Module
@@ -253,16 +255,16 @@ docModule m Sym.Module
                         } doc ->
                        docPathTe m n <>
                        docFixy token_fixity <>
-                       D.space <> D.bold (D.yellower "::") <> D.space <>
+                       Doc.space <> Doc.bold (Doc.yellower "::") <> Doc.space <>
                        docTokenTerm (t Sym.noSource) <>
-                       D.eol <> doc)
-                D.empty
+                       Doc.eol <> doc)
+                Doc.empty
 
 docTokenTerm ::
  forall src ss d.
  Source src =>
- D.Doc_Text d =>
- D.Doc_Color d =>
+ Doc.Textable d =>
+ Doc.Colorable d =>
  ReadTe src ss =>
  Sym.Token_Term src ss -> d
 docTokenTerm t =
@@ -274,31 +276,31 @@ docTokenTerm t =
                 { config_Doc_Type_vars_numbering = False
                 } 0 $ Sym.typeOfTerm te
 
-docFixityInfix :: (D.Doc_Decoration t, D.Doc_Color t, D.Doc_Text t) => Infix -> t
+docFixityInfix :: (Doc.Decorationable t, Doc.Colorable t, Doc.Textable t) => Infix -> t
 docFixityInfix = \case
-        Sym.Infix Nothing 5 -> D.empty
+        Sym.Infix Nothing 5 -> Doc.empty
         Sym.Infix a p ->
                let docAssoc = \case
                         Sym.AssocL -> "l"
                         Sym.AssocR -> "r"
                         Sym.AssocB Sym.SideL -> "l"
                         Sym.AssocB Sym.SideR -> "r" in
-               D.magenta $ " infix" <> maybe D.empty docAssoc a <>
-               D.space <> D.bold (D.bluer (D.int p))
-docFixityPrefix :: (D.Doc_Decoration t, D.Doc_Color t, D.Doc_Text t) => Unifix -> t
-docFixityPrefix p = D.magenta $ " prefix "  <> D.bold (D.bluer (D.int $ Sym.unifix_prece p))
-docFixityPostfix :: (D.Doc_Decoration t, D.Doc_Color t, D.Doc_Text t) => Unifix -> t
-docFixityPostfix p = D.magenta $ " postfix " <> D.bold (D.bluer (D.int $ Sym.unifix_prece p))
+               Doc.magenta $ " infix" <> maybe Doc.empty docAssoc a <>
+               Doc.space <> Doc.bold (Doc.bluer (Doc.int p))
+docFixityPrefix :: (Doc.Decorationable t, Doc.Colorable t, Doc.Textable t) => Unifix -> t
+docFixityPrefix p = Doc.magenta $ " prefix "  <> Doc.bold (Doc.bluer (Doc.int $ Sym.unifix_prece p))
+docFixityPostfix :: (Doc.Decorationable t, Doc.Colorable t, Doc.Textable t) => Unifix -> t
+docFixityPostfix p = Doc.magenta $ " postfix " <> Doc.bold (Doc.bluer (Doc.int $ Sym.unifix_prece p))
 
 docPathTe ::
- D.Doc_Text d =>
- D.Doc_Color d =>
+ Doc.Textable d =>
+ Doc.Colorable d =>
  Sym.PathMod -> Sym.NameTe -> d
 docPathTe (ms::Sym.PathMod) (Sym.NameTe n) =
-       D.catH $
-       L.intersperse (D.charH '.') $
-       ((\(Sym.NameMod m) -> D.textH m) <$> ms) <>
-       [(if isOp n then id else D.yellower) $ D.text n]
+       Doc.catH $
+       L.intersperse (Doc.charH '.') $
+       ((\(Sym.NameMod m) -> Doc.textH m) <$> ms) <>
+       [(if isOp n then id else Doc.yellower) $ Doc.text n]
        where
        isOp = T.all $ \case '_' -> True; '\'' -> True; c -> Char.isAlphaNum c
 -}

diff --git a/symantic/Language/Symantic/Typing/Show.hs b/symantic/Language/Symantic/Typing/Show.hs
index cbd360d534d1180ff549ae2b75f2975f038d07c2..23823f10839d565718b47a6438b877ba61897472 100644 (file)
--- a/symantic/Language/Symantic/Typing/Show.hs
+++ b/symantic/Language/Symantic/Typing/Show.hs
@@ -3,28 +3,34 @@
 module Language.Symantic.Typing.Show where
 
 import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as TLB
 
-import qualified Language.Symantic.Document as D
+import qualified Language.Symantic.Document.Term as Doc
 import Language.Symantic.Grammar
 import Language.Symantic.Typing.Type
 import Language.Symantic.Typing.Module
 import Language.Symantic.Typing.Document
 
+stringDocTerm :: Doc.Term -> String
+stringDocTerm =
+       TL.unpack .
+       Doc.textTerm .
+       Doc.withColorable False .
+       Doc.withDecorable False
+
 showType :: Config_Doc_Type -> Type src vs t -> String
-showType conf ty = TL.unpack $ TLB.toLazyText $ D.plain $ docType conf 0 ty
+showType conf ty = stringDocTerm $ docType conf 0 ty
 
 showTypeS :: Config_Doc_Type -> Precedence -> Type src vs t -> ShowS
-showTypeS conf pr ty = showString $ TL.unpack (TLB.toLazyText $ D.plain $ docType conf pr ty)
+showTypeS conf pr ty = showString $ stringDocTerm $ docType conf pr ty
 
 showTypes :: Config_Doc_Type -> Types src vs ts -> String
-showTypes conf tys = TL.unpack (TLB.toLazyText $ D.plain $ docTypes conf tys)
+showTypes conf tys = stringDocTerm $ docTypes conf tys
 
 showTypesS :: Config_Doc_Type -> Types src vs ts -> ShowS
-showTypesS conf tys = showString $ TL.unpack (TLB.toLazyText $ D.plain $ docTypes conf tys)
+showTypesS conf tys = showString $ stringDocTerm $ docTypes conf tys
 
 instance NameTyOf c => Show (Const src c) where
-       showsPrec _p = showString . TL.unpack . TLB.toLazyText . D.plain . docConst mempty
+       showsPrec _p = showString . stringDocTerm . docConst mempty
 
 instance Source src => Show (Type src vs t) where
        showsPrec = showTypeS config_Doc_Type