|
1 | | -{-# LANGUAGE DeriveFunctor #-} |
2 | | -{-# LANGUAGE FlexibleInstances #-} |
3 | | -{-# LANGUAGE GADTs #-} |
4 | | -{-# LANGUAGE LambdaCase #-} |
5 | | -{-# LANGUAGE RankNTypes #-} |
6 | | -{-# LANGUAGE ScopedTypeVariables #-} |
7 | | -{-# LANGUAGE TypeOperators #-} |
8 | | -{-# LANGUAGE TypeSynonymInstances #-} |
| 1 | +{-# LANGUAGE FlexibleInstances #-} |
| 2 | +{-# LANGUAGE GADTs #-} |
| 3 | +{-# LANGUAGE RankNTypes #-} |
| 4 | +{-# LANGUAGE ScopedTypeVariables #-} |
9 | 5 |
|
10 | 6 | module Data.Schema.PrettyPrint |
11 | | - ( SchemaDoc (..) |
12 | | - , ToSchemaDoc (..) |
| 7 | + ( module Data.Schema.PrettyPrint.Internal.Algebra |
| 8 | + , module Data.Schema.PrettyPrint.Internal.Types |
13 | 9 | , putSchema |
14 | | - , SchemaLayout (..) |
15 | | - , ToSchemaLayout (..) |
| 10 | + , putSchema' |
16 | 11 | , prettyPrinter |
| 12 | + , prettyPrinter' |
17 | 13 | ) where |
18 | 14 |
|
19 | | -import Control.Applicative.Free |
20 | | -import Control.Functor.HigherOrder |
21 | | -import Control.Lens hiding (iso) |
22 | | -import Control.Monad.State (State) |
23 | | -import qualified Control.Monad.State as ST |
24 | | -import Control.Natural |
25 | | -import Data.Functor.Contravariant |
26 | | -import Data.Functor.Contravariant.Divisible |
27 | | -import Data.Functor.Sum |
28 | | -import qualified Data.HashMap.Strict as Map |
29 | | -import Data.List.NonEmpty (NonEmpty) |
30 | | -import qualified Data.List.NonEmpty as NEL |
31 | | -import Data.Maybe |
32 | | -import Data.Schema.Internal.Types |
33 | | -import Data.Text.Prettyprint.Doc ((<+>), (<>)) |
34 | | -import qualified Data.Text.Prettyprint.Doc as PP |
35 | | -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as PP |
36 | | -import qualified Data.Vector as Vector |
37 | 15 |
|
38 | | -type AnsiDoc = PP.Doc PP.AnsiStyle |
| 16 | +import Data.Schema.PrettyPrint.Internal.Algebra |
| 17 | +import Data.Schema.PrettyPrint.Internal.Types |
| 18 | +import qualified Prettyprinter.Render.Terminal as PP |
39 | 19 |
|
40 | | -indentAmount :: Int |
41 | | -indentAmount = 2 |
42 | | - |
43 | | -doubleColon :: AnsiDoc |
44 | | -doubleColon = PP.colon <> PP.colon |
45 | | - |
46 | | -layoutFields :: forall o s. (forall v. FieldDef o s v -> AnsiDoc) -> Fields s o -> AnsiDoc |
47 | | -layoutFields f fields = renderFields $ ST.execState (runAp fieldDoc $ unwrapField fields) [] |
48 | | - where fieldDoc :: FieldDef o s v -> State [AnsiDoc] v |
49 | | - fieldDoc fld = do |
50 | | - fieldDesc <- pure $ PP.pretty "*" <+> (PP.pretty $ fieldName fld) <+> (f fld) |
51 | | - ST.modify $ \xs -> fieldDesc:xs |
52 | | - return undefined |
53 | | - |
54 | | - renderFields :: [AnsiDoc] -> AnsiDoc |
55 | | - renderFields [] = PP.emptyDoc |
56 | | - renderFields xs = PP.nest indentAmount $ PP.line <> PP.vsep xs |
57 | | - |
58 | | -layoutAlts :: forall s o. (AltDef s o -> Maybe AnsiDoc) -> NonEmpty (AltDef s o) -> [AnsiDoc] |
59 | | -layoutAlts f alts = catMaybes . NEL.toList $ altDoc <$> alts |
60 | | - where altDoc :: AltDef s o -> Maybe AnsiDoc |
61 | | - altDoc a = (\x -> PP.indent indentAmount $ PP.pretty "-" <+> (PP.pretty $ altName a) <> x) <$> (f a) |
62 | | - |
63 | | -newtype SchemaDoc a = SchemaDoc { getDoc :: AnsiDoc } deriving Functor |
64 | | - |
65 | | -instance Applicative SchemaDoc where |
66 | | - pure _ = SchemaDoc $ PP.emptyDoc |
67 | | - (SchemaDoc l) <*> (SchemaDoc r) = SchemaDoc $ l <> r |
68 | | - |
69 | | -class ToSchemaDoc s where |
70 | | - toSchemaDoc :: s ~> SchemaDoc |
71 | | - |
72 | | -instance (ToSchemaDoc p, ToSchemaDoc q) => ToSchemaDoc (Sum p q) where |
73 | | - toSchemaDoc (InL l) = toSchemaDoc l |
74 | | - toSchemaDoc (InR r) = toSchemaDoc r |
75 | | - |
76 | | -toSchemaDocAlg :: ToSchemaDoc s => HAlgebra (SchemaF s) SchemaDoc |
77 | | -toSchemaDocAlg = wrapNT $ \case |
78 | | - PrimitiveSchema p -> SchemaDoc $ doubleColon <+> (getDoc $ toSchemaDoc p) |
79 | | - RecordSchema fields -> SchemaDoc $ layoutFields fieldDoc' fields |
80 | | - where fieldDoc' :: FieldDef o SchemaDoc v -> AnsiDoc |
81 | | - fieldDoc' (RequiredField _ schemaDoc _) = getDoc schemaDoc |
82 | | - fieldDoc' (OptionalField _ schemaDoc _) = PP.pretty "?" <> (getDoc schemaDoc) |
83 | | - UnionSchema alts -> SchemaDoc $ PP.vsep $ layoutAlts altDoc' alts |
84 | | - where altDoc' :: AltDef SchemaDoc a -> Maybe AnsiDoc |
85 | | - altDoc' (AltDef _ (SchemaDoc doc) _) = Just doc |
86 | | - AliasSchema baseDoc _ -> SchemaDoc $ getDoc baseDoc |
87 | | - |
88 | | -instance ToSchemaDoc s => ToSchemaDoc (Schema s) where |
89 | | - toSchemaDoc schema = (cataNT toSchemaDocAlg) (unwrapSchema schema) |
90 | 20 |
|
91 | 21 | -- | Renders the given schema to the standard out |
92 | | -putSchema :: ToSchemaDoc s => s a -> IO () |
93 | | -putSchema schema = do |
94 | | - PP.putDoc . getDoc $ toSchemaDoc schema |
| 22 | +putSchema :: ToSchemaDoc s => LayoutSettings -> s a -> IO () |
| 23 | +putSchema settings schema = do |
| 24 | + PP.putDoc . getDoc $ toSchemaDoc settings schema |
95 | 25 | putStrLn "" |
96 | 26 |
|
97 | | -newtype SchemaLayout a = SchemaLayout { runSchemaLayout :: a -> AnsiDoc } |
98 | | - |
99 | | -instance Contravariant SchemaLayout where |
100 | | - contramap f (SchemaLayout g) = SchemaLayout $ g . f |
101 | | - |
102 | | -instance Divisible SchemaLayout where |
103 | | - conquer = SchemaLayout $ const PP.emptyDoc |
104 | | - divide split leftLayout rightLayout = SchemaLayout $ \x -> |
105 | | - let (left, right) = split x |
106 | | - leftDoc = runSchemaLayout leftLayout left |
107 | | - rightDoc = runSchemaLayout rightLayout right |
108 | | - in leftDoc <+> PP.pretty "," <+> rightDoc |
109 | | - |
110 | | -class ToSchemaLayout s where |
111 | | - toSchemaLayout :: s ~> SchemaLayout |
112 | | - |
113 | | -instance (ToSchemaLayout p, ToSchemaLayout q) => ToSchemaLayout (Sum p q) where |
114 | | - toSchemaLayout (InL l) = toSchemaLayout l |
115 | | - toSchemaLayout (InR r) = toSchemaLayout r |
116 | | - |
117 | | -toSchemaLayoutAlg :: ToSchemaLayout s => HAlgebra (SchemaF s) SchemaLayout |
118 | | -toSchemaLayoutAlg = wrapNT $ \case |
119 | | - PrimitiveSchema p -> SchemaLayout $ \x -> PP.colon <+> runSchemaLayout (toSchemaLayout p) x |
120 | | - RecordSchema fields -> SchemaLayout $ \rc -> layoutFields (fieldDocOf rc) fields |
121 | | - where fieldDocOf :: o -> FieldDef o SchemaLayout v -> AnsiDoc |
122 | | - fieldDocOf obj (RequiredField _ (SchemaLayout layout) getter) = |
123 | | - let el = view getter obj |
124 | | - in layout el |
125 | | - fieldDocOf obj (OptionalField _ (SchemaLayout layout) getter) = |
126 | | - let el = view getter obj |
127 | | - in maybe (PP.pretty "Nothing") layout el |
128 | | - UnionSchema alts -> SchemaLayout $ \value -> head $ layoutAlts (layoutAlt' value) alts |
129 | | - where layoutAlt' :: o -> AltDef SchemaLayout o -> Maybe AnsiDoc |
130 | | - layoutAlt' obj (AltDef _ (SchemaLayout layout) getter) = layout <$> obj ^? getter |
131 | | - AliasSchema (SchemaLayout baseLayout) getter -> SchemaLayout $ \value -> baseLayout (view (re getter) value) |
132 | | - |
133 | | -instance ToSchemaLayout s => ToSchemaLayout (Schema s) where |
134 | | - toSchemaLayout schema = (cataNT toSchemaLayoutAlg) (unwrapSchema schema) |
| 27 | +putSchema' :: ToSchemaDoc s => s a -> IO () |
| 28 | +putSchema' = putSchema defaultLayoutSettings |
135 | 29 |
|
136 | 30 | -- | Generates a renderer of data types based on the given schema |
137 | | -prettyPrinter :: ToSchemaLayout s => s a -> (a -> IO ()) |
138 | | -prettyPrinter schema = \x -> do |
139 | | - PP.putDoc $ runSchemaLayout (toSchemaLayout schema) x |
| 31 | +prettyPrinter :: ToSchemaLayout s => LayoutSettings -> s a -> (a -> IO ()) |
| 32 | +prettyPrinter settings schema x = do |
| 33 | + PP.putDoc $ renderSchemaLayout (toSchemaLayout settings schema) x |
140 | 34 | putStrLn "" |
| 35 | + |
| 36 | +prettyPrinter' :: ToSchemaLayout s => s a -> (a -> IO ()) |
| 37 | +prettyPrinter' = prettyPrinter defaultLayoutSettings |
0 commit comments