-- utilities for writing new rules.

module RuleUtils where

import Text.PrettyPrint.HughesPJ

import DataP (Statement(..), Data(..), Type(..), Class,

Body(..), Constructor)

-- Rule Declarations

type Tag = String

type Rule = (Tag, Data -> Doc)

type RuleDef = (Tag, Data -> Doc, String, String, Maybe String)

rArrow :: Doc

rArrow = text "->"

lArrow :: Doc

lArrow = text "<-"

prettyType :: Type -> Doc

prettyType (Arrow x y) = parens (prettyType x <+> text "->" <+> prettyType y)

prettyType (List x) = brackets (prettyType x)

prettyType (Tuple xs) = tuple (map prettyType xs)

prettyType (Var s) = text s

prettyType (Con s) = text s

prettyType (LApply t ts) = prettyType t <+> hsep (map prettyType ts)

-- New Pretty Printers ---------------

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

-- for bulding m1 >> m2 >> m3, f . g . h, etc

sepWith :: a -> [a] -> [a]

sepWith _ [] = []

sepWith _ [x] = [x]

sepWith a (x:xs) = x:a: sepWith a xs

--optional combinator, applys fn if arg is non-[]

opt :: [a] -> ([a] -> Doc) -> Doc

opt [] _ = empty

opt a f = f a

--equivalent of `opt' for singleton lists

opt1 :: [a] -> ([a] -> Doc) -> (a -> Doc) -> Doc

opt1 [] _ _ = empty

opt1 [x] _ g = g x

opt1 a f _ = f a

-- new simple docs

commentLine :: Doc -> Doc

commentLine x = text "--" <+> x -- useful for warnings / error messages

commentBlock :: Doc -> Doc

commentBlock x = text "{-" <+> x <+> text "-}"

--- Utility Functions -------------------------------------------------------

-- Instances

strippedName :: Data -> [Char]

strippedName = reverse . takeWhile (/= '.') . reverse . name

-- instance header, handling class constraints etc.

simpleInstance :: Class -> Data -> Doc

simpleInstance s d = hsep [text "instance"

, opt1 constr (\ x -> parenList x <+> text "=>")

( \ x -> x <+> text "=>")

, text s

, opt1 (texts (strippedName 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

-- instanceSkeleton handles most instance declarations, where instance

-- functions are not related to one another. A member function is generated

-- using a (IFunction,Doc) pair. The IFunction is applied to each body of the

-- type, creating a block of pattern - matching cases. Default cases can be

-- given using the Doc in the pair. If a default case is not required, set

-- Doc to 'empty'

type IFunction = Body -> Doc -- instance function

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]

-- little variable name generator, generates unique names a - z

varNames :: [a] -> [Doc]

varNames l = zipWith (const char) l ['a' .. 'z']

-- variant generating aa' - aZ'

varNames' :: [a] -> [Doc]

varNames' = map (<> (char '\'')) . varNames

-- pattern matching a constructor and args

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)

-- test that a datatype has at least one record constructor

hasRecord :: Data -> Bool

hasRecord d = statement d == DataStmt

&& any (not . null . labels) (body d)

tuple :: [Doc] -> Doc

tuple xs = parens $ hcat (punctuate (char ',') xs)