module DrIFT.Perl6Class where
import Data.Typeable
import Data.List
import Data.Word
import qualified Data.Map as Map
import Text.PrettyPrint.HughesPJ
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
showPerl6RoleDef, showMooseRoleDef
:: NamespaceMangler -> String -> String
showPerl6RoleDef ns name = render $
hsep $ map text ["role", ns name, "is TaggedUnion;"]
showMooseRoleDef ns name = render $
vcat [ text "package" <+> (text $ ns name) <> semi
, text "use Moose::Role;"
, text ""
, text "with 'TaggedUnion';"
, text ""
]
showPerl6ClassDef, showMooseClassDef
:: NamespaceMangler
-> String
-> String
-> [(String, String, String)]
-> String
showPerl6ClassDef ns role cls members = render $
catF [clsHead, mem, clsTail]
where
mem = nest 4 $ vcat $ map memberDef members
catF | null members = cat
| otherwise = vcat
clsHead = hsep $ map text ["class", ns cls, "does", ns role, "{"]
clsTail = rbrace <> semi
memberDef (ty, nm, ann) = hsep [text "has", ty' ty, nm' nm] <> semi <+> annComment ann
ty' x = if null x then empty else text x
nm' (_:'_':n) = text n
nm' n = text n
annComment x = if null x then empty else text "#" <+> text x
showMooseClassDef ns role cls members = render $
clsHead $+$ mem $+$ text ""
where
mem = vcat $ map memberDef members
clsHead = vcat
[ text "package" <+> (text $ ns cls) <> semi
, text "use Moose;"
, text ""
, text "extends" <+> quotes (text $ ns role) <> semi
, text ""
]
memberDef (ty, nm, ann) = hsep [text "has", nm' nm, text "=>"] <+>
(parens $ hsep [text "is 'rw',", ty' ty]) <> semi <+> annComment ann
ty' x = if null x then empty else text "isa =>" <+> (quotes $ text x)
nm' (_:'_':n) = qt n
nm' n = qt n
annComment x = if null x then empty else text "#" <+> text x
qt :: String -> Doc
qt = doubleQuotes . text
type NamespaceMangler = String -> String
class Typeable a => MooseClass a where
showMooseTypeDef :: NamespaceMangler -> a -> String
showMooseTypeDef _ ty = error $ "showMooseTypeDef " ++ (show $ typeOf ty)
class PLit a => Perl6Class a where
showPerl6TypeDef :: NamespaceMangler -> a -> String
showPerl6TypeDef _ ty = error $ "showPerl6TypeDef " ++ (show $ typeOf ty)
asPerl6Object :: a -> String
asPerl6Object simple = "new " ++ (show $ typeOf simple)
instance Perl6Class a => Perl6Class [a] where
showPerl6TypeDef _ ty = error $ "showPerl6TypeDef " ++ (show $ typeOf ty)
asPerl6Object xs = (show $ typeOf xs) ++ ".new(" ++ (concat $ intersperse ", " $ map asPerl6Object xs) ++ ")"
instance (Perl6Class a, Perl6Class b, PLit a, PLit b, PLit (Map.Map a b)) => (Perl6Class (Map.Map a b)) where
asPerl6Object h = render $ cat $ qbraces $ map showKV $ Map.assocs h
showKV :: (PLit a, PLit b) => (a, b) -> Doc
showKV (k, v) = ts k <+> qt "=>" <+> ts v
ts :: PLit a => a -> Doc
ts = text . show . plShow
qbraces :: [Doc] -> [Doc]
qbraces ls = doubleQuotes lbrace : ls ++ [doubleQuotes rbrace]
class (Typeable a, Show a) => PLit a where
plShow :: a -> String
plShow = show
instance Perl6Class Int
instance Perl6Class Rational
instance Perl6Class Float
instance Perl6Class Word
instance MooseClass Int
instance MooseClass Rational
instance MooseClass Float
instance MooseClass Word
instance PLit String where
plShow = render . cat . showStringLiteral
instance PLit S.ByteString where
plShow = render . cat . showSLiteral
instance PLit L.ByteString where
plShow = render . cat . showLLiteral
instance PLit a => PLit [a] where
plShow x = "[" ++ (concat $ intersperse ", " $ map plShow x) ++ "]"
instance PLit a => PLit (Maybe a) where
plShow Nothing = "undef"
plShow (Just x) = plShow x
instance (Typeable a, Show a) => PLit a where
plShow = show
showStringLiteral :: String -> [Doc]
showStringLiteral str =
intersperse catter $ map slQuote $ strQuoteSplit [] "" str
where
catter = text "~ \"'\" ~"
strQuoteSplit :: [String] -> String -> String -> [String]
strQuoteSplit qa sa "" = qa ++ [sa]
strQuoteSplit qa sa ('\'':xs) = strQuoteSplit (qa ++ [sa]) "" xs
strQuoteSplit qa sa (x:xs) = strQuoteSplit qa (sa++[x]) xs
slQuote str' = text "qn'" <> text str' <> text "'"
showSLiteral :: S.ByteString -> [Doc]
showSLiteral str =
intersperse catter $ map slQuote $ S.split '\'' str
where
catter = text "~ \"'\" ~"
slQuote str' = text "qn'" <> text (S.unpack str') <> text "'"
showLLiteral :: L.ByteString -> [Doc]
showLLiteral str =
intersperse catter $ map slQuote $ L.split '\'' str
where
catter = text "~ \"'\" ~"
slQuote str' = text "qn'" <> text (L.unpack str') <> text "'"