module DerivingDrift.RuleUtils (
module Text.PrettyPrint.HughesPJ,
module DerivingDrift.RuleUtils,
module DerivingDrift.DataP
)where
import DerivingDrift.DataP
import Name.Name(getIdent)
import Text.PrettyPrint.HughesPJ
x = text "x"
f = text "f"
rArrow = text "->"
lArrow = text "<-"
blank = text "_"
semicolon = char ';'
texts :: [String] -> [Doc]
texts = map text
block, blockList,parenList,bracketList :: [Doc] -> Doc
block = nest 4 . vcat
blockList = braces . fcat . sepWith semi
parenList = parens . fcat . sepWith comma
bracketList = brackets . fcat . sepWith comma
sepWith :: a -> [a] -> [a]
sepWith _ [] = []
sepWith a [x] = [x]
sepWith a (x:xs) = x:a: sepWith a xs
opt :: [a] -> ([a] -> Doc) -> Doc
opt [] f = empty
opt a f = f a
opt1 :: [a] -> ([a] -> Doc) -> (a -> Doc) -> Doc
opt1 [] _ _ = empty
opt1 [x] _ g = g x
opt1 a f g = f a
commentLine x = text "--" <+> x
commentBlock x = text "{-" <> x <> text "-}"
simpleInstance :: Class -> Data -> Doc
simpleInstance s d = hsep [text "instance"
, opt constr (\x -> parenList x <+> text "=>")
, text s
, opt1 (texts (getIdent (name d) : vars d)) parenSpace id]
where
constr = map (\(c,v) -> text c <+> text v) (constraints d) ++
map (\x -> text s <+> text x) (vars d)
parenSpace = parens . hcat . sepWith space
type IFunction = Body -> Doc
instanceSkeleton :: Class -> [(IFunction,Doc)] -> Data -> Doc
instanceSkeleton s ii d = (simpleInstance s d <+> text "where")
$$ block functions
where
functions = concatMap f ii
f (i,dflt) = map i (body d) ++ [dflt]
varNames :: [a] -> [Doc]
varNames l = take (length l) names
where names = [text [x,y] | x <- ['a' .. 'z'],
y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
varNames' :: [a] -> [Doc]
varNames' = map (<> (char '\'')) . varNames
pattern :: Constructor -> [a] -> Doc
pattern c l = parens $ fsep (text c : varNames l)
pattern_ :: Constructor -> [a] -> Doc
pattern_ c l = parens $ fsep (text c : replicate (length l) (text "_"))
pattern' :: Constructor -> [a] -> Doc
pattern' c l = parens $ fsep (text c : varNames' l)
hasRecord :: Data -> Bool
hasRecord d = statement d == DataStmt
&& any (not . null . labels) (body d)
tuple :: [Doc] -> Doc
tuple xs = parens $ hcat (punctuate (char ',') xs)