content: 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 "<-"
  --equals = 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
  
  -- for bulding m1 >> m2 >> m3, f . g . h, etc
  sepWith :: a -> [a] -> [a]
  sepWith _ [] = []
  sepWith a [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 [] f = 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 g = f a
  
  -- new simple docs
  commentLine x = text "--" <+> x -- useful for warnings / error messages
  commentBlock x = text "{-" <> x <> text "-}"
  
  --- Utility Functions -------------------------------------------------------
  
  -- Instances
  
  -- instance header, handling class constraints etc.
  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
  
  -- 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 (length l) unique names aa - aZ
  varNames :: [a] -> [Doc]
  varNames l = take (length l) names
     where names = [text [x,y] | x <- ['a' .. 'z'],
                                 y <- ['a' .. 'z'] ++ ['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)
  