module Elm.Print.Types
( prettyShowDefinition
, elmAliasDoc
, elmTypeDoc
) where
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Doc, align, colon, comma, dquotes, emptyDoc, equals, lbrace, line,
lparen, nest, parens, pipe, pretty, prettyList, rbrace, rparen,
sep, space, vsep, (<+>))
import Elm.Ast (ElmAlias (..), ElmConstructor (..), ElmDefinition (..), ElmPrim (..),
ElmRecordField (..), ElmType (..), TypeName (..), TypeRef (..), getConstructorNames,
isEnum)
import Elm.Print.Common (arrow, showDoc, typeWithVarsDoc, wrapParens)
import qualified Data.List.NonEmpty as NE
prettyShowDefinition :: ElmDefinition -> Text
prettyShowDefinition = showDoc . elmDoc
elmDoc :: ElmDefinition -> Doc ann
elmDoc = \case
DefAlias elmAlias -> elmAliasDoc elmAlias
DefType elmType -> elmTypeDoc elmType
DefPrim _ -> emptyDoc
elmTypeRefDoc :: TypeRef -> Doc ann
elmTypeRefDoc = \case
RefPrim elmPrim -> elmPrimDoc elmPrim
RefCustom (TypeName typeName) -> pretty typeName
elmPrimDoc :: ElmPrim -> Doc ann
elmPrimDoc = \case
ElmUnit -> "()"
ElmNever -> "Never"
ElmBool -> "Bool"
ElmChar -> "Char"
ElmInt -> "Int"
ElmFloat -> "Float"
ElmString -> "String"
ElmTime -> "Posix"
ElmMaybe t -> "Maybe" <+> elmTypeParenDoc t
ElmResult l r -> "Result" <+> elmTypeParenDoc l <+> elmTypeParenDoc r
ElmPair a b -> lparen <> elmTypeRefDoc a <> comma <+> elmTypeRefDoc b <> rparen
ElmTriple a b c -> lparen <> elmTypeRefDoc a <> comma <+> elmTypeRefDoc b <> comma <+> elmTypeRefDoc c <> rparen
ElmList l -> "List" <+> elmTypeParenDoc l
elmTypeParenDoc :: TypeRef -> Doc ann
elmTypeParenDoc = wrapParens . elmTypeRefDoc
elmAliasDoc :: ElmAlias -> Doc ann
elmAliasDoc ElmAlias{..} = nest 4 $
vsep $ ("type alias" <+> pretty elmAliasName <+> equals)
: fieldsDoc elmAliasFields
where
fieldsDoc :: NonEmpty ElmRecordField -> [Doc ann]
fieldsDoc (fstR :| rest) =
lbrace <+> recordFieldDoc fstR
: map ((comma <+>) . recordFieldDoc) rest
++ [rbrace]
recordFieldDoc :: ElmRecordField -> Doc ann
recordFieldDoc ElmRecordField{..} =
pretty elmRecordFieldName
<+> colon
<+> elmTypeRefDoc elmRecordFieldType
elmTypeDoc :: ElmType -> Doc ann
elmTypeDoc t@ElmType{..} =
nest 4 ( vsep $ ("type" <+> pretty elmTypeName <> sepVars)
: constructorsDoc elmTypeConstructors
)
<> unFunc
<> enumFuncs
where
sepVars :: Doc ann
sepVars = case elmTypeVars of
[] -> emptyDoc
vars -> space <> sep (map pretty vars)
constructorsDoc :: NonEmpty ElmConstructor -> [Doc ann]
constructorsDoc (fstC :| rest) =
equals <+> constructorDoc fstC
: map ((pipe <+>) . constructorDoc) rest
constructorDoc :: ElmConstructor -> Doc ann
constructorDoc ElmConstructor{..} = sep $
pretty elmConstructorName : map elmTypeRefDoc elmConstructorFields
unFunc :: Doc ann
unFunc =
if elmTypeIsNewtype
then line <> elmUnFuncDoc t
else emptyDoc
enumFuncs :: Doc ann
enumFuncs =
if isEnum t
then vsep $ map (line <>) [elmEnumShowDoc t, elmEnumReadDoc t, elmEnumUniverse t]
else emptyDoc
elmUnFuncDoc :: ElmType -> Doc ann
elmUnFuncDoc ElmType{..} = line <> vsep
[ unName <+> colon <+> typeWithVarsDoc elmTypeName elmTypeVars <+> arrow <+> result
, unName <+> parens (ctorName <+> "x") <+> equals <+> "x"
]
where
unName :: Doc ann
unName = "un" <> pretty elmTypeName
ctor :: ElmConstructor
ctor = NE.head elmTypeConstructors
result :: Doc ann
result = case elmConstructorFields ctor of
[] -> "ERROR"
fld : _ -> elmTypeRefDoc fld
ctorName :: Doc ann
ctorName = pretty $ elmConstructorName ctor
elmEnumShowDoc :: forall ann . ElmType -> Doc ann
elmEnumShowDoc t@ElmType{..} =
line
<> (showName <+> colon <+> pretty elmTypeName <+> arrow <+> "String")
<> line
<> nest 4
( vsep $ (showName <+> "x" <+> equals <+> "case x of")
: map patternMatch (getConstructorNames t)
)
where
showName :: Doc ann
showName = "show" <> pretty elmTypeName
patternMatch :: Text -> Doc ann
patternMatch (pretty -> c) = c <+> arrow <+> dquotes c
elmEnumReadDoc :: ElmType -> Doc ann
elmEnumReadDoc t@ElmType{..} =
(readName <+> colon <+> "String" <+> arrow <+> "Maybe" <+> pretty elmTypeName)
<> line
<> nest 4
( vsep $ (readName <+> "x" <+> equals <+> "case x of")
: map patternMatch (getConstructorNames t)
++ ["_" <+> arrow <+> "Nothing"]
)
where
readName :: Doc ann
readName = "read" <> pretty elmTypeName
patternMatch :: Text -> Doc ann
patternMatch (pretty -> c) = dquotes c <+> arrow <+> "Just" <+> c
elmEnumUniverse :: ElmType -> Doc ann
elmEnumUniverse t@ElmType{..} = vsep
[ universeName <+> colon <+> "List" <+> pretty elmTypeName
, universeName <+> equals <+> align (prettyList $ getConstructorNames t)
]
where
universeName :: Doc ann
universeName = "universe" <> pretty elmTypeName