module Infernu.Pretty where
import Infernu.Types
import Data.Char (chr, ord)
import qualified Data.Char as Char
import qualified Data.Digits as Digits
import Data.List (intercalate)
import qualified Data.Map.Lazy as Map
import qualified Data.Graph.Inductive as Graph
import qualified Data.Set as Set
import qualified Text.Parsec.Pos as Pos
tab :: Int -> String
tab t = replicate (t*4) ' '
class Pretty a where
prettyTab :: Int -> a -> String
instance Pretty a => Pretty (Maybe a) where
prettyTab _ x = maybe "Nothing" pretty x
instance (Pretty a, Pretty b) => Pretty (a,b) where
prettyTab _ (a,b) = "(" ++ pretty a ++ ", " ++ pretty b ++ ")"
instance (Pretty a, Pretty b, Pretty c) => Pretty (a,b,c) where
prettyTab _ (a,b,c) = "(" ++ pretty a ++ ", " ++ pretty b ++ ", " ++ pretty c ++ ")"
prettyList :: Pretty a => [a] -> String
prettyList [] = "[]"
prettyList xs = "[" ++ intercalate "," (map pretty xs) ++ "]"
instance Pretty [String] where
prettyTab _ = prettyList
instance Pretty [Type] where
prettyTab _ = prettyList
instance (Pretty a, Pretty b) => Pretty [(a,b)] where
prettyTab _ xs = "[" ++ intercalate "," (map pretty xs) ++ "]"
pretty :: Pretty a => a -> String
pretty = prettyTab 0
instance Pretty Source where
prettyTab _ (Source (genInfo, pos)) = pretty pos ++ (if isGen genInfo then "*" else "") ++ (maybe "" (\x -> pretty x ++ " : ") $ declName genInfo)
instance Pretty LitVal where
prettyTab _ (LitNumber x) = show x
prettyTab _ (LitBoolean x) = show x
prettyTab _ (LitString x) = show x
prettyTab _ (LitRegex x g i) = "/" ++ x ++ "/" ++ (if g then "g" else "") ++ (if i then "i" else "") ++ (if g || i then "/" else "")
prettyTab _ LitUndefined = "undefined"
prettyTab _ LitNull = "null"
instance Pretty EVarName where
prettyTab _ x = x
nakedSingleOrTuple :: [String] -> String
nakedSingleOrTuple [] = "()"
nakedSingleOrTuple [x] = x
nakedSingleOrTuple xs = "(" ++ intercalate ", " xs ++ ")"
instance Pretty (Exp a) where
prettyTab t (EVar _ n) = prettyTab t n
prettyTab t (EApp _ e1 args) = "(" ++ prettyTab t e1 ++ " " ++ nakedSingleOrTuple (map (prettyTab t) args) ++")"
prettyTab t (EAbs _ args e) = "(\\" ++ nakedSingleOrTuple (map (prettyTab t) args) ++ " -> " ++ prettyTab (t+1) e ++ ")"
prettyTab t (ELet _ n e1 e2) = "\n" ++ tab t ++ "let " ++ letLine n e1 e2
where letLine n' e' eBody = prettyTab t n'
++ " = "
++ prettyTab (t+1) e'
++ "\n" ++ tab (t+1)
++ case eBody of
(ELet _ nb e1b e2b) -> letLine nb e1b e2b
_ -> pretty " in " ++ prettyTab (t+1) eBody
prettyTab t (ELit _ l) = prettyTab t l
prettyTab t (EAssign _ n e1 e2) = prettyTab t n ++ " := " ++ prettyTab t e1 ++ ";\n" ++ tab (t+1) ++ prettyTab (t+1) e2
prettyTab t (EPropAssign _ obj n e1 e2) = prettyTab t obj ++ "." ++ prettyTab t n ++ " := " ++ prettyTab t e1 ++ ";\n" ++ tab (t+1) ++ prettyTab (t+1) e2
prettyTab t (EIndexAssign _ obj i e1 e2) = prettyTab t obj ++ "[" ++ prettyTab t i ++ "] := " ++ prettyTab t e1 ++ ";\n" ++ tab (t+1) ++ prettyTab (t+1) e2
prettyTab t (EArray _ es) = "[" ++ intercalate ", " (map (prettyTab t) es) ++ "]"
prettyTab t (ETuple _ es) = "(" ++ intercalate ", " (map (prettyTab t) es) ++ ")"
prettyTab t (ERow _ isOpen props) = "{" ++ intercalate ", " (map (\(n,v) -> prettyTab t n ++ ": " ++ prettyTab t v) props) ++ (if isOpen then ", " else "") ++ "}"
prettyTab t (ECase _ ep es) = "case " ++ prettyTab t ep ++ " of\n" ++ (concatMap formatBranch' es)
where formatBranch' (pat, branch) = tab (t+1)
++ prettyTab (t+1) pat
++ " -> "
++ prettyTab (t+1) branch
prettyTab t (EProp _ e n) = prettyTab t e ++ "." ++ pretty n
prettyTab t (EIndex _ e1 e2) = prettyTab t e1 ++ "[" ++ prettyTab t e2 ++ "]"
prettyTab t (ENew _ e args) = "new " ++ prettyTab t e ++ " " ++ nakedSingleOrTuple (map (prettyTab t) args)
prettyTab t (EStringMap _ exprs) = "<" ++ intercalate ", " (map (\(n,v) -> prettyTab t n ++ " => " ++ prettyTab t v) exprs) ++ ">"
toChr :: Int -> Char
toChr n = chr (ord 'a' + (n 1))
instance Pretty TVarName where
prettyTab _ n = foldr ((++) . (:[]) . toChr) [] (Digits.digits 26 (n + 1))
instance Pretty Bool where
prettyTab _ x = show x
instance Pretty TypeId where
prettyTab _ (TypeId n) = capitalize $ pretty n
where capitalize [] = []
capitalize (x:xs) = Char.toUpper x : xs
instance Pretty TBody where
prettyTab t (TVar n) = prettyTab t n
prettyTab _ x = case show x of
'T':xs -> xs
xs -> xs
instance Pretty TConsName where
prettyTab _ = show
instance Pretty RowTVar where
prettyTab _ t = ".." ++ pretty (getRowTVar t)
instance Pretty Type where
prettyTab x = prettyType x . unFix
instance Pretty (FType Type) where
prettyTab = prettyType
prettyType :: Int -> FType Type -> String
prettyType n (TBody t) = prettyTab n t
prettyType n (TFunc ts tres) = wrapThis this $ "(" ++ args ++ " -> " ++ prettyTab n tres ++ ")"
where nonThisArgs = map (prettyTab n) . drop 1 $ ts
(this, args) = case ts of
[] -> (Nothing, nakedSingleOrTuple nonThisArgs)
(this_:_) -> (Just this_, nakedSingleOrTuple nonThisArgs)
wrapThis Nothing s = s
wrapThis (Just (Fix (TBody TUndefined))) s = s
wrapThis (Just t) s = prettyTab n t ++ "." ++ s
prettyType n (TCons TArray [t]) = "[" ++ prettyTab n t ++ "]"
prettyType n (TCons TArray ts) = error $ "Malformed TArray: " ++ intercalate ", " (map (prettyTab n) ts)
prettyType n (TCons TTuple ts) = "(" ++ intercalate ", " (map (prettyTab n) ts) ++ ")"
prettyType _ (TCons (TName name) _) = "<" ++ pretty name ++ ">"
prettyType n (TCons TStringMap [t]) = "Map " ++ prettyTab n t
prettyType n (TCons TStringMap ts) = error $ "Malformed TStringMap: " ++ intercalate ", " (map (prettyTab n) ts)
prettyType t (TRow list) = "{"
++ body'
++ (case r of
FlatRowEndTVar r' -> maybe "" ((", "++) . pretty) r'
FlatRowEndRec tid ts -> ", " ++ prettyTab (t+1) (Fix $ TCons (TName tid) ts)
)
++ "}"
where (props, r) = flattenRow list
printProp' = (\(n,v) -> prettyTab (t+1) n ++ ": " ++ prettyTab (t+1) v)
body' = case Map.toList props of
[] -> ""
[p] -> printProp' p
ps -> "\n" ++ tab (t+1) ++ intercalate (",\n" ++ tab (t+1)) (map printProp' ps) ++ "\n" ++ tab t
instance Pretty ClassName where
prettyTab _ (ClassName c) = c
instance (Pretty t) => Pretty (TPred t) where
prettyTab _ (TPredIsIn cn t) = pretty cn ++ " " ++ pretty t
instance (Pretty t) => Pretty [TPred t] where
prettyTab n p = intercalate ", " $ map (prettyTab n) p
instance (VarNames t, Pretty t) => Pretty (TQual t) where
prettyTab n (TQual [] t) = prettyTab n t
prettyTab n (TQual preds t) = prettyTab n preds ++ " => " ++ prettyTab n t
instance (Ord t, VarNames t, Pretty t) => Pretty (TScheme t) where
prettyTab n (TScheme vars t) = forall ++ prettyTab n t
where forall = if null vars then "" else "forall " ++ unwords (map (prettyTab n) vars) ++ ". "
instance (Pretty a, Pretty b) => Pretty (Either a b) where
prettyTab n (Left x) = "Error: " ++ prettyTab n x
prettyTab n (Right x) = prettyTab n x
instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where
prettyTab n s = "Map (" ++ str' ++ ")"
where str' = intercalate ", " . map (\(k,v) -> prettyTab n k ++ " => " ++ prettyTab n v) . Map.toList $ s
instance (Pretty k) => Pretty (Set.Set k) where
prettyTab n s = "Set {" ++ str' ++ "}"
where str' = intercalate ", " . map (prettyTab n) . Set.toList $ s
instance Pretty Pos.SourcePos where
prettyTab _ p = Pos.sourceName p ++ ":" ++ show (Pos.sourceLine p) ++ ":" ++ show (Pos.sourceColumn p)
instance Pretty GenInfo where
prettyTab _ g = show g
instance Pretty TypeError where
prettyTab t (TypeError s m) = prettyTab t s ++ ": Error: " ++ prettyTab (t+1) m
instance Pretty NameSource where
prettyTab _ = show
instance Pretty VarId where
prettyTab _ = show
instance (Ord t, VarNames t, Pretty t) => Pretty (Class t) where
prettyTab n c = "{ instances = [" ++ s' ++ "] }"
where s' = intercalate ", " . map (prettyTab n) $ classInstances c
instance (Show a, Show b) => Pretty (Graph.Gr a b) where
prettyTab _ = Graph.prettify
instance Pretty InferState where
prettyTab t (InferState ns sub vs vi tn cs pu) = "InferState { nameSource: "
++ pretty ns ++ newline
++ ", subst: " ++ pretty sub ++ newline
++ ", varSchemes: " ++ pretty vs ++ newline
++ ", varInstances: " ++ pretty vi ++ newline
++ ", namedTypes: " ++ pretty tn ++ newline
++ ", pendingUni: " ++ pretty pu ++ newline
++ ", classes: " ++ pretty cs ++ newline
++ "}"
where newline = "\n" ++ tab (t+1)