module Present
(
presentIt
,presentName
,presentType
,toShow
,toWHNF
,whnfJson
,presentShow
,Value(..)
,WHNF(..)
,Present0(..)
,Present1(..)
,Present2(..)
,Present3(..)
,Present4(..)
,Present5(..)
,Present6(..))
where
import Control.Arrow (second)
import Control.Exception (evaluate,SomeException(..),try,evaluate)
import Control.Monad (forM)
import Control.Monad.Trans.State.Strict (evalStateT,get,modify,StateT(..))
import Data.Char (isSpace,ord,isAlphaNum)
import Data.Int (Int8,Int16,Int32,Int64)
import Data.List (nub,find,intercalate,foldl',isSuffixOf)
import Data.Maybe (mapMaybe,isJust)
import Data.Ratio (numerator,denominator)
import Data.String (IsString)
import Data.Typeable (typeOf)
import Data.Word (Word8,Word32,Word64)
import Foreign.ForeignPtr
import Foreign.Ptr
import Numeric (showHex)
import System.IO.Unsafe (unsafePerformIO)
import Text.Printf (printf)
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
newtype TypeVariable =
TypeVariable TH.Name
deriving (Eq)
newtype TypeConstructor =
TypeConstructor TH.Name
deriving (Eq)
newtype PrimitiveTypeConstructor =
PrimitiveTypeConstructor TH.Name
data NormalType
= NormalCons TypeConstructor
| NormalPrimitive PrimitiveTypeConstructor
| NormalFunction TH.Type
| NormalVar TypeVariable
| NormalApp NormalType
[NormalType]
normalizeType
:: TH.Type -> Either String NormalType
normalizeType = go
where go =
\case
ty@TH.AppT{} ->
do let (typeFunction,typeArguments) = flattenApplication ty
case typeFunction of
TH.ArrowT -> return (NormalFunction ty)
_ -> NormalApp <$> go typeFunction <*> mapM go typeArguments
TH.ForallT _ context ty ->
if isFunction ty
then return (NormalFunction ty)
else go (typeClassDefaulting context ty)
TH.SigT ty _kind -> go ty
TH.VarT name -> return (NormalVar (TypeVariable name))
TH.ConT name ->
return (if isPrimitiveType name
then NormalPrimitive (PrimitiveTypeConstructor name)
else NormalCons (TypeConstructor name))
TH.TupleT i ->
case lookup i tupleConstructors of
Nothing -> Left ("Tuple arity " ++ show i ++ " not supported.")
Just cons -> return (NormalCons (TypeConstructor cons))
TH.ListT -> return (NormalCons (TypeConstructor ''[]))
TH.PromotedT _ -> Left "Promoted types are not supported."
TH.UnboxedTupleT _ -> Left "Unboxed tuples are not supported."
TH.ArrowT -> Left "The function arrow (->) is not supported."
TH.EqualityT -> Left "Equalities are not supported."
TH.PromotedTupleT _ -> Left "Promoted types are not supported."
TH.PromotedNilT -> Left "Promoted types are not supported."
TH.PromotedConsT -> Left "Promoted types are not supported."
TH.StarT -> Left "Star (*) is not supported."
TH.ConstraintT -> Left "Constraints are not supported."
TH.LitT _ -> Left "Type-level literals are not supported."
#if MIN_VERSION_template_haskell(2,11,0)
TH.InfixT{} -> Left "Infix type constructors are not supported."
TH.UInfixT{} -> Left "Unresolved infix type constructors are not supported."
TH.ParensT _ -> Left "Parenthesized types are not supported."
TH.WildCardT -> Left "Wildcard types are not supported."
#endif
isFunction :: TH.Type -> Bool
isFunction ty =
let (typeFunction,_) = flattenApplication ty
in case typeFunction of
TH.ArrowT -> True
_ -> False
tupleConstructors :: [(Int,TH.Name)]
tupleConstructors =
[(0,''())
,(2,''(,))
,(3,''(,,))
,(4,''(,,,))
,(5,''(,,,,))
,(6,''(,,,,,))
,(7,''(,,,,,,))
,(8,''(,,,,,,,))
,(9,''(,,,,,,,,))
,(10,''(,,,,,,,,,))
,(11,''(,,,,,,,,,,))
,(12,''(,,,,,,,,,,,))
,(13,''(,,,,,,,,,,,,))
,(14,''(,,,,,,,,,,,,,))
,(15,''(,,,,,,,,,,,,,,))
,(16,''(,,,,,,,,,,,,,,,))
,(17,''(,,,,,,,,,,,,,,,,))
,(18,''(,,,,,,,,,,,,,,,,,))
,(19,''(,,,,,,,,,,,,,,,,,,))
,(20,''(,,,,,,,,,,,,,,,,,,,))
,(21,''(,,,,,,,,,,,,,,,,,,,,))
,(22,''(,,,,,,,,,,,,,,,,,,,,,))
,(23,''(,,,,,,,,,,,,,,,,,,,,,,))
,(24,''(,,,,,,,,,,,,,,,,,,,,,,,))
,(25,''(,,,,,,,,,,,,,,,,,,,,,,,,))
,(26,''(,,,,,,,,,,,,,,,,,,,,,,,,,))]
isPrimitiveType :: TH.Name -> Bool
isPrimitiveType (TH.Name (TH.OccName _) (TH.NameG TH.TcClsName (TH.PkgName "ghc-prim") (TH.ModName "GHC.Prim"))) =
True
isPrimitiveType name = isSuffixOf "#" (show name)
flattenApplication
:: TH.Type -> (TH.Type,[TH.Type])
flattenApplication = go []
where go args (TH.AppT f x) = go (x : args) f
go args f = (f,args)
typeClassDefaulting
:: [TH.Type] -> TH.Type -> TH.Type
typeClassDefaulting constraints =
applyTypeSubstitution
(mapMaybe (\case
TH.AppT (TH.ConT className) (TH.VarT varName) ->
fmap (\tyName -> (varName,TH.ConT tyName))
(lookup className defaultedClasses)
_ -> Nothing)
constraints)
applyTypeSubstitution
:: [(TH.Name,TH.Type)] -> TH.Type -> TH.Type
applyTypeSubstitution subs = go
where go =
\case
TH.ForallT vars ctx ty ->
TH.ForallT vars
ctx
(go ty)
TH.AppT f x ->
TH.AppT (go f)
(go x)
TH.SigT ty k -> TH.SigT (go ty) k
TH.VarT a
| Just b <- lookup a subs -> b
| otherwise -> TH.VarT a
x -> x
defaultedClasses :: [(TH.Name,TH.Name)]
defaultedClasses =
[(''Integral,''Integer)
,(''Num,''Integer)
,(''Fractional,''Double)
,(''Bounded,''())
,(''Eq,''())
,(''Read,''())
,(''Show,''())
,(''IsString,''String)]
enumerateTypeConstructors
:: NormalType -> [TypeConstructor]
enumerateTypeConstructors = nub . go
where go =
\case
NormalCons cons -> [cons]
NormalApp ty tys -> go ty ++ concatMap go tys
NormalPrimitive{} -> []
NormalVar{} -> []
NormalFunction{} -> []
newtype ValueVariable =
ValueVariable TH.Name
newtype ValueConstructor =
ValueConstructor TH.Name
data Constructor =
Constructor {_constructorName :: ValueConstructor
,constructorFields :: [(Maybe ValueVariable,NormalType)]}
data DataType =
DataType {_dataTypeVariables :: [TypeVariable]
,_dataTypeConstructors :: [Constructor]}
data TypeAlias =
TypeAlias {_aliasVariables :: [TypeVariable]
,_aliasType :: NormalType}
data TypeDefinition
= DataTypeDefinition TypeConstructor
DataType
| TypeAliasDefinition TypeConstructor
TypeAlias
reifyTypeDefinition
:: TypeConstructor -> TH.Q (Maybe TypeDefinition)
reifyTypeDefinition typeConstructor@(TypeConstructor name) =
do info <- TH.reify name
let result =
case info of
TH.TyConI dec ->
case dec of
#if MIN_VERSION_template_haskell(2,11,0)
TH.DataD _cxt0 _ vars _mkind cons _cxt1 ->
#else
TH.DataD _cxt _ vars cons _deriving ->
#endif
do cs <- concat <$> mapM makeConstructors cons
return (Just (DataTypeDefinition typeConstructor
(DataType (map toTypeVariable vars) cs)))
#if MIN_VERSION_template_haskell(2,11,0)
TH.NewtypeD _cxt0 _ vars _mkind con _cxt1 ->
#else
TH.NewtypeD _cxt _ vars con _deriving ->
#endif
do cs <- makeConstructors con
return (Just (DataTypeDefinition
typeConstructor
(DataType (map toTypeVariable vars)
cs)))
TH.TySynD _ vars ty ->
do ty' <- normalizeType ty
return (Just (TypeAliasDefinition typeConstructor
(TypeAlias (map toTypeVariable vars) ty')))
_ -> Left "Not a supported data type declaration."
TH.PrimTyConI{} -> return Nothing
TH.FamilyI{} -> Left "Data families not supported yet."
_ ->
Left ("Not a supported object, no type inside it: " ++
TH.pprint info)
case result of
Left err -> fail err
Right ok -> return ok
toTypeVariable :: TH.TyVarBndr -> TypeVariable
toTypeVariable =
\case
TH.PlainTV t -> TypeVariable t
TH.KindedTV t _ -> TypeVariable t
makeConstructors
:: TH.Con -> Either String [Constructor]
makeConstructors =
\case
TH.NormalC name slots ->
(:[]) <$> makeConstructor name (mapM makeSlot slots)
TH.RecC name fields ->
(:[]) <$> makeConstructor name (mapM makeField fields)
TH.InfixC t1 name t2 ->
(:[]) <$> makeConstructor name ((\x y -> [x,y]) <$> makeSlot t1 <*> makeSlot t2)
(TH.ForallC _ _ con) ->
makeConstructors con
#if MIN_VERSION_template_haskell(2,11,0)
TH.GadtC names slots _type ->
forM names $ \name ->
makeConstructor name (mapM makeSlot slots)
TH.RecGadtC names fields _type ->
forM names $ \name ->
makeConstructor name (mapM makeField fields)
#endif
where makeConstructor name efields = Constructor (ValueConstructor name) <$> efields
makeSlot (_,ty) = (Nothing,) <$> normalizeType ty
makeField (name,_,ty) =
(Just (ValueVariable name),) <$> normalizeType ty
definitionNormalTypes
:: TypeDefinition -> [NormalType]
definitionNormalTypes =
\case
DataTypeDefinition _ (DataType _ cons) ->
concatMap (map snd . constructorFields) cons
TypeAliasDefinition _ (TypeAlias _ ty) -> [ty]
normalTypeDefinitions
:: NormalType -> TH.Q [TypeDefinition]
normalTypeDefinitions = flip evalStateT [] . expandNormalType
where expandNormalType =
fmap concat . mapM expandTypeConstructor . enumerateTypeConstructors
expandTypeConstructor typeConstructor =
do seenConstructors <- get
if elem typeConstructor seenConstructors
then return []
else do mtypeDefinition <-
liftQ (reifyTypeDefinition typeConstructor)
case mtypeDefinition of
Nothing -> return []
Just typeDefinition ->
do let normalTypes =
definitionNormalTypes typeDefinition
modify (typeConstructor :)
typeDefinitions <-
fmap concat (mapM expandNormalType normalTypes)
return (typeDefinition : typeDefinitions)
liftQ :: TH.Q a -> StateT s TH.Q a
liftQ m =
StateT (\s ->
do v <- m
return (v,s))
data Value
= DataValue String String [Value]
| TypeVariableValue String
| PrimitiveValue String
| FunctionValue String
| CharValue String String
| IntegerValue String String
| ChoiceValue String [(String,Value)]
| RecordValue String String [(String,Value)]
| ListValue String [Value]
| StringValue String String
| TupleValue String [Value]
| ExceptionValue String String
deriving (Show)
typeDefinitionPresenter :: [(TypeConstructor,ValueVariable)]
-> TypeDefinition
-> TH.Q [TH.Dec]
typeDefinitionPresenter instances =
\case
DataTypeDefinition typeConstructor dataType@(DataType typeVariables _) ->
case find (namesBasicallyEqual typeConstructor . fst) instances of
Nothing ->
case find (namesBasicallyEqual typeConstructor . fst) builtInPresenters of
Nothing -> dataTypePresenter typeConstructor dataType
Just (_,presenter) ->
do automaticPresenter <-
dataTypePresenterBody typeConstructor dataType
builtinFunctionDeclaration typeConstructor
(presenter typeVariables automaticPresenter)
Just (_,methodName) ->
do instanceBasedPresenter typeConstructor methodName dataType typeVariables
TypeAliasDefinition typeConstructor typeAlias ->
typeAliasPresenter typeConstructor typeAlias
instanceBasedPresenter :: TypeConstructor
-> ValueVariable
-> DataType
-> [TypeVariable]
-> TH.Q [TH.Dec]
instanceBasedPresenter typeConstructor@(TypeConstructor typeConstructorName) (ValueVariable methodName) dataType typeVariables =
presentingFunctionDeclaration
typeConstructor
typeVariables
(TH.tupE [typeDisplayExpression
,[|\x ->
ChoiceValue
$(typeDisplayExpression)
[("Instance"
,snd $(foldl TH.appE
(TH.varE methodName)
(map (TH.varE . presentVarName) typeVariables))
x)
,("Internal"
,$(dataTypePresenterBody typeConstructor dataType) x)]|]])
where typeDisplayExpression = typeDisplay typeVariables typeConstructorName
dataTypePresenter
:: TypeConstructor -> DataType -> TH.Q [TH.Dec]
dataTypePresenter typeConstructor@(TypeConstructor typeConstructorName) dataType@(DataType typeVariables _) =
presentingFunctionDeclaration
typeConstructor
typeVariables
(TH.tupE [typeDisplayExpression
,dataTypePresenterBody typeConstructor dataType])
where typeDisplayExpression = typeDisplay typeVariables typeConstructorName
dataTypePresenterBody
:: TypeConstructor -> DataType -> TH.Q TH.Exp
dataTypePresenterBody (TypeConstructor typeConstructorName) (DataType typeVariables constructors) =
TH.lamCaseE (map constructorCase constructors)
where typeDisplayExpression = typeDisplay typeVariables typeConstructorName
constructorCase (Constructor (ValueConstructor valueConstructorName) fields) =
TH.match (TH.conP valueConstructorName (map (return . fieldPattern) indexedFields))
(TH.normalB
(TH.appE presentationConstructor (TH.listE (map fieldPresenter indexedFields))))
[]
where presentationConstructor =
if isTuple typeConstructorName
then TH.appE (TH.conE 'TupleValue) typeDisplayExpression
else TH.appE (TH.appE (TH.conE (if any (isJust . fst) fields &&
not (null fields)
then 'RecordValue
else 'DataValue))
typeDisplayExpression)
(TH.litE (TH.stringL (TH.pprint valueConstructorName)))
indexedFields = zip (map indexedFieldName [0 ..]) fields
fieldPattern (indexedName,_) = TH.VarP indexedName
fieldPresenter (indexedName,(mvalueVariable,normalType)) =
addField (TH.appE (TH.appE (TH.varE 'snd)
(expressType typeVariables normalType))
(TH.varE indexedName))
where addField =
case mvalueVariable of
Nothing -> id
Just (ValueVariable fieldName) ->
\e ->
TH.tupE [TH.stringE (TH.pprint fieldName),e]
typeDisplay
:: [TypeVariable] -> TH.Name -> TH.Q TH.Exp
typeDisplay typeVariables name =
(applyToVars . TH.litE . TH.stringL . TH.pprint) name
where applyToVars typeConstructorDisplay
| null typeVariables = typeConstructorDisplay
| isTuple name =
[|("(" ++
intercalate
","
$(TH.listE (map (\typeVariable ->
TH.appE (TH.varE 'fst)
(TH.varE (presentVarName typeVariable)))
typeVariables)) ++
")")|]
| otherwise =
TH.appE (TH.varE 'unwords)
(TH.infixE (Just (TH.listE [typeConstructorDisplay]))
(TH.varE '(++))
(Just (TH.listE (map (\typeVariable ->
TH.appE (TH.varE 'parensIfNeeded)
(TH.appE (TH.varE 'fst)
(TH.varE (presentVarName typeVariable))))
typeVariables))))
isTuple :: TH.Name -> Bool
isTuple typeConstructorName =
any ((== typeConstructorName) . snd) tupleConstructors
parensIfNeeded :: [Char] -> [Char]
parensIfNeeded e =
if any isSpace e
then "(" ++ e ++ ")"
else e
indexedFieldName :: Integer -> TH.Name
indexedFieldName index = TH.mkName ("indexedField_" ++ show index)
typeAliasPresenter
:: TypeConstructor -> TypeAlias -> TH.Q [TH.Dec]
typeAliasPresenter typeConstructor@(TypeConstructor typeConstructorName) (TypeAlias typeVariables normalType) =
presentingFunctionDeclaration
typeConstructor
typeVariables
(TH.tupE [TH.litE (TH.stringL (TH.pprint typeConstructorName))
,TH.appE (TH.varE 'snd)
(expressType typeVariables normalType)])
builtinFunctionDeclaration
:: TypeConstructor -> TH.Q TH.Exp -> TH.Q [TH.Dec]
builtinFunctionDeclaration typeConstructor body =
do dec <-
TH.valD (TH.varP name)
(TH.normalB body)
[]
return [dec]
where name = presentConsName typeConstructor
presentingFunctionDeclaration :: TypeConstructor
-> [TypeVariable]
-> TH.Q TH.Exp
-> TH.Q [TH.Dec]
presentingFunctionDeclaration typeConstructor@(TypeConstructor typeConstructorName) typeVariables body =
do sig <-
TH.sigD name
(TH.forallT
(map (\(TypeVariable typeVariable) -> TH.PlainTV typeVariable) typeVariables)
(return [])
(foldl (\inner (TypeVariable typeVariable) ->
let presentTypeVariable =
return (TH.AppT (TH.AppT (TH.TupleT 2)
(TH.ConT ''String))
presenter)
where presenter =
TH.AppT (TH.AppT TH.ArrowT (TH.VarT typeVariable))
(TH.ConT ''Value)
in TH.appT (TH.appT TH.arrowT presentTypeVariable) inner)
tupleType
(reverse typeVariables)))
dec <-
if null typeVariables
then TH.valD (TH.varP name)
(TH.normalB body)
[]
else TH.funD name
[TH.clause (map (\typeVariable ->
TH.varP (presentVarName typeVariable))
typeVariables)
(TH.normalB body)
[]]
return [sig,dec]
where name = presentConsName typeConstructor
tupleType =
((\string typ -> TH.AppT (TH.AppT (TH.TupleT 2) string) typ) <$>
TH.conT ''String <*>
TH.appT (TH.appT TH.arrowT appliedType)
(TH.conT ''Value))
appliedType =
foldl TH.appT
(TH.conT typeConstructorName)
(map (\(TypeVariable typeVariableName) ->
TH.varT typeVariableName)
typeVariables)
namesBasicallyEqual
:: TypeConstructor -> TypeConstructor -> Bool
namesBasicallyEqual (TypeConstructor this) (TypeConstructor that) =
normalize this == normalize that
where normalize n@(TH.Name name flavour) =
case flavour of
TH.NameG _ _ modName -> TH.Name name (TH.NameQ modName)
_ -> n
builtInPresenters
:: [(TypeConstructor,[TypeVariable] -> TH.Exp -> TH.Q TH.Exp)]
builtInPresenters =
concat [listPrinters
,integerPrinters
,realPrinters
,charPrinters
,packedStrings
,vectorPrinters
,pointerPrinters]
vectorPrinters
:: [(TypeConstructor,[TypeVariable] -> TH.Exp -> TH.Q TH.Exp)]
vectorPrinters =
[makeVectorPrinter (qualified "Data.Vector" "Vector")
(qualified "Data.Vector" "toList")]
where makeVectorPrinter typeName unpackFunction =
(TypeConstructor typeName
,\(typeVariable:_) automaticPrinter ->
(let presentVar = TH.varE (presentVarName typeVariable)
in TH.lamE [TH.varP (presentVarName typeVariable)]
[|(let typeString =
$(TH.stringE (TH.pprint typeName)) ++
" " ++ parensIfNeeded (fst $(presentVar))
in (typeString
,\xs ->
ChoiceValue
typeString
[("List"
,ListValue typeString
(map (snd $(presentVar))
($(TH.varE unpackFunction) xs)))
,("Internal",$(return automaticPrinter) xs)]))|]))
qualified modName term =
TH.Name (TH.OccName term)
(TH.NameQ (TH.ModName modName))
packedStrings
:: [(TypeConstructor,a -> TH.Exp -> TH.Q TH.Exp)]
packedStrings =
[makeStringPrinter (qualified "Data.ByteString.Internal" "ByteString")
(qualified "Data.ByteString.Char8" "unpack")
,makeStringPrinter (qualified "Data.ByteString.Lazy.Internal" "ByteString")
(qualified "Data.ByteString.Lazy.Char8" "unpack")
,makeStringPrinter (qualified "Data.Text.Internal" "Text")
(qualified "Data.Text" "unpack")
,makeStringPrinter (qualified "Data.Text.Internal.Lazy" "Text")
(qualified "Data.Text.Lazy" "unpack")]
where makeStringPrinter typeName unpackFunction =
(TypeConstructor typeName
,\_ internal ->
[|let typeString = $(TH.stringE (TH.pprint typeName))
in (typeString
,\xs ->
ChoiceValue
typeString
[("String"
,StringValue typeString
($(TH.varE unpackFunction) xs))
,("Internal",$(return internal) xs)])|])
qualified modName term =
TH.Name (TH.OccName term)
(TH.NameQ (TH.ModName modName))
listPrinters
:: [(TypeConstructor,[TypeVariable] -> TH.Exp -> TH.Q TH.Exp)]
listPrinters =
[(TypeConstructor ''[]
,\(typeVariable:_) _automaticPrinter ->
(let presentVar = TH.varE (presentVarName typeVariable)
in TH.lamE [TH.varP (presentVarName typeVariable)]
[|(let typeString = "[" ++ fst $(presentVar) ++ "]"
in (typeString
,\xs ->
ListValue typeString (map (snd $(presentVar)) xs)))|]))]
charPrinters
:: [(TypeConstructor,a -> TH.Exp -> TH.Q TH.Exp)]
charPrinters = map makeCharPrinter [''Char]
where makeCharPrinter name =
(TypeConstructor name
,\_ automaticPrinter ->
[|($(TH.stringE (show name))
,\c ->
ChoiceValue
$(TH.stringE (show name))
[("Character"
,CharValue $(TH.stringE (show name))
(return c))
,("Unicode point",($(intPrinter Nothing name) (ord c)))
,("Internal",$(return automaticPrinter) c)])|])
pointerPrinters
:: [(TypeConstructor,[TypeVariable] -> TH.Exp -> TH.Q TH.Exp)]
pointerPrinters = map makePtrPrinter [''Ptr,''ForeignPtr,''FunPtr]
where makePtrPrinter name =
(TypeConstructor name
,\(typeVariable:_) automaticPrinter ->
(let presentVar = TH.varE (presentVarName typeVariable)
in TH.lamE [TH.varP (presentVarName typeVariable)]
[|(let typeString =
$(TH.stringE (show name)) ++
" " ++ parensIfNeeded (fst $(presentVar))
in (typeString
,\x ->
ChoiceValue
typeString
[("Pointer"
,IntegerValue typeString
(show x))
,("Internal",$(return automaticPrinter) x)]))|]))
realPrinters
:: [(TypeConstructor,a -> TH.Exp -> TH.Q TH.Exp)]
realPrinters = map makeIntPrinter [''Float,''Double]
where makeIntPrinter name =
(TypeConstructor name
,\_ automaticPrinter ->
[|($(TH.stringE (show name))
,$(floatingPrinter (Just automaticPrinter)
name))|])
integerPrinters
:: [(TypeConstructor,a -> TH.Exp -> TH.Q TH.Exp)]
integerPrinters =
map makeIntPrinter
[''Integer
,''Int
,''Int8
,''Int16
,''Int32
,''Int64
,''Word
,''Word8
,''Word32
,''Word64]
where makeIntPrinter name =
(TypeConstructor name
,\_ automaticPrinter ->
[|($(TH.stringE (show name))
,$(intPrinter (Just automaticPrinter)
name))|])
showRational :: Rational -> String
showRational x = show (numerator x) ++ "/" ++ show (denominator x)
floatingPrinter
:: Maybe TH.Exp -> TH.Name -> TH.Q TH.Exp
floatingPrinter mautomaticPrinter name =
[|\x ->
ChoiceValue
$(TH.stringE (show name))
$(case mautomaticPrinter of
Nothing ->
[|[("Floating"
,IntegerValue $(TH.stringE (show name))
(printf "%f" x))
,("Show"
,IntegerValue $(TH.stringE (show name))
(show x))
,("Rational"
,IntegerValue $(TH.stringE (show name))
(showRational (toRational x)))]|]
Just automaticPrinter ->
[|[("Floating"
,IntegerValue $(TH.stringE (show name))
(printf "%f" x))
,("Show"
,IntegerValue $(TH.stringE (show name))
(show x))
,("Rational"
,IntegerValue $(TH.stringE (show name))
(showRational (toRational x)))
,("Internal",$(return automaticPrinter) x)]|])|]
intPrinter
:: Maybe TH.Exp -> TH.Name -> TH.Q TH.Exp
intPrinter mautomaticPrinter name =
[|\x ->
ChoiceValue
$(TH.stringE (show name))
$(case mautomaticPrinter of
Nothing ->
[|[("Decimal"
,IntegerValue $(TH.stringE (show name))
(show x))
,("Hexadecimal"
,IntegerValue $(TH.stringE (show name))
(Text.Printf.printf "%x" x))
,("Binary"
,IntegerValue $(TH.stringE (show name))
(Text.Printf.printf "%b" x))]|]
Just automaticPrinter ->
[|[("Decimal"
,IntegerValue $(TH.stringE (show name))
(show x))
,("Hexadecimal"
,IntegerValue $(TH.stringE (show name))
(Text.Printf.printf "%x" x))
,("Binary"
,IntegerValue $(TH.stringE (show name))
(Text.Printf.printf "%b" x))
,("Internal",$(return automaticPrinter) x)]|])|]
expressType
:: [TypeVariable] -> NormalType -> TH.Q TH.Exp
expressType = go 0
where go arity typeVariables =
\case
NormalVar ty ->
if elem ty typeVariables
then TH.varE (presentVarName ty)
else return (presentUnknownVar ty arity)
NormalCons cons -> TH.varE (presentConsName cons)
NormalPrimitive (PrimitiveTypeConstructor typeConstructorName) ->
expressPrimitive typeConstructorName
NormalFunction ty ->
return (TH.TupE [TH.LitE (TH.StringL (TH.pprint ty))
,TH.LamE [TH.WildP]
(TH.AppE (TH.ConE 'FunctionValue)
(TH.LitE (TH.StringL (TH.pprint ty))))])
NormalApp f args ->
foldl TH.appE
(go (length args) typeVariables f)
(map (go 0 typeVariables) args)
expressPrimitive :: TH.Name -> TH.Q TH.Exp
expressPrimitive typeConstructorName =
do info <- TH.reify typeConstructorName
case info of
TH.PrimTyConI _ arity _unlifted ->
return (ignoreTypeVariables
arity
(TH.TupE [TH.LitE (TH.StringL (TH.pprint typeConstructorName))
,TH.LamE [TH.WildP]
(TH.AppE (TH.ConE 'PrimitiveValue)
(TH.LitE (TH.StringL (TH.pprint typeConstructorName))))]))
_ -> fail ("Mistaken primitive type: " ++ TH.pprint typeConstructorName)
presentUnknownVar
:: TypeVariable -> Int -> TH.Exp
presentUnknownVar (TypeVariable ty) arity =
ignoreTypeVariables
arity
(TH.TupE [TH.LitE (TH.StringL (TH.pprint ty))
,TH.LamE [TH.WildP]
(TH.AppE (TH.ConE 'TypeVariableValue)
(TH.LitE (TH.StringL (TH.pprint ty))))])
ignoreTypeVariables :: Int -> TH.Exp -> TH.Exp
ignoreTypeVariables arity
| arity == 0 = id
| otherwise = TH.ParensE . TH.LamE (replicate arity TH.WildP)
presentVarName :: TypeVariable -> TH.Name
presentVarName (TypeVariable ty) =
TH.mkName ("presentVar_" ++ normalizeName ty)
presentConsName :: TypeConstructor -> TH.Name
presentConsName (TypeConstructor ty) =
TH.mkName ("presentCons_" ++ normalizeName ty)
normalizeName :: TH.Name -> String
normalizeName x = concatMap replace (show x)
where replace 'z' = "zz"
replace c
| isAlphaNum c = [c]
| otherwise = "z" ++ printf "%x" (ord c)
getPresentInstances
:: TH.Q [(TypeConstructor,ValueVariable)]
getPresentInstances =
do p0 <- getFor ''Present0
p1 <- getFor ''Present1
p2 <- getFor ''Present2
p3 <- getFor ''Present3
p4 <- getFor ''Present4
return (concat [p0,p1,p2,p3,p4])
where getFor cls =
do result <- TH.reify cls
case result of
TH.ClassI (TH.ClassD _ _ _ _ [TH.SigD method _]) instances ->
return (mapMaybe (\i ->
case i of
#if MIN_VERSION_template_haskell(2,11,0)
TH.InstanceD _moverlap _ (TH.AppT (TH.ConT _className) (TH.ConT typeName)) _ ->
#else
TH.InstanceD _ (TH.AppT (TH.ConT _className) (TH.ConT typeName)) _ ->
#endif
Just (TypeConstructor typeName
,ValueVariable method)
_ -> Nothing)
instances)
_ -> return []
class Present0 a where
present0 :: (String,a -> Value)
class Present1 a where
present1
:: (String,x -> Value)
-> (String,a x -> Value)
class Present2 a where
present2
:: (String,x -> Value)
-> (String,y -> Value)
-> (String,a x y -> Value)
class Present3 a where
present3
:: (String,x -> Value)
-> (String,y -> Value)
-> (String,z -> Value)
-> (String,a x y z -> Value)
class Present4 a where
present4
:: (String,x -> Value)
-> (String,y -> Value)
-> (String,z -> Value)
-> (String,z0 -> Value)
-> (String,a x y z z0 -> Value)
class Present5 a where
present5
:: (String,x -> Value)
-> (String,y -> Value)
-> (String,z -> Value)
-> (String,z0 -> Value)
-> (String,z1 -> Value)
-> (String,a x y z z0 z1 -> Value)
class Present6 a where
present6
:: (String,x -> Value)
-> (String,y -> Value)
-> (String,z -> Value)
-> (String,z0 -> Value)
-> (String,z1 -> Value)
-> (String,z2 -> Value)
-> (String,a x y z z0 z1 z2 -> Value)
presentIt :: TH.Q TH.Exp
presentIt = presentName (TH.mkName "it")
presentName :: TH.Name -> TH.Q TH.Exp
presentName name =
do result <- tryQ (TH.reify name)
case result of
Nothing -> fail "Name `it' isn't in scope."
#if MIN_VERSION_template_haskell(2,11,0)
Just (TH.VarI _ ty _) ->
#else
Just (TH.VarI _ ty _ _) ->
#endif
TH.appE (presentType (return ty)) (TH.varE name)
_ -> fail "The name `it' isn't a variable."
where tryQ m =
TH.recover (pure Nothing)
(fmap Just m)
presentType :: TH.Q TH.Type -> TH.Q TH.Exp
presentType getTy =
do ty <- getTy
let normalizeResult = normalizeType ty
case normalizeResult of
Left err -> fail err
Right normalType ->
do instances <- getPresentInstances
typeDefinitions <- normalTypeDefinitions normalType
presenters <-
mapM (typeDefinitionPresenter instances) typeDefinitions
TH.letE (map return (concat presenters))
(TH.infixE (Just (TH.varE 'wrapExceptions))
(TH.varE '(.))
(Just (TH.appE (TH.varE 'snd)
(expressType [] normalType))))
presentShow :: TH.Q TH.Type -> TH.Q TH.Exp
presentShow ty = [|toShow False . $(presentType ty)|]
wrapExceptions :: Value -> Value
wrapExceptions = wrap . go
where wrap =
either (\(SomeException exception) ->
ExceptionValue (show (typeOf exception))
(show exception))
id .
trySpoon
go =
\case
DataValue a b ps ->
DataValue a
b
(map wrapExceptions ps)
ChoiceValue ty lps ->
ChoiceValue ty
(map (second wrapExceptions) lps)
RecordValue ty c lps ->
RecordValue ty
c
(map (second wrapExceptions) lps)
ListValue ty ps -> seq ps (ListValue ty (map wrapExceptions ps))
TupleValue ty ps ->
seq ps
(TupleValue ty
(map wrapExceptions ps))
p@(CharValue _ x) -> seqString p x
p@(IntegerValue _ x) -> seqString p x
p@TypeVariableValue{} -> p
p@PrimitiveValue{} -> p
p@FunctionValue{} -> p
p@(StringValue _ x) -> seqString p x
p@ExceptionValue{} -> p
seqString :: Value -> String -> Value
seqString = foldl' (\presentation x -> seq x presentation)
trySpoon :: a -> Either SomeException a
trySpoon a = unsafePerformIO (try (evaluate a))
toShow :: Bool -> Value -> String
toShow qualified =
\case
IntegerValue _ i -> i
ExceptionValue ex display -> "<" ++ ex ++ ": " ++ show display ++ ">"
TypeVariableValue ty -> "<_ :: " ++ ty ++ ">"
CharValue _ c -> "'" ++ c ++ "'"
FunctionValue ty -> "<" ++ unwords (lines ty) ++ ">"
DataValue _type name slots ->
qualify name ++
(if null slots
then ""
else " ") ++
intercalate " "
(map recur slots)
RecordValue _type name fields ->
qualify name ++
" {" ++
intercalate ","
(map showField fields) ++
"}"
where showField (fname,slot) =
qualify fname ++ " = " ++ toShow qualified slot
TupleValue _type slots ->
"(" ++
intercalate ","
(map (toShow qualified) slots) ++
")"
ListValue typ slots ->
if typ == "[GHC.Types.Char]"
then show (concatMap (\case
CharValue _ c -> c
ChoiceValue _ ((_,CharValue _ c):_) -> c
_ -> []) slots)
else "[" ++
intercalate ","
(map (toShow qualified) slots) ++
"]"
PrimitiveValue p -> "<" ++ p ++ ">"
StringValue _ string -> show string
ChoiceValue ty ((_,x):choices) ->
case x of
ExceptionValue{}
| not (null choices) -> toShow qualified (ChoiceValue ty choices)
_ -> toShow qualified x
ChoiceValue _ [] -> "<no presentation choices>"
where recur p
| atomic p = toShow qualified p
| otherwise = "(" ++ toShow qualified p ++ ")"
where atomic =
\case
ListValue{} -> True
IntegerValue{} -> True
CharValue{} -> True
StringValue{} -> True
ChoiceValue ty ((_,x):xs) ->
case x of
ExceptionValue{}
| not (null xs) -> atomic (ChoiceValue ty xs)
_ -> atomic x
DataValue _ _ [] -> True
PrimitiveValue _ -> True
_ -> False
qualify x =
if qualified
then x
else reverse (takeWhile (/= '.') (reverse x))
data WHNF
= DataWHNF String String [(String,[Integer])]
| TypeVariableWHNF String
| PrimitiveWHNF String
| FunctionWHNF String
| CharWHNF String String
| IntegerWHNF String String
| ChoiceWHNF String [(String,[Integer])]
| RecordWHNF String String [(String,String,[Integer])]
| ListConsWHNF String [Integer] [Integer]
| ListEndWHNF String
| StringWHNF String String
| TupleWHNF String [(String,[Integer])]
| ExceptionWHNF String String
deriving (Show)
toWHNF :: [Integer]
-> Value
-> WHNF
toWHNF = go []
where go
:: [Integer] -> [Integer] -> Value -> WHNF
go stack cursor =
\case
DataValue typ name slots ->
case cursor of
(slot:subCursor) ->
case lookup slot (zip [0 ..] slots) of
Nothing -> error "toWHNF: Invalid slot."
Just value -> go (push [slot]) subCursor value
_ ->
DataWHNF typ
name
(zipWith (\index slot ->
(valueType slot,push (cursor ++ [index])))
[0 ..]
slots)
ChoiceValue ty slots ->
case cursor of
(slot:subCursor) ->
case lookup slot (zip [0 ..] slots) of
Nothing -> error "toWHNF: Invalid slot."
Just (_,value) -> go (push [slot]) subCursor value
_ ->
ChoiceWHNF
ty
(zipWith (\index (string,_) ->
(string,push (cursor ++ [index])))
[0 ..]
slots)
RecordValue typ name slots ->
case cursor of
(slot:subCursor) ->
case lookup slot (zip [0 ..] slots) of
Nothing -> error "toWHNF: Invalid slot."
Just (_,value) -> go (push [slot]) subCursor value
_ ->
RecordWHNF
typ
name
(zipWith (\index (fname,slot) ->
(valueType slot,fname,push (cursor ++ [index])))
[0 ..]
slots)
ListValue ty slots ->
case cursor of
(slot:subCursor) ->
case slot of
0 ->
case slots of
(value0:_) -> go (push [slot]) subCursor value0
_ -> ListEndWHNF ty
_ ->
case slots of
(_:value1) ->
go (push [slot])
subCursor
(ListValue ty value1)
_ -> ListEndWHNF ty
_ ->
case slots of
[] -> ListEndWHNF ty
(_:_) ->
ListConsWHNF ty
(push cursor ++ [0])
(push cursor ++ [1])
TupleValue ty slots ->
case cursor of
(slot:subCursor) ->
case lookup slot (zip [0 ..] slots) of
Nothing -> error "toWHNF: Invalid slot."
Just value -> go (push [slot]) subCursor value
_ ->
TupleWHNF ty
(zipWith (\index slot ->
(valueType slot
,push (cursor ++ [index])))
[0 ..]
slots)
TypeVariableValue ty -> TypeVariableWHNF ty
PrimitiveValue ty -> PrimitiveWHNF ty
FunctionValue ty -> FunctionWHNF ty
CharValue ty ch -> CharWHNF ty ch
IntegerValue ty rep -> IntegerWHNF ty rep
StringValue ty str -> StringWHNF ty str
ExceptionValue ty c -> ExceptionWHNF ty c
where push xs = stack ++ xs
valueType :: Value -> String
valueType =
\case
DataValue ty _ _ -> ty
TypeVariableValue ty -> ty
PrimitiveValue ty -> ty
FunctionValue ty -> ty
CharValue ty _ -> ty
IntegerValue ty _ -> ty
ChoiceValue ty _ -> ty
RecordValue ty _ _ -> ty
ListValue ty _ -> ty
StringValue ty _ -> ty
TupleValue ty _ -> ty
ExceptionValue ty _ -> ty
whnfJson :: WHNF -> String
whnfJson =
\case
DataWHNF ty name slots ->
jsonObject
[("constructor",jsonString "data")
,("type",jsonString ty)
,("name",jsonString name)
,("slots"
,jsonList (map (\(typ,sid) ->
jsonObject
[("type",jsonString typ)
,("id",jsonList (map jsonInteger sid))])
slots))]
TypeVariableWHNF var ->
jsonObject
[("constructor",jsonString "type-variable"),("type",jsonString var)]
PrimitiveWHNF name ->
jsonObject
[("constructor",jsonString "primitive"),("type",jsonString name)]
FunctionWHNF ty ->
jsonObject [("constructor",jsonString "primitive"),("type",jsonString ty)]
CharWHNF ty string ->
jsonObject
[("constructor",jsonString "char")
,("type",jsonString ty)
,("string",jsonString string)]
IntegerWHNF ty string ->
jsonObject
[("constructor",jsonString "integer")
,("type",jsonString ty)
,("string",jsonString string)]
ChoiceWHNF ty slots ->
jsonObject
[("constructor",jsonString "choice")
,("type",jsonString ty)
,("slots"
,jsonList (map (\(typ,sid) ->
jsonObject
[("title",jsonString typ)
,("id",jsonList (map jsonInteger sid))])
slots))]
RecordWHNF ty name slots ->
jsonObject
[("constructor",jsonString "record")
,("type",jsonString ty)
,("name",jsonString name)
,("slots"
,jsonList (map (\(typ,name',sid) ->
jsonObject
[("type",jsonString typ)
,("name",jsonString name')
,("id",jsonList (map jsonInteger sid))])
slots))]
ListConsWHNF typ x xs ->
jsonObject
[("constructor",jsonString "list-cons")
,("type",jsonString typ)
,("car",jsonList (map jsonInteger x))
,("cdr",jsonList (map jsonInteger xs))]
ListEndWHNF typ ->
jsonObject [("constructor",jsonString "list-end"),("type",jsonString typ)]
StringWHNF typ string ->
jsonObject
[("constructor",jsonString "string")
,("type",jsonString typ)
,("string",jsonString string)]
TupleWHNF ty slots ->
jsonObject
[("constructor",jsonString "tuple")
,("type",jsonString ty)
,("slots"
,jsonList (map (\(typ,sid) ->
jsonObject
[("type",jsonString typ)
,("id",jsonList (map jsonInteger sid))])
slots))]
ExceptionWHNF typ shown ->
jsonObject
[("constructor",jsonString "exception")
,("type",jsonString typ)
,("string",jsonString shown)]
where jsonString :: String -> String
jsonString = (\x -> "\"" ++ x ++ "\"") . go
where go s1 =
case s1 of
(x:xs)
| x < '\x20' ->
'\\' :
encControl x
(go xs)
('"':xs) -> '\\' : '"' : go xs
('\\':xs) -> '\\' : '\\' : go xs
(x:xs) -> x : go xs
"" -> ""
encControl x xs =
case x of
'\b' -> 'b' : xs
'\f' -> 'f' : xs
'\n' -> 'n' : xs
'\r' -> 'r' : xs
'\t' -> 't' : xs
_
| x < '\x10' -> 'u' : '0' : '0' : '0' : hexxs
| x < '\x100' -> 'u' : '0' : '0' : hexxs
| x < '\x1000' -> 'u' : '0' : hexxs
| otherwise -> 'u' : hexxs
where hexxs = showHex (fromEnum x) xs
jsonObject fields =
"{" ++
intercalate ", "
(map makeField fields) ++
"}"
where makeField (name,value) = jsonString name ++ ": " ++ value
jsonList xs = "[" ++ intercalate ", " xs ++ "]"
jsonInteger :: Integer -> String
jsonInteger = show