Commit 7ff9dce4 authored by Kirchmayr's avatar Kirchmayr
Browse files

Added simplified output (-parameter)

parent efa2490a
......@@ -48,6 +48,7 @@ Library
, directory
, filepath
, mtl
, pretty
, process
, syb
, transformers
......
......@@ -73,22 +73,6 @@ toType' tvs (CS.ParenType ty) = toType' tvs ty
fromQualType :: ModuleIdent -> Type -> CS.TypeExpr
fromQualType m = fromType . unqualifyType m
fromType :: Type -> CS.TypeExpr
fromType (TypeConstructor tc tys)
| isTupleId c = CS.TupleType tys'
| c == unitId && null tys = CS.TupleType []
| c == listId && length tys == 1 = CS.ListType (head tys')
| otherwise = CS.ConstructorType tc tys'
where c = unqualify tc
tys' = map fromType tys
fromType (TypeVariable tv) = CS.VariableType
(if tv >= 0 then identSupply !! tv else mkIdent ('_' : show (-tv)))
fromType (TypeConstrained tys _) = fromType (head tys)
fromType (TypeArrow ty1 ty2) =
CS.ArrowType (fromType ty1) (fromType ty2)
fromType (TypeSkolem k) =
CS.VariableType $ mkIdent $ "_?" ++ show k
-- The following functions implement pretty-printing for types.
ppType :: ModuleIdent -> Type -> Doc
ppType m = ppTypeExpr 0 . fromQualType m
......
......@@ -19,7 +19,8 @@
module Base.Types
( -- * Representation of Types
Type (..), isArrowType, arrowArity, arrowArgs, arrowBase, arrowUnapply
, typeVars, typeConstrs, typeSkolems, equTypes, qualifyType, unqualifyType
, fromType, typeVars, typeConstrs, typeSkolems, equTypes, qualifyType
, unqualifyType
-- * Representation of Data Constructors
, DataConstr (..), constrIdent, constrTypes, recLabels, recLabelTypes
, tupleData
......@@ -31,6 +32,11 @@ module Base.Types
) where
import Curry.Base.Ident
import Curry.Base.Pretty (Pretty(..))
import qualified Curry.Syntax as CS
import Curry.Syntax.Pretty (ppTypeExpr)
import Text.PrettyPrint
-- A type is either a type variable, an application of a type constructor
-- to a list of arguments, or an arrow type. The 'TypeConstrained'
......@@ -59,6 +65,25 @@ data Type
| TypeSkolem Int
deriving (Eq, Show)
instance Pretty Type where
pPrint = ppTypeExpr 0 . fromType
fromType :: Type -> CS.TypeExpr
fromType (TypeConstructor tc tys)
| isTupleId c = CS.TupleType tys'
| c == unitId && null tys = CS.TupleType []
| c == listId && length tys == 1 = CS.ListType (head tys')
| otherwise = CS.ConstructorType tc tys'
where c = unqualify tc
tys' = map fromType tys
fromType (TypeVariable tv) = CS.VariableType
(if tv >= 0 then identSupply !! tv else mkIdent ('_' : show (-tv)))
fromType (TypeConstrained tys _) = fromType (head tys)
fromType (TypeArrow ty1 ty2) =
CS.ArrowType (fromType ty1) (fromType ty2)
fromType (TypeSkolem k) =
CS.VariableType $ mkIdent $ "_?" ++ show k
-- The function 'isArrowType' checks whether a type is a function
-- type t_1 -> t_2 -> ... -> t_n . The function 'arrowArity' computes the arity
-- n of a function type, 'arrowArgs' computes the types t_1 ... t_n-1
......@@ -184,6 +209,13 @@ data DataConstr = DataConstr Ident Int [Type]
| RecordConstr Ident Int [Ident] [Type]
deriving (Eq, Show)
instance Pretty DataConstr where
pPrint (DataConstr i _ tys) = pPrint i <+> hsep (map pPrint tys)
pPrint (RecordConstr i _ ls tys) = pPrint i
<+> braces (hsep (punctuate comma pLs))
where
pLs = zipWith (\l ty -> pPrint l <+> colon <> colon <+> pPrint ty) ls tys
constrIdent :: DataConstr -> Ident
constrIdent (DataConstr c _ _) = c
constrIdent (RecordConstr c _ _ _) = c
......@@ -214,6 +246,12 @@ recLabelTypes (RecordConstr _ _ _ tys) = tys
data TypeScheme = ForAll Int Type deriving (Eq, Show)
data ExistTypeScheme = ForAllExist Int Int Type deriving (Eq, Show)
instance Pretty TypeScheme where
pPrint (ForAll _ ty) = pPrint ty
instance Pretty ExistTypeScheme where
pPrint (ForAllExist _ _ ty) = pPrint ty
-- The functions 'monoType' and 'polyType' translate a type tau into a
-- monomorphic type scheme and a polymorphic type scheme, respectively.
-- 'polyType' assumes that all universally quantified variables in the type are
......
......@@ -68,23 +68,42 @@ showCompilerEnv env allBinds simpleEnv = show $ vcat
, header "Interfaces " $ hcat $ punctuate comma
$ map (text . moduleName)
$ Map.keys $ interfaceEnv env
, header "Module Aliases " $ ppMap $ aliasEnv env
, header "Precedences " $ ppAL $ bindings $ opPrecEnv env
, header "Type Constructors " $ ppAL $ bindings $ tyConsEnv env
, header "Values " $ ppAL $ bindings $ valueEnv env
, header "Module Aliases " $ ppMap simpleEnv $ aliasEnv env
, header "Precedences " $ ppAL simpleEnv $ bindings $ opPrecEnv env
, header "Type Constructors " $ ppAL simpleEnv $ bindings $ tyConsEnv env
, header "Values " $ ppAL simpleEnv $ bindings $ valueEnv env
]
where
header hdr content = hang (text hdr <+> colon) 4 content
bindings = if allBinds then allBindings else allLocalBindings
-- |Pretty print a 'Map'
ppMap :: (Show a, Show b) => Map.Map a b -> Doc
ppMap = ppAL . Map.toList
ppMap :: (Show a, Pretty a, Show b, Pretty b) => Bool-> Map.Map a b -> Doc
ppMap True = ppMapPretty
ppMap False = ppMapShow
ppMapShow :: (Show a, Show b) => Map.Map a b -> Doc
ppMapShow = ppALShow . Map.toList
ppMapPretty :: (Pretty a, Pretty b) => Map.Map a b -> Doc
ppMapPretty = ppALPretty . Map.toList
-- |Pretty print an association list
ppAL :: (Show a, Show b) => [(a, b)] -> Doc
ppAL xs = vcat
ppAL :: (Show a, Pretty a, Show b, Pretty b) => Bool -> [(a, b)] -> Doc
ppAL True = ppALPretty
ppAL False = ppALShow
ppALShow :: (Show a, Show b) => [(a, b)] -> Doc
ppALShow xs = vcat
$ map (\(a,b) -> text (pad a keyWidth) <+> equals <+> text b) showXs
where showXs = map (\(a,b) -> (show a, show b)) xs
keyWidth = maximum (0 : map (length .fst) showXs)
pad s n = take n (s ++ repeat ' ')
ppALPretty :: (Pretty a, Pretty b) => [(a, b)] -> Doc
ppALPretty xs = vcat
$ map (\(a,b) -> text (pad a keyWidth) <+> equals <+> text b) showXs
where showXs = map (\(a,b) -> (render (pPrint a), render (pPrint b))) xs
keyWidth = maximum (0 : map (length .fst) showXs)
pad s n = take n (s ++ repeat ' ')
......@@ -29,11 +29,14 @@ module Env.OpPrec
) where
import Curry.Base.Ident
import Curry.Syntax (Infix (..))
import Curry.Base.Pretty (Pretty(..))
import Curry.Syntax (Infix (..))
import Base.TopEnv
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe)
import Text.PrettyPrint
-- |Operator precedence.
data OpPrec = OpPrec Infix Precedence deriving Eq
......@@ -49,6 +52,9 @@ instance Show OpPrec where
assoc InfixR = "right "
assoc Infix = "non-assoc "
instance Pretty OpPrec where
pPrint (OpPrec fix p) = pPrint fix <+> integer p
-- |Default operator declaration (associativity and precedence).
defaultP :: OpPrec
defaultP = OpPrec defaultAssoc defaultPrecedence
......@@ -70,6 +76,9 @@ data PrecInfo = PrecInfo QualIdent OpPrec deriving (Eq, Show)
instance Entity PrecInfo where
origName (PrecInfo op _) = op
instance Pretty PrecInfo where
pPrint (PrecInfo qid prec) = pPrint qid <+> pPrint prec
-- |Environment mapping identifiers to their operator precedence.
type OpPrecEnv = TopEnv PrecInfo
......
......@@ -44,11 +44,14 @@ module Env.TypeConstructor
) where
import Curry.Base.Ident
import Curry.Base.Pretty (Pretty(..))
import Base.Messages (internalError)
import Base.Messages (internalError)
import Base.TopEnv
import Base.Types
import Base.Utils ((++!))
import Base.Utils ((++!))
import Text.PrettyPrint
data TypeInfo
= DataType QualIdent Int [DataConstr]
......@@ -74,6 +77,18 @@ instance Entity TypeInfo where
| tc == tc' = Just l
merge _ _ = Nothing
instance Pretty TypeInfo where
pPrint (DataType qid ar cs) = text "data" <+> pPrint qid
<> text "/" <> int ar
<+> equals
<+> hsep (punctuate (text "|") (map pPrint cs))
pPrint (RenamingType qid ar c) = text "newtype" <+> pPrint qid
<> text "/" <> int ar
<+> equals <+> pPrint c
pPrint (AliasType qid ar ty) = text "type" <+> pPrint qid
<> text "/" <> int ar
<+> equals <+> pPrint ty
tcArity :: TypeInfo -> Int
tcArity (DataType _ n _) = n
tcArity (RenamingType _ n _) = n
......
......@@ -32,7 +32,7 @@ module Env.Value
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty (Doc, vcat)
import Curry.Base.Pretty (Pretty(..))
import Curry.Syntax
import Base.CurryTypes (fromQualType)
......@@ -41,6 +41,8 @@ import Base.TopEnv
import Base.Types
import Base.Utils ((++!))
import Text.PrettyPrint
data ValueInfo
-- |Data constructor with original name, arity, list of record labels and type
= DataConstructor QualIdent Int [Ident] ExistTypeScheme
......@@ -74,6 +76,18 @@ instance Entity ValueInfo where
| l1 == l2 && cs1 == cs2 && ty1 == ty2 = Just (Label l1 cs1 ty1)
merge _ _ = Nothing
instance Pretty ValueInfo where
pPrint (DataConstructor qid ar _ ts) = text "data" <+> pPrint qid
<> text "/" <> int ar
<+> equals <+> pPrint ts
pPrint (NewtypeConstructor qid _ ts) = text "newtype" <+> pPrint qid
<+> equals <+> pPrint ts
pPrint (Value qid ar ts) = pPrint qid
<> text "/" <> int ar
<+> equals <+> pPrint ts
pPrint (Label qid _ ts) = text "label" <+> pPrint qid
<+> equals <+> pPrint ts
mergeLabel :: Ident -> Ident -> Maybe Ident
mergeLabel l1 l2
| l1 == anonId = Just l2
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment