symantic 6.3.1.20180213 → 6.3.2.20180208

raw patch · 5 files changed

+77/−69 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Language/Symantic/Compiling/Beta.hs +1/−1
• Language/Symantic/Typing/Document.hs +60/−58
• Language/Symantic/Typing/Show.hs +13/−7
• stack.yaml +1/−1
• symantic.cabal +2/−2

@@ -8,7 +8,7 @@ import Language.Symantic.Typing import Language.Symantic.Compiling.Term --- | Term application: apply second given 'TermT' to the first,+-- | Term application: apply second given 'Term' to the first, -- applying embedded 'TeSym's, or return an error. betaTerm ::  forall src ss ts vs fun arg.

@@ -14,7 +14,7 @@ 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 @@ 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 @@ 		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 @@ 	 , 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 @@ 		 -- 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 @@ 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 @@ 	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 (Doc.charH '(') (Doc.charH ')')  {- 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 @@ 			 } 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 @@ 		 { 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 -}

@@ -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

@@ -1,4 +1,4 @@-resolver: lts-10.5+resolver: lts-12.8 packages: - '.' - location: '../symantic-grammar'

@@ -2,7 +2,7 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 6.3.1.20180213+version: 6.3.2.20180208 synopsis: Library for Typed Tagless-Final Higher-Order Composable DSL description: This is an experimental library for composing, parsing,              typing, compiling, transforming and interpreting@@ -20,7 +20,7 @@  build-type: Simple cabal-version: >= 1.24-tested-with: GHC==8.2.2+tested-with: GHC==8.4.3 extra-source-files:   stack.yaml extra-tmp-files: