diff options
author | Greg Brown <greg.brown01@ed.ac.uk> | 2024-09-17 17:09:41 +0100 |
---|---|---|
committer | Greg Brown <greg.brown01@ed.ac.uk> | 2024-09-17 17:09:41 +0100 |
commit | 974717f0aa46bb295d44e239594b38f63f39ceab (patch) | |
tree | 73eaa9501f4c79328d98bf5257529d8495f6c756 /src/Inky/Type | |
parent | b2d6c85d420992270c37eba055cdc3952985c70e (diff) |
Introduce names in contexts.
Introduce rows for n-ary sums and products.
Remove union types.
Diffstat (limited to 'src/Inky/Type')
-rw-r--r-- | src/Inky/Type/Pretty.idr | 70 |
1 files changed, 20 insertions, 50 deletions
diff --git a/src/Inky/Type/Pretty.idr b/src/Inky/Type/Pretty.idr index 074d86e..1f2d35b 100644 --- a/src/Inky/Type/Pretty.idr +++ b/src/Inky/Type/Pretty.idr @@ -1,73 +1,43 @@ module Inky.Type.Pretty -import Data.Fin -import Data.Fin.Extra -import Data.List -import Data.String +import Inky.Context import Inky.Type import Text.PrettyPrint.Prettyprinter -asTyChar : Fin 6 -> Char -asTyChar = index' ['X', 'Y', 'Z', 'A', 'B', 'C'] - -export -typeName : Nat -> String -typeName n with (divMod n 6) - typeName _ | Fraction _ 6 q r Refl = - strSnoc - (if q == 0 then "'" else assert_total (typeName $ pred q)) - (asTyChar r) - -arrowPrec, unionPrec, prodPrec, sumPrec, fixPrec : Prec +arrowPrec, prodPrec, sumPrec, fixPrec : Prec arrowPrec = Open -unionPrec = User 2 prodPrec = Open -sumPrec = User 1 +sumPrec = Open fixPrec = Open export -prettyType : {ty : Nat} -> Ty ty -> Prec -> Doc ann -prettyTypeAll : {ty : Nat} -> List (Ty ty) -> Prec -> List (Doc ann) -prettyTypeAll1 : {ty : Nat} -> List1 (Ty ty) -> Prec -> List (Doc ann) +prettyType : {ctx : Context ()} -> Ty ctx () -> Prec -> Doc ann +prettyTypeRow : {ctx : Context ()} -> Row (Ty ctx ()) -> Prec -> List (Doc ann) -prettyType (TVar i) d = pretty (typeName $ finToNat i) +prettyType (TVar i) d = pretty (unVal $ nameOf i) prettyType TNat d = pretty "Nat" prettyType (TArrow a b) d = parenthesise (d > arrowPrec) $ group $ align $ hang 2 $ let parts = stripArrow b in - concatWith (\x, y => x <++> "->" <+> line <+> y) (prettyType a arrowPrec :: parts) + concatWith (surround $ "->" <+> line) (prettyType a arrowPrec :: parts) where - stripArrow : Ty ty -> List (Doc ann) + stripArrow : Ty ctx () -> List (Doc ann) stripArrow (TArrow a b) = prettyType a arrowPrec :: stripArrow b stripArrow a = [prettyType a arrowPrec] -prettyType (TUnion (a ::: [])) d = - parens $ group $ align $ hang 2 $ - prettyType a unionPrec <++> "&" -prettyType (TUnion as) d = - parenthesise (d >= unionPrec) $ group $ align $ hang 2 $ - let parts = prettyTypeAll1 as unionPrec in - concatWith (\x, y => x <++> "&" <+> line <+> y) parts -prettyType (TProd [a]) d = - parens $ group $ align $ hang 2 $ - prettyType a prodPrec <++> "," prettyType (TProd as) d = - parens $ group $ align $ hang 2 $ - let parts = prettyTypeAll as prodPrec in - concatWith (\x, y => x <++> "," <+> line <+> y) parts -prettyType (TSum []) d = "(+)" -prettyType (TSum [a]) d = - parens $ group $ align $ hang 2 $ - prettyType a sumPrec <++> "+" + enclose "<" ">" $ group $ align $ hang 2 $ + let parts = prettyTypeRow as prodPrec in + concatWith (surround $ "," <+> line) parts prettyType (TSum as) d = - parenthesise (d >= sumPrec) $ group $ align $ hang 2 $ - let parts = prettyTypeAll as sumPrec in - concatWith (\x, y => x <++> "+" <+> line <+> y) parts -prettyType (TFix a) d = + enclose "[" "]" $ group $ align $ hang 2 $ + let parts = prettyTypeRow as prodPrec in + concatWith (surround $ "," <+> line) parts +prettyType (TFix x a) d = parens $ group $ align $ hang 2 $ - "\\" <+> pretty (typeName ty) <++> "=>" <+> line <+> + "\\" <+> pretty x <++> "=>" <+> line <+> prettyType a fixPrec -prettyTypeAll [] d = [] -prettyTypeAll (a :: as) d = prettyType a d :: prettyTypeAll as d - -prettyTypeAll1 (a ::: as) d = prettyType a d :: prettyTypeAll as d +prettyTypeRow [<] d = [] +prettyTypeRow (as :< (x :- a)) d = + (group $ align $ hang 2 $ pretty x <+> ":" <+> line <+> prettyType a d) + :: prettyTypeRow as d |