Source

xilocaml / PrettyShow.hs

Full commit
module PrettyShow where
import Control.Monad.State
import Data.Char
import qualified Data.Map as Map
import TypeEnvironment
import RunEnvironment
import AbsXilocaml
import PrintXilocaml
import Common
import Position


class PrettyShowable t where
	prettyShow :: t -> String


instance PrettyShowable Position where
	prettyShow Somewhere = "somewhere"
	prettyShow (At line column) = "line " ++ (show line) ++ " around column " ++ (show column)


instance PrettyShowable Type where
	prettyShow = prettyShowNormalized . normalize where
		prettyShowNormalized x = case x of
			TFun t1 t2 -> let
					left = case t1 of
						TFun _ _ -> "(" ++ (prettyShowNormalized t1) ++ ")"
						_ -> prettyShowNormalized t1
					right = prettyShowNormalized t2
				in left ++ " -> " ++ right
			TList t -> let
					left = case t of
						TFun _ _ -> "(" ++ (prettyShowNormalized t) ++ ")"
						_ -> prettyShowNormalized t
				in left ++ " list"
			TInt -> "int"
			TFloat -> "float"
			TBool -> "bool"
			TPoly (OPolyIdent p) -> p


instance PrettyShowable UType where
	prettyShow = prettyShow . convertUTypeToType


instance PrettyShowable Value where
	prettyShow x = case x of
		VFun _ _ _ -> "<fun>"
		VList [] -> "[]"
		VList [x] -> "[" ++ (prettyShow x) ++ "]"
		VList (x:xs) -> let
				tailStr = foldl (\x y -> x ++ ";" ++ y) "" $ map prettyShow xs
			in "[" ++ (prettyShow x) ++ tailStr ++ "]"
		VFloat f -> show f
		VInt i -> show i
		VBool True -> "true"
		VBool False -> "false"


-- Automatically generated printer inserts \n in wrong places.
instance PrettyShowable Exp where
	prettyShow = foldr (\c s -> (if c == '\n' then ' ' else c):s) "" . printTree


-- Normalize polymorphic identifiers to 'a, 'b, ...
type NormalizationEnvironment = Map.Map OPolyIdent OPolyIdent

normalize :: Type -> Type
normalize t = evalState (normalizeImpl t) startMapEnv where
	normalizeImpl :: Type -> State NormalizationEnvironment Type
	normalizeImpl t = case t of
		TFun t1 t2 -> do
			t1' <- normalizeImpl t1
			t2' <- normalizeImpl t2
			return $ TFun t1' t2'
		TList tl -> do
			tl' <- normalizeImpl tl
			return $ TList tl'
		TPoly p -> do
			p' <- lookupVar p
			case p' of
				Nothing -> do
					newP <- nextIdent
					assignVar p newP
					return $ TPoly newP
				Just x -> return $ TPoly x
		_ -> return t

	nextIdent :: State NormalizationEnvironment OPolyIdent
	nextIdent = do
		s <- get
		return $ OPolyIdent $ "'" ++ (identWithNumber $ Map.size s) where
			identWithNumber :: Int -> String
			identWithNumber n = letter:number where
				numLetters = ord 'z' - ord 'a' + 1
				letter = chr $ ord 'a' + n `mod` numLetters
				number = if n < numLetters then "" else show $ n `div` numLetters