Created
June 21, 2016 07:24
-
-
Save adinapoli/fc40cc6bd972ede5f7442494d33556b8 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE DataKinds #-} | |
module Data.API.Tools.PureScript.Pretty where | |
import Data.String.Conv | |
import qualified Data.Text as T | |
import qualified Language.PureScript.AST.Declarations as PS | |
import qualified Language.PureScript.Environment as PS | |
import qualified Language.PureScript.Kinds as PS | |
import qualified Language.PureScript.Names as PS | |
import qualified Language.PureScript.Pretty as PS | |
import qualified Language.PureScript.Pretty.Types as PS | |
import qualified Language.PureScript.Types as PS | |
import Text.PrettyPrint.Boxes as Box | |
-------------------------------------------------------------------------------- | |
-- | Pretty-print only a subset of a `Declaration`, useful to pretty print the | |
-- subset of the AST we are interested in. | |
prettyPrintDeclaration :: PS.Declaration -> Box | |
prettyPrintDeclaration (PS.DataDeclaration dt tn typeParams decl) = | |
dataDeclTypeAsBox dt <> text " " | |
<> text (PS.runProperName tn) | |
<> typeParamsAsBox typeParams | |
<+> typeDeclAsBox decl | |
prettyPrintDeclaration (PS.TypeSynonymDeclaration tn typeParams aliasType) = | |
text "type " <> text (PS.runProperName tn) | |
<> typeParamsAsBox typeParams | |
<> text " = " | |
<> PS.typeAsBox aliasType | |
prettyPrintDeclaration (PS.TypeInstanceDeclaration (PS.Ident ident) _ className [theType] PS.DerivedInstance) = | |
text "derive instance" <+> text ident <+> "::" <+> text (PS.runProperName (PS.disqualify className)) <+> PS.typeAsBox theType | |
prettyPrintDeclaration (PS.TypeInstanceDeclaration (PS.Ident ident) _ className [theType] (PS.ExplicitInstance [decl])) = | |
Box.vsep 0 Box.top [ text "instance" <+> text ident <+> "::" <+> text (PS.runProperName (PS.disqualify className)) <+> PS.typeAsBox theType <+> "where" | |
, text " " <+> prettyPrintDeclaration decl | |
] | |
prettyPrintDeclaration (PS.ValueDeclaration ident _ [] (Right val)) = | |
text (PS.showIdent ident ++ " = ") <> PS.prettyPrintValue maxBound val | |
prettyPrintDeclaration _ = error "Unsupported, sorry." | |
-------------------------------------------------------------------------------- | |
typeParamsAsBox :: [(String, Maybe PS.Kind)] -> Box | |
typeParamsAsBox = text . toS . T.intercalate " " . map (toS . fst) | |
-------------------------------------------------------------------------------- | |
dataDeclTypeAsBox :: PS.DataDeclType -> Box | |
dataDeclTypeAsBox = text . PS.showDataDeclType | |
-------------------------------------------------------------------------------- | |
typeDeclAsBox :: [(PS.ProperName 'PS.ConstructorName, [PS.Type])] -> Box | |
typeDeclAsBox [] = text "" | |
typeDeclAsBox (x:xs) = Box.vsep 0 Box.top ((text "=" <+> toBox x) : map (\v -> text "|" <+> toBox v) xs) | |
where | |
toBox :: (PS.ProperName 'PS.ConstructorName, [PS.Type]) -> Box | |
toBox (cn, types) = | |
let ctor = text (PS.runProperName cn) | |
in case types of | |
[] -> ctor | |
l -> ctor <+> Box.vsep 4 Box.top (map recordAsBox l) | |
-------------------------------------------------------------------------------- | |
-- | Exploit the native PureScript `typeAsBox`, but with some extra changes to | |
-- ensure we display record brackets. | |
recordAsBox :: PS.Type -> Box | |
recordAsBox (PS.TypeApp _ t@PS.RCons{}) = | |
let (fields, _) = PS.rowToList t | |
in Box.vsep 0 Box.top (text "{" : mapped fields) | |
where | |
mapped f = case f of | |
[] -> [text "}"] | |
(fn,ty):xs -> (text " " <> text fn <+> text "::" <+> PS.typeAsBox ty) : go xs | |
go [] = [text "}"] | |
go ((fn,ty):xs) = (text "," <+> text fn <+> text "::" <+> PS.typeAsBox ty) : go xs | |
recordAsBox t = PS.typeAsBox t |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment