├── .gitignore
├── LICENSE
├── README.md
├── install-to-global-db.sh
├── present.cabal
├── remove-from-global-db.sh
├── src
    ├── Present.hs
    └── test
    │   └── tests.ghci
├── stack.yaml
├── stack.yaml.lock
└── test
    ├── Lifts.hs
    ├── Main.hs
    └── NormalizeSpec.hs


/.gitignore:
--------------------------------------------------------------------------------
 1 | *.o
 2 | *.hi
 3 | *~
 4 | dist/
 5 | cabal-dev/
 6 | .hsenv
 7 | TAGS
 8 | tags
 9 | *.tag
10 | .stack-work
11 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2014, present
 2 | All rights reserved.
 3 | 
 4 | Redistribution and use in source and binary forms, with or without
 5 | modification, are permitted provided that the following conditions are met:
 6 |     * Redistributions of source code must retain the above copyright
 7 |       notice, this list of conditions and the following disclaimer.
 8 |     * Redistributions in binary form must reproduce the above copyright
 9 |       notice, this list of conditions and the following disclaimer in the
10 |       documentation and/or other materials provided with the distribution.
11 |     * Neither the name of present nor the
12 |       names of its contributors may be used to endorse or promote products
13 |       derived from this software without specific prior written permission.
14 | 
15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
18 | DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
25 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | present
  2 | =======
  3 | 
  4 | Make presentations for data types.
  5 | 
  6 | ## Install
  7 | 
  8 | Requires: GHC 7.10.3
  9 | 
 10 | Install globally into your GHC's global database (via stack) with:
 11 | 
 12 | ```
 13 | $ sh install-to-global-db.sh
 14 | ```
 15 | 
 16 | To remove it later:
 17 | 
 18 | ```
 19 | $ sh remove-from-global-db.sh
 20 | ```
 21 | 
 22 | To be added: install via `stack install present`, but it needs to be
 23 | added to an LTS/nightly version first.
 24 | 
 25 | ## Customizing GHCi
 26 | 
 27 | Add to the following to your `~/.ghci`:
 28 | 
 29 | ``` haskell
 30 | :seti -XTemplateHaskell
 31 | :def presentDebug \e -> return ("let it = " ++ e ++ "\n$(Present.presentIt)")
 32 | :def presentQualified \e -> return ("let it = " ++ e ++ "\nPrelude.putStrLn (Present.toShow True $(Present.presentIt))")
 33 | :def present \e -> return ("let it = " ++ e ++ "\nPrelude.putStrLn (Present.toShow False $(Present.presentIt))")
 34 | :set -package present
 35 | ```
 36 | 
 37 | ## Usage
 38 | 
 39 | ``` haskell
 40 | bash-3.2$ stack exec ghci
 41 | GHCi, version 7.10.3: http://www.haskell.org/ghc/  :? for help
 42 | package flags have changed, resetting and loading new packages...
 43 | λ> :present "hi"
 44 | "hi"
 45 | 
 46 | λ> :present 123
 47 | 123
 48 | 
 49 | λ> :present (5.2,"hi",1,'a')
 50 | (5.2,"hi",1,'a')
 51 | 
 52 | λ> data X a = X a Int
 53 | 
 54 | λ> :present X 5 1
 55 | X 5 1
 56 | 
 57 | λ> :present S88.pack "hi"
 58 | "hi"
 59 | 
 60 | λ> :present print
 61 | <a_0 -> GHC.Types.IO ()>
 62 | 
 63 | λ> :present print ()
 64 | IO (<GHC.Prim.State# GHC.Prim.RealWorld -> (GHC.Prim.State# GHC.Prim.RealWorld, a_0)>)
 65 | 
 66 | λ> :present undefined
 67 | <_ :: t_0>
 68 | 
 69 | λ> :present id
 70 | <a_0 -> a_0>
 71 | 
 72 | λ> :present [undefined]
 73 | [<_ :: t_0>]
 74 | 
 75 | ```
 76 | 
 77 | ## Extension
 78 | 
 79 | You can write your own instances like this:
 80 | 
 81 | ``` haskell
 82 | λ> data X = X Int
 83 | λ> :present X 5
 84 | X 5
 85 | λ> instance Present0 X where present0 = ("X",\(X x) -> IntegerPresentation "X" (show x))
 86 | λ> :present X 5
 87 | 5
 88 | ```
 89 | 
 90 | ## Detailed output
 91 | 
 92 | ``` haskell
 93 | λ> :presentDebug (2.5,"hi",1,'a')
 94 | TuplePresentation
 95 |   "(GHC.Types.Double,GHC.Base.String,GHC.Integer.Type.Integer,GHC.Types.Char)"
 96 |   [ChoicePresentation
 97 |      "GHC.Types.Double"
 98 |      [("Floating",IntegerPresentation "GHC.Types.Double" "2.5")
 99 |      ,("Show",IntegerPresentation "GHC.Types.Double" "2.5")
100 |      ,("Rational",IntegerPresentation "GHC.Types.Double" "5/2")
101 |      ,("Internal"
102 |       ,DataTypePresentation "GHC.Types.Double"
103 |                             "GHC.Types.D#"
104 |                             [PrimitivePresentation "GHC.Prim.Double#"])]
105 |   ,ChoicePresentation
106 |      "String"
107 |      [("String",StringPresentation "String" "hi")
108 |      ,("List of characters"
109 |       ,ListPresentation
110 |          "[GHC.Types.Char]"
111 |          [ChoicePresentation
112 |             "GHC.Types.Char"
113 |             [("Character",CharPresentation "GHC.Types.Char" "h")
114 |             ,("Unicode point"
115 |              ,ChoicePresentation
116 |                 "GHC.Types.Char"
117 |                 [("Decimal",IntegerPresentation "GHC.Types.Char" "104")
118 |                 ,("Hexadecimal",IntegerPresentation "GHC.Types.Char" "68")
119 |                 ,("Binary",IntegerPresentation "GHC.Types.Char" "1101000")])
120 |             ,("Internal"
121 |              ,DataTypePresentation "GHC.Types.Char"
122 |                                    "GHC.Types.C#"
123 |                                    [PrimitivePresentation "GHC.Prim.Char#"])]
124 |          ,ChoicePresentation
125 |             "GHC.Types.Char"
126 |             [("Character",CharPresentation "GHC.Types.Char" "i")
127 |             ,("Unicode point"
128 |              ,ChoicePresentation
129 |                 "GHC.Types.Char"
130 |                 [("Decimal",IntegerPresentation "GHC.Types.Char" "105")
131 |                 ,("Hexadecimal",IntegerPresentation "GHC.Types.Char" "69")
132 |                 ,("Binary",IntegerPresentation "GHC.Types.Char" "1101001")])
133 |             ,("Internal"
134 |              ,DataTypePresentation "GHC.Types.Char"
135 |                                    "GHC.Types.C#"
136 |                                    [PrimitivePresentation "GHC.Prim.Char#"])]])]
137 |   ,ChoicePresentation
138 |      "GHC.Integer.Type.Integer"
139 |      [("Decimal",IntegerPresentation "GHC.Integer.Type.Integer" "1")
140 |      ,("Hexadecimal",IntegerPresentation "GHC.Integer.Type.Integer" "1")
141 |      ,("Binary",IntegerPresentation "GHC.Integer.Type.Integer" "1")
142 |      ,("Internal"
143 |       ,DataTypePresentation "GHC.Integer.Type.Integer"
144 |                             "GHC.Integer.Type.S#"
145 |                             [PrimitivePresentation "GHC.Prim.Int#"])]
146 |   ,ChoicePresentation
147 |      "GHC.Types.Char"
148 |      [("Character",CharPresentation "GHC.Types.Char" "a")
149 |      ,("Unicode point"
150 |       ,ChoicePresentation
151 |          "GHC.Types.Char"
152 |          [("Decimal",IntegerPresentation "GHC.Types.Char" "97")
153 |          ,("Hexadecimal",IntegerPresentation "GHC.Types.Char" "61")
154 |          ,("Binary",IntegerPresentation "GHC.Types.Char" "1100001")])
155 |      ,("Internal"
156 |       ,DataTypePresentation "GHC.Types.Char"
157 |                             "GHC.Types.C#"
158 |                             [PrimitivePresentation "GHC.Prim.Char#"])]]
159 | ```
160 | 


--------------------------------------------------------------------------------
/install-to-global-db.sh:
--------------------------------------------------------------------------------
1 | # Installs globally to your GHC's global package database
2 | 
3 | stack install
4 | 
5 | stack exec --no-ghc-package-path -- runhaskell Setup.hs clean
6 | stack exec --no-ghc-package-path -- runhaskell Setup.hs configure --package-db $(stack path --global-pkg-db) --prefix=$(stack path --ghc-paths)/ghc-$(stack exec -- ghc --numeric-version)
7 | stack exec --no-ghc-package-path -- runhaskell Setup.hs build
8 | stack exec --no-ghc-package-path -- runhaskell Setup.hs install
9 | 


--------------------------------------------------------------------------------
/present.cabal:
--------------------------------------------------------------------------------
 1 | name:                present
 2 | version:             4.2.0
 3 | synopsis:            Make presentations for data types.
 4 | description:         Make presentations for data types.
 5 | homepage:            https://github.com/chrisdone/present
 6 | license:             BSD3
 7 | license-file:        LICENSE
 8 | author:              Chris Done
 9 | maintainer:          chrisdone@gmail.com
10 | copyright:           2016-2021 Chris Done
11 | category:            Development
12 | build-type:          Simple
13 | cabal-version:       >=1.8
14 | extra-source-files: README.md
15 | 
16 | library
17 |   hs-source-dirs:    src/
18 |   ghc-options:       -Wall
19 |   exposed-modules:   Present
20 |   build-depends:     base >= 4 && <5
21 |                    , template-haskell
22 |                    , transformers
23 | 
24 | test-suite present-test
25 |   type: exitcode-stdio-1.0
26 |   hs-source-dirs: test/
27 |   main-is: Main.hs
28 |   other-modules: NormalizeSpec, Lifts
29 |   build-depends: base, hspec, present, template-haskell, th-lift, transformers
30 | 


--------------------------------------------------------------------------------
/remove-from-global-db.sh:
--------------------------------------------------------------------------------
1 | stack exec -- ghc-pkg --package-db $(stack path --global-pkg-db) unregister present
2 | 


--------------------------------------------------------------------------------
/src/Present.hs:
--------------------------------------------------------------------------------
   1 | {-# LANGUAGE FlexibleContexts #-}
   2 | {-# LANGUAGE OverloadedStrings #-}
   3 | {-# LANGUAGE PatternGuards #-}
   4 | {-# LANGUAGE TupleSections #-}
   5 | {-# LANGUAGE TemplateHaskell #-}
   6 | {-# LANGUAGE LambdaCase #-}
   7 | 
   8 | -- | Generate presentations for types.
   9 | 
  10 | module Present
  11 |   (-- * Presenting functions
  12 |    presentIt
  13 |   ,presentName
  14 |   ,presentType
  15 |   -- * Presentation mediums
  16 |   ,toShow
  17 |   ,toWHNF
  18 |   ,whnfJson
  19 |   -- * Debugging convenience functions
  20 |   ,presentShow
  21 |   -- * Types
  22 |   ,Value(..)
  23 |   ,WHNF(..)
  24 |   -- * Customization classes
  25 |   ,Present0(..)
  26 |   ,Present1(..)
  27 |   ,Present2(..)
  28 |   ,Present3(..)
  29 |   ,Present4(..)
  30 |   ,Present5(..)
  31 |   ,Present6(..)
  32 |    -- * Internals
  33 |   ,normalizeType
  34 |   ,NormalType(..)
  35 |   ,TypeConstructor(..)
  36 |   )
  37 |   where
  38 | 
  39 | import           Control.Arrow (second)
  40 | import           Control.Exception (evaluate,SomeException(..),try,evaluate)
  41 | import           Control.Monad (forM)
  42 | import           Control.Monad.Trans.State.Strict (evalStateT,get,modify,StateT(..))
  43 | import           Data.Char (isSpace,ord,isAlphaNum)
  44 | import           Data.Int (Int8,Int16,Int32,Int64)
  45 | import           Data.List (nub,find,intercalate,foldl',isSuffixOf)
  46 | import           Data.Maybe (mapMaybe,isJust)
  47 | import           Data.Ratio (numerator,denominator)
  48 | import           Data.String (IsString)
  49 | import           Data.Typeable (typeOf)
  50 | import           Data.Word (Word8,Word32,Word64)
  51 | import           Foreign.ForeignPtr
  52 | import           Foreign.Ptr
  53 | import           Numeric (showHex)
  54 | import           System.IO.Unsafe (unsafePerformIO)
  55 | import           Text.Printf (printf)
  56 | 
  57 | import qualified Language.Haskell.TH as TH
  58 | import qualified Language.Haskell.TH.Syntax as TH
  59 | 
  60 | --------------------------------------------------------------------------------
  61 | -- Introduction
  62 | --
  63 | -- Present's algorithm works in stages/levels of work. The first
  64 | -- implementation of Present worked, but was a mess. This
  65 | -- implementation is an effort to separate all that functionality into
  66 | -- clean, small stages.
  67 | 
  68 | --------------------------------------------------------------------------------
  69 | -- Type Normalization
  70 | --
  71 | -- TH's representation of types is wider than what Present cares
  72 | -- about, and has some heterogeneity that is unwanted; it adds some
  73 | -- messiness. To simplify the code further down, we perform this
  74 | -- transformation to simplify the types and therefore the scope we
  75 | -- have to deal with.
  76 | --
  77 | -- TH's representation of names is also unfortunate, as it mixes up
  78 | -- variables, types and type variables all together. We address that
  79 | -- too.
  80 | 
  81 | -- | A type variable.
  82 | newtype TypeVariable =
  83 |   TypeVariable TH.Name
  84 |   deriving (Eq, Show)
  85 | 
  86 | -- | A type constructor.
  87 | newtype TypeConstructor =
  88 |   TypeConstructor TH.Name
  89 |   deriving (Eq, Show)
  90 | 
  91 | -- | A primitive type constructor.
  92 | newtype PrimitiveTypeConstructor =
  93 |   PrimitiveTypeConstructor TH.Name
  94 |   deriving (Eq, Show)
  95 | 
  96 | -- | A normalized type.
  97 | data NormalType
  98 |   = NormalCons TypeConstructor
  99 |   | NormalPrimitive PrimitiveTypeConstructor
 100 |   | NormalFunction TH.Type
 101 |   | NormalVar TypeVariable
 102 |   | NormalApp NormalType
 103 |               [NormalType]
 104 |   deriving (Eq, Show)
 105 | 
 106 | 
 107 | -- | Convert the heterogenous TH type into a more normal form.
 108 | normalizeType
 109 |   :: TH.Type -> Either String NormalType
 110 | normalizeType = go
 111 |   where go =
 112 |           \case
 113 |             ty@TH.AppT{} ->
 114 |               do let (typeFunction,typeArguments) = flattenApplication ty
 115 |                  case typeFunction of
 116 |                    TH.ArrowT -> return (NormalFunction ty)
 117 |                    _ -> NormalApp <$> go typeFunction <*> mapM go typeArguments
 118 |             TH.ForallT _ context ty ->
 119 |               if isFunction ty
 120 |                  then return (NormalFunction ty)
 121 |                  else go (typeClassDefaulting context ty)
 122 |             TH.SigT ty _kind -> go ty
 123 |             -- Oh, crap. I don't know the type of the type variable here. We're screwed.
 124 |             TH.VarT name -> return (NormalVar (TypeVariable name))
 125 |             TH.ConT name ->
 126 |               return (if isPrimitiveType name
 127 |                          then NormalPrimitive (PrimitiveTypeConstructor name)
 128 |                          else NormalCons (TypeConstructor name))
 129 |             TH.TupleT i ->
 130 |               case lookup i tupleConstructors of
 131 |                 Nothing -> Left ("Tuple arity " ++ show i ++ " not supported.")
 132 |                 Just cons -> return (NormalCons (TypeConstructor cons))
 133 |             TH.ListT -> return (NormalCons (TypeConstructor ''[]))
 134 |             TH.PromotedT _ -> Left "Promoted types are not supported."
 135 |             TH.UnboxedTupleT _ -> Left "Unboxed tuples are not supported."
 136 |             TH.ArrowT -> Left "The function arrow (->) is not supported."
 137 |             TH.EqualityT -> Left "Equalities are not supported."
 138 |             TH.PromotedTupleT _ -> Left "Promoted types are not supported."
 139 |             TH.PromotedNilT -> Left "Promoted types are not supported."
 140 |             TH.PromotedConsT -> Left "Promoted types are not supported."
 141 |             TH.StarT -> Left "Star (*) is not supported."
 142 |             TH.ConstraintT -> Left "Constraints are not supported."
 143 |             TH.LitT _ -> Left "Type-level literals are not supported."
 144 |             TH.InfixT{} -> Left "Infix type constructors are not supported."
 145 |             TH.UInfixT{} -> Left "Unresolved infix type constructors are not supported."
 146 |             TH.ParensT _ -> Left "Parenthesized types are not supported."
 147 |             TH.WildCardT -> Left "Wildcard types are not supported."
 148 |             TH.ForallVisT{} -> Left "Forall vis not supported."
 149 |             TH.AppKindT{} -> Left "App kind not supported."
 150 |             TH.UnboxedSumT{} -> Left "Unboxed sums not supported."
 151 |             TH.ImplicitParamT{} -> Left "Unboxed sums not supported."
 152 | 
 153 | -- | Is the type a function?
 154 | isFunction :: TH.Type -> Bool
 155 | isFunction ty =
 156 |   let (typeFunction,_) = flattenApplication ty
 157 |   in case typeFunction of
 158 |        TH.ArrowT -> True
 159 |        _ -> False
 160 | 
 161 | -- | Arity-constructor mapping for tuples.
 162 | tupleConstructors :: [(Int,TH.Name)]
 163 | tupleConstructors =
 164 |   [(0,''())
 165 |   ,(2,''(,))
 166 |   ,(3,''(,,))
 167 |   ,(4,''(,,,))
 168 |   ,(5,''(,,,,))
 169 |   ,(6,''(,,,,,))
 170 |   ,(7,''(,,,,,,))
 171 |   ,(8,''(,,,,,,,))
 172 |   ,(9,''(,,,,,,,,))
 173 |   ,(10,''(,,,,,,,,,))
 174 |   ,(11,''(,,,,,,,,,,))
 175 |   ,(12,''(,,,,,,,,,,,))
 176 |   ,(13,''(,,,,,,,,,,,,))
 177 |   ,(14,''(,,,,,,,,,,,,,))
 178 |   ,(15,''(,,,,,,,,,,,,,,))
 179 |   ,(16,''(,,,,,,,,,,,,,,,))
 180 |   ,(17,''(,,,,,,,,,,,,,,,,))
 181 |   ,(18,''(,,,,,,,,,,,,,,,,,))
 182 |   ,(19,''(,,,,,,,,,,,,,,,,,,))
 183 |   ,(20,''(,,,,,,,,,,,,,,,,,,,))
 184 |   ,(21,''(,,,,,,,,,,,,,,,,,,,,))
 185 |   ,(22,''(,,,,,,,,,,,,,,,,,,,,,))
 186 |   ,(23,''(,,,,,,,,,,,,,,,,,,,,,,))
 187 |   ,(24,''(,,,,,,,,,,,,,,,,,,,,,,,))
 188 |   ,(25,''(,,,,,,,,,,,,,,,,,,,,,,,,))
 189 |   ,(26,''(,,,,,,,,,,,,,,,,,,,,,,,,,))]
 190 | 
 191 | -- | Is the name specified by Name a primitive type? Like Int#?
 192 | --
 193 | -- This check may be overly cautious, but it's also about as accurate
 194 | -- as one can seemingly be.
 195 | isPrimitiveType :: TH.Name -> Bool
 196 | isPrimitiveType (TH.Name (TH.OccName _) (TH.NameG TH.TcClsName (TH.PkgName "ghc-prim") (TH.ModName "GHC.Prim"))) =
 197 |   True
 198 | isPrimitiveType name = isSuffixOf "#" (show name)
 199 | 
 200 | -- | Flatten a type application f x y into (f,[x,y]).
 201 | flattenApplication
 202 |   :: TH.Type -> (TH.Type,[TH.Type])
 203 | flattenApplication = go []
 204 |   where go args (TH.AppT f x) = go (x : args) f
 205 |         go args f = (f,args)
 206 | 
 207 | --------------------------------------------------------------------------------
 208 | -- Defaulting
 209 | --
 210 | -- For some classes like Num and IsString, we can default to a
 211 | -- reasonable value in the REPL. It leads to a better user-experience.
 212 | 
 213 | -- | Apply defaulted substitutions for each of the constraints in the
 214 | -- type.
 215 | typeClassDefaulting
 216 |   :: [TH.Type] -> TH.Type -> TH.Type
 217 | typeClassDefaulting constraints =
 218 |   applyTypeSubstitution
 219 |     (mapMaybe (\case
 220 |                  TH.AppT (TH.ConT className) (TH.VarT varName) ->
 221 |                    fmap (\tyName -> (varName,TH.ConT tyName))
 222 |                         (lookup className defaultedClasses)
 223 |                  _ -> Nothing)
 224 |               constraints)
 225 | 
 226 | -- | Apply the given substitutions to the type.
 227 | applyTypeSubstitution
 228 |   :: [(TH.Name,TH.Type)] -> TH.Type -> TH.Type
 229 | applyTypeSubstitution subs = go
 230 |   where go =
 231 |           \case
 232 |             TH.ForallT vars ctx ty ->
 233 |               TH.ForallT vars
 234 |                          ctx
 235 |                          (go ty)
 236 |             TH.AppT f x ->
 237 |               TH.AppT (go f)
 238 |                       (go x)
 239 |             TH.SigT ty k -> TH.SigT (go ty) k
 240 |             TH.VarT a
 241 |               | Just b <- lookup a subs -> b
 242 |               | otherwise -> TH.VarT a
 243 |             x -> x
 244 | 
 245 | -- | Classes which when encountered in a forall context should have
 246 | -- their corresponding type variables substituted on the right hand
 247 | -- side with the given type.
 248 | defaultedClasses :: [(TH.Name,TH.Name)]
 249 | defaultedClasses =
 250 |   [(''Integral,''Integer)
 251 |   ,(''Num,''Integer)
 252 |   ,(''Fractional,''Double)
 253 |   ,(''Bounded,''())
 254 |   ,(''Eq,''())
 255 |   ,(''Read,''())
 256 |   ,(''Show,''())
 257 |   ,(''IsString,''String)]
 258 | 
 259 | --------------------------------------------------------------------------------
 260 | -- Type Enumeration
 261 | --
 262 | -- Given a NormalType, we extract all the instances of NormalCons into
 263 | -- a flat set.
 264 | --
 265 | -- We can then run through each type constructor name, reify them, and
 266 | -- generate a printer for it. This separate step avoids cycles/acts as
 267 | -- an alternative to performing an occurs check.
 268 | 
 269 | -- | Enumerate all unique type constructors in the type.
 270 | enumerateTypeConstructors
 271 |   :: NormalType -> [TypeConstructor]
 272 | enumerateTypeConstructors = nub . go
 273 |   where go =
 274 |           \case
 275 |             NormalCons cons -> [cons]
 276 |             NormalApp ty tys -> go ty ++ concatMap go tys
 277 |             NormalPrimitive{} -> []
 278 |             NormalVar{} -> []
 279 |             NormalFunction{} -> []
 280 | 
 281 | --------------------------------------------------------------------------------
 282 | -- Type Reification
 283 | --
 284 | -- We have to reify all the type constructors involved in a given
 285 | -- type.
 286 | --
 287 | 
 288 | -- | Name of a variable.
 289 | newtype ValueVariable =
 290 |   ValueVariable TH.Name
 291 | 
 292 | -- | Name of a value constructor.
 293 | newtype ValueConstructor =
 294 |   ValueConstructor TH.Name
 295 | 
 296 | -- | A normalize representation of a constructor. Present's main
 297 | -- algorithm doesn't particularly care whether it's infix, a record,
 298 | -- or whatever.
 299 | data Constructor =
 300 |   Constructor {_constructorName :: ValueConstructor
 301 |               ,constructorFields :: [(Maybe ValueVariable,NormalType)]}
 302 | 
 303 | -- | A data type.
 304 | data DataType =
 305 |   DataType {_dataTypeVariables :: [TypeVariable]
 306 |            ,_dataTypeConstructors :: [Constructor]}
 307 | 
 308 | -- | A type alias.
 309 | data TypeAlias =
 310 |   TypeAlias {_aliasVariables :: [TypeVariable]
 311 |             ,_aliasType :: NormalType}
 312 | 
 313 | -- | Definition of a type.
 314 | data TypeDefinition
 315 |   = DataTypeDefinition TypeConstructor
 316 |                        DataType
 317 |   | TypeAliasDefinition TypeConstructor
 318 |                         TypeAlias
 319 | 
 320 | -- | Reify all the constructors of a name. Unless it's primitive, in
 321 | -- which case return nothing.
 322 | reifyTypeDefinition
 323 |   :: TypeConstructor -> TH.Q (Maybe TypeDefinition)
 324 | reifyTypeDefinition typeConstructor@(TypeConstructor name) =
 325 |   do info <- TH.reify name
 326 |      let result =
 327 |            case info of
 328 |              TH.TyConI dec ->
 329 |                case dec of
 330 |                  TH.DataD _cxt0 _ vars _mkind cons _cxt1 ->
 331 |                    do cs <- concat <$> mapM makeConstructors cons
 332 |                       return (Just (DataTypeDefinition typeConstructor
 333 |                                                        (DataType (map toTypeVariable vars) cs)))
 334 |                  TH.NewtypeD _cxt0 _ vars _mkind con _cxt1 ->
 335 |                    do cs <- makeConstructors con
 336 |                       return (Just (DataTypeDefinition
 337 |                                       typeConstructor
 338 |                                       (DataType (map toTypeVariable vars)
 339 |                                                 cs)))
 340 |                  TH.TySynD _ vars ty ->
 341 |                    do ty' <- normalizeType ty
 342 |                       return (Just (TypeAliasDefinition typeConstructor
 343 |                                                         (TypeAlias (map toTypeVariable vars) ty')))
 344 |                  _ -> Left "Not a supported data type declaration."
 345 |              TH.PrimTyConI{} -> return Nothing
 346 |              TH.FamilyI{} -> Left "Data families not supported yet."
 347 |              _ ->
 348 |                Left ("Not a supported object, no type inside it: " ++
 349 |                      TH.pprint info)
 350 |      case result of
 351 |        Left err -> fail err
 352 |        Right ok -> return ok
 353 | 
 354 | -- | Convert a TH type variable to a normalized type variable.
 355 | toTypeVariable :: TH.TyVarBndr -> TypeVariable
 356 | toTypeVariable =
 357 |   \case
 358 |     TH.PlainTV t -> TypeVariable t
 359 |     TH.KindedTV t _ -> TypeVariable t
 360 | 
 361 | -- | Make a normalized constructor from the more complex TH Con.
 362 | makeConstructors
 363 |   :: TH.Con -> Either String [Constructor]
 364 | makeConstructors =
 365 |   \case
 366 |     TH.NormalC name slots ->
 367 |       (:[]) <$> makeConstructor name (mapM makeSlot slots)
 368 |     TH.RecC name fields ->
 369 |       (:[]) <$> makeConstructor name (mapM makeField fields)
 370 |     TH.InfixC t1 name t2 ->
 371 |       (:[]) <$> makeConstructor name ((\x y -> [x,y]) <$> makeSlot t1 <*> makeSlot t2)
 372 |     (TH.ForallC _ _ con) ->
 373 |       makeConstructors con
 374 |     TH.GadtC names slots _type ->
 375 |       forM names $ \name ->
 376 |         makeConstructor name (mapM makeSlot slots)
 377 |     TH.RecGadtC names fields _type ->
 378 |       forM names $ \name ->
 379 |         makeConstructor name (mapM makeField fields)
 380 |   where makeConstructor name efields = Constructor (ValueConstructor name) <$> efields
 381 |         makeSlot (_,ty) = (Nothing,) <$> normalizeType ty
 382 |         makeField (name,_,ty) =
 383 |           (Just (ValueVariable name),) <$> normalizeType ty
 384 | 
 385 | --------------------------------------------------------------------------------
 386 | -- Definition Elaboration
 387 | --
 388 | -- When reifying a type, we discover that it refers to other types
 389 | -- which in turn need to be reified. So to get the total of all types
 390 | -- that we're going to want to generate a printer for, we need to
 391 | -- recursively elaborate everything all the way down.
 392 | --
 393 | -- A primitive type definition does not decompose into other types.
 394 | 
 395 | -- | Elaborate the types involved in a type definition.
 396 | definitionNormalTypes
 397 |   :: TypeDefinition -> [NormalType]
 398 | definitionNormalTypes =
 399 |   \case
 400 |     DataTypeDefinition _ (DataType _ cons) ->
 401 |       concatMap (map snd . constructorFields) cons
 402 |     TypeAliasDefinition _ (TypeAlias _ ty) -> [ty]
 403 | 
 404 | --------------------------------------------------------------------------------
 405 | -- Complete Expansion
 406 | --
 407 | -- Finally, we need a way to, given a type, completely explode that
 408 | -- type, and every type inside it, recursively, to produce a finite,
 409 | -- unique set of TypeDefinitions.
 410 | 
 411 | -- | Expand a type into all the type definitions directly or
 412 | -- indirectly related.
 413 | normalTypeDefinitions
 414 |   :: NormalType -> TH.Q [TypeDefinition]
 415 | normalTypeDefinitions = flip evalStateT [] . expandNormalType
 416 |   where expandNormalType =
 417 |           fmap concat . mapM expandTypeConstructor . enumerateTypeConstructors
 418 |         expandTypeConstructor typeConstructor =
 419 |           do seenConstructors <- get
 420 |              if elem typeConstructor seenConstructors
 421 |                 then return []
 422 |                 else do mtypeDefinition <-
 423 |                           liftQ (reifyTypeDefinition typeConstructor)
 424 |                         case mtypeDefinition of
 425 |                           Nothing -> return []
 426 |                           Just typeDefinition ->
 427 |                             do let normalTypes =
 428 |                                      definitionNormalTypes typeDefinition
 429 |                                modify (typeConstructor :)
 430 |                                typeDefinitions <-
 431 |                                  fmap concat (mapM expandNormalType normalTypes)
 432 |                                return (typeDefinition : typeDefinitions)
 433 | 
 434 | -- | Lift a Q monad into a StateT transformer.
 435 | liftQ :: TH.Q a -> StateT s TH.Q a
 436 | liftQ m =
 437 |   StateT (\s ->
 438 |             do v <- m
 439 |                return (v,s))
 440 | 
 441 | --------------------------------------------------------------------------------
 442 | -- Printer Generation
 443 | --
 444 | -- Given a TypeDefinition, generate a printer for that data type.
 445 | 
 446 | data Value
 447 |   = DataValue String String [Value]
 448 |   | TypeVariableValue String
 449 |   | PrimitiveValue String
 450 |   | FunctionValue String
 451 |   | CharValue String String
 452 |   | IntegerValue String String
 453 |   | ChoiceValue String [(String,Value)]
 454 |   | RecordValue String String [(String,Value)]
 455 |   | ListValue String [Value]
 456 |   | StringValue String String
 457 |   | TupleValue String [Value]
 458 |   | ExceptionValue String String
 459 |   deriving (Show)
 460 | 
 461 | -- | Make a presenter for a type definition.
 462 | typeDefinitionPresenter :: [(TypeConstructor,ValueVariable)]
 463 |                         -> TypeDefinition
 464 |                         -> TH.Q [TH.Dec]
 465 | typeDefinitionPresenter instances =
 466 |   \case
 467 |     DataTypeDefinition typeConstructor dataType@(DataType typeVariables _) ->
 468 |       case find (namesBasicallyEqual typeConstructor . fst) instances of
 469 |         Nothing ->
 470 |           case find (namesBasicallyEqual typeConstructor . fst) builtInPresenters of
 471 |             Nothing -> dataTypePresenter typeConstructor dataType
 472 |             Just (_,presenter) ->
 473 |               do automaticPresenter <-
 474 |                    dataTypePresenterBody typeConstructor dataType
 475 |                  builtinFunctionDeclaration typeConstructor
 476 |                                             (presenter typeVariables automaticPresenter)
 477 |         Just (_,methodName) ->
 478 |           do instanceBasedPresenter typeConstructor methodName dataType typeVariables
 479 |     TypeAliasDefinition typeConstructor typeAlias ->
 480 |       typeAliasPresenter typeConstructor typeAlias
 481 | 
 482 | -- | Make a printer based on an instance declaration for Present[N].
 483 | instanceBasedPresenter :: TypeConstructor
 484 |                        -> ValueVariable
 485 |                        -> DataType
 486 |                        -> [TypeVariable]
 487 |                        -> TH.Q [TH.Dec]
 488 | instanceBasedPresenter typeConstructor@(TypeConstructor typeConstructorName) (ValueVariable methodName) dataType typeVariables =
 489 |   presentingFunctionDeclaration
 490 |     typeConstructor
 491 |     typeVariables
 492 |     (TH.tupE [typeDisplayExpression
 493 |              ,[|\x ->
 494 |                   ChoiceValue
 495 |                     $(typeDisplayExpression)
 496 |                     [("Instance"
 497 |                      ,snd $(foldl TH.appE
 498 |                                   (TH.varE methodName)
 499 |                                   (map (TH.varE . presentVarName) typeVariables))
 500 |                           x)
 501 |                     ,("Internal"
 502 |                      ,$(dataTypePresenterBody typeConstructor dataType) x)]|]])
 503 |   where typeDisplayExpression = typeDisplay typeVariables typeConstructorName
 504 | 
 505 | -- | Make a presenter for the given data type.
 506 | dataTypePresenter
 507 |   :: TypeConstructor -> DataType -> TH.Q [TH.Dec]
 508 | dataTypePresenter typeConstructor@(TypeConstructor typeConstructorName) dataType@(DataType typeVariables _) =
 509 |   presentingFunctionDeclaration
 510 |     typeConstructor
 511 |     typeVariables
 512 |     (TH.tupE [typeDisplayExpression
 513 |              ,dataTypePresenterBody typeConstructor dataType])
 514 |   where typeDisplayExpression = typeDisplay typeVariables typeConstructorName
 515 | 
 516 | -- | Make a printer for a data type, just the expression part.
 517 | dataTypePresenterBody
 518 |   :: TypeConstructor -> DataType -> TH.Q TH.Exp
 519 | dataTypePresenterBody (TypeConstructor typeConstructorName) (DataType typeVariables constructors) =
 520 |   TH.lamCaseE (map constructorCase constructors)
 521 |   where typeDisplayExpression = typeDisplay typeVariables typeConstructorName
 522 |         constructorCase (Constructor (ValueConstructor valueConstructorName) fields) =
 523 |           TH.match (TH.conP valueConstructorName (map (return . fieldPattern) indexedFields))
 524 |                    (TH.normalB
 525 |                       (TH.appE presentationConstructor (TH.listE (map fieldPresenter indexedFields))))
 526 |                    []
 527 |           where presentationConstructor =
 528 |                   if isTuple typeConstructorName
 529 |                      then TH.appE (TH.conE 'TupleValue) typeDisplayExpression
 530 |                      else TH.appE (TH.appE (TH.conE (if any (isJust . fst) fields &&
 531 |                                                         not (null fields)
 532 |                                                         then 'RecordValue
 533 |                                                         else 'DataValue))
 534 |                                            typeDisplayExpression)
 535 |                                   (TH.litE (TH.stringL (TH.pprint valueConstructorName)))
 536 |                 indexedFields = zip (map indexedFieldName [0 ..]) fields
 537 |                 fieldPattern (indexedName,_) = TH.VarP indexedName
 538 |                 fieldPresenter (indexedName,(mvalueVariable,normalType)) =
 539 |                   addField (TH.appE (TH.appE (TH.varE 'snd)
 540 |                                              (expressType typeVariables normalType))
 541 |                                     (TH.varE indexedName))
 542 |                   where addField =
 543 |                           case mvalueVariable of
 544 |                             Nothing -> id
 545 |                             Just (ValueVariable fieldName) ->
 546 |                               \e ->
 547 |                                 TH.tupE [TH.stringE (TH.pprint fieldName),e]
 548 | 
 549 | -- | Generate an expression which displays a data type and its
 550 | -- type variables as instantiated.
 551 | typeDisplay
 552 |   :: [TypeVariable] -> TH.Name -> TH.Q TH.Exp
 553 | typeDisplay typeVariables name =
 554 |   (applyToVars . TH.litE . TH.stringL . TH.pprint) name
 555 |   where applyToVars typeConstructorDisplay
 556 |           | null typeVariables = typeConstructorDisplay
 557 |           | isTuple name =
 558 |             [|("(" ++
 559 |                intercalate
 560 |                  ","
 561 |                  $(TH.listE (map (\typeVariable ->
 562 |                                     TH.appE (TH.varE 'fst)
 563 |                                             (TH.varE (presentVarName typeVariable)))
 564 |                                  typeVariables)) ++
 565 |                ")")|]
 566 |           | otherwise =
 567 |             TH.appE (TH.varE 'unwords)
 568 |                     (TH.infixE (Just (TH.listE [typeConstructorDisplay]))
 569 |                                (TH.varE '(++))
 570 |                                (Just (TH.listE (map (\typeVariable ->
 571 |                                                        TH.appE (TH.varE 'parensIfNeeded)
 572 |                                                                (TH.appE (TH.varE 'fst)
 573 |                                                                         (TH.varE (presentVarName typeVariable))))
 574 |                                                     typeVariables))))
 575 | 
 576 | -- | Is a name a tuple?
 577 | isTuple :: TH.Name -> Bool
 578 | isTuple typeConstructorName =
 579 |   any ((== typeConstructorName) . snd) tupleConstructors
 580 | 
 581 | -- | Add parens to a string if there's a space inside.
 582 | parensIfNeeded :: [Char] -> [Char]
 583 | parensIfNeeded e =
 584 |   if any isSpace e
 585 |      then "(" ++ e ++ ")"
 586 |      else e
 587 | 
 588 | -- | Make a name for an indexed field of a data type constructor.
 589 | indexedFieldName :: Integer -> TH.Name
 590 | indexedFieldName index = TH.mkName ("indexedField_" ++ show index)
 591 | 
 592 | -- | Make a printer for a type-alias. This involves simply proxying to
 593 | -- the real printer, whether that's a data type or a primitive, or
 594 | -- another type-alias.
 595 | typeAliasPresenter
 596 |   :: TypeConstructor -> TypeAlias -> TH.Q [TH.Dec]
 597 | typeAliasPresenter typeConstructor@(TypeConstructor typeConstructorName) (TypeAlias typeVariables normalType) =
 598 |   presentingFunctionDeclaration
 599 |     typeConstructor
 600 |     typeVariables
 601 |     (TH.tupE [TH.litE (TH.stringL (TH.pprint typeConstructorName))
 602 |              ,TH.appE (TH.varE 'snd)
 603 |                       (expressType typeVariables normalType)])
 604 | 
 605 | -- | Make a presenting function.
 606 | builtinFunctionDeclaration
 607 |   :: TypeConstructor -> TH.Q TH.Exp -> TH.Q [TH.Dec]
 608 | builtinFunctionDeclaration typeConstructor body =
 609 |   do dec <-
 610 |        TH.valD (TH.varP name)
 611 |                (TH.normalB body)
 612 |                []
 613 |      return [dec]
 614 |   where name = presentConsName typeConstructor
 615 | 
 616 | -- | Make a presenting function.
 617 | presentingFunctionDeclaration :: TypeConstructor
 618 |                               -> [TypeVariable]
 619 |                               -> TH.Q TH.Exp
 620 |                               -> TH.Q [TH.Dec]
 621 | presentingFunctionDeclaration typeConstructor@(TypeConstructor typeConstructorName) typeVariables body =
 622 |   do sig <-
 623 |        TH.sigD name
 624 |                (TH.forallT
 625 |                   (map (\(TypeVariable typeVariable) -> TH.PlainTV typeVariable) typeVariables)
 626 |                   (return [])
 627 |                   (foldl (\inner (TypeVariable typeVariable) ->
 628 |                             let presentTypeVariable =
 629 |                                   return (TH.AppT (TH.AppT (TH.TupleT 2)
 630 |                                                            (TH.ConT ''String))
 631 |                                                   presenter)
 632 |                                   where presenter =
 633 |                                           TH.AppT (TH.AppT TH.ArrowT (TH.VarT typeVariable))
 634 |                                                   (TH.ConT ''Value)
 635 |                             in TH.appT (TH.appT TH.arrowT presentTypeVariable) inner)
 636 |                          tupleType
 637 |                          (reverse typeVariables)))
 638 |      dec <-
 639 |        if null typeVariables
 640 |           then TH.valD (TH.varP name)
 641 |                        (TH.normalB body)
 642 |                        []
 643 |           else TH.funD name
 644 |                        [TH.clause (map (\typeVariable ->
 645 |                                           TH.varP (presentVarName typeVariable))
 646 |                                        typeVariables)
 647 |                                   (TH.normalB body)
 648 |                                   []]
 649 |      return [sig,dec]
 650 |   where name = presentConsName typeConstructor
 651 |         tupleType =
 652 |           ((\string typ -> TH.AppT (TH.AppT (TH.TupleT 2) string) typ) <$>
 653 |            TH.conT ''String <*>
 654 |            TH.appT (TH.appT TH.arrowT appliedType)
 655 |                    (TH.conT ''Value))
 656 |         appliedType =
 657 |           foldl TH.appT
 658 |                 (TH.conT typeConstructorName)
 659 |                 (map (\(TypeVariable typeVariableName) ->
 660 |                         TH.varT typeVariableName)
 661 |                      typeVariables)
 662 | 
 663 | --------------------------------------------------------------------------------
 664 | -- Built-in printers
 665 | 
 666 | -- | Are the names basically equal, disregarding package id buggerances?
 667 | namesBasicallyEqual
 668 |   :: TypeConstructor -> TypeConstructor -> Bool
 669 | namesBasicallyEqual (TypeConstructor this) (TypeConstructor that) =
 670 |   normalize this == normalize that
 671 |   where normalize n@(TH.Name name flavour) =
 672 |           case flavour of
 673 |             TH.NameG _ _ modName -> TH.Name name (TH.NameQ modName)
 674 |             _ -> n
 675 | 
 676 | -- | Printers for built-in data types with custom representations
 677 | -- (think: primitives, tuples, etc.)
 678 | builtInPresenters
 679 |   :: [(TypeConstructor,[TypeVariable] -> TH.Exp -> TH.Q TH.Exp)]
 680 | builtInPresenters =
 681 |   concat [listPrinters
 682 |          ,integerPrinters
 683 |          ,realPrinters
 684 |          ,charPrinters
 685 |          ,packedStrings
 686 |          ,vectorPrinters
 687 |          ,pointerPrinters]
 688 | 
 689 | -- | Vectors.
 690 | vectorPrinters
 691 |   :: [(TypeConstructor,[TypeVariable] -> TH.Exp -> TH.Q TH.Exp)]
 692 | vectorPrinters =
 693 |   [makeVectorPrinter (qualified "Data.Vector" "Vector")
 694 |                      (qualified "Data.Vector" "toList")]
 695 |   where makeVectorPrinter typeName unpackFunction =
 696 |           (TypeConstructor typeName
 697 |           ,\(typeVariable:_) automaticPrinter ->
 698 |              (let presentVar = TH.varE (presentVarName typeVariable)
 699 |               in TH.lamE [TH.varP (presentVarName typeVariable)]
 700 |                          [|(let typeString =
 701 |                                   $(TH.stringE (TH.pprint typeName)) ++
 702 |                                   " " ++ parensIfNeeded (fst $(presentVar))
 703 |                             in (typeString
 704 |                                ,\xs ->
 705 |                                   ChoiceValue
 706 |                                     typeString
 707 |                                     [("List"
 708 |                                      ,ListValue typeString
 709 |                                                 (map (snd $(presentVar))
 710 |                                                      ($(TH.varE unpackFunction) xs)))
 711 |                                     ,("Internal",$(return automaticPrinter) xs)]))|]))
 712 |         qualified modName term =
 713 |           TH.Name (TH.OccName term)
 714 |                   (TH.NameQ (TH.ModName modName))
 715 | 
 716 | -- | Packed strings; Text, ByteString.
 717 | --
 718 | -- This function cleverly acccess functions from these packages in the
 719 | -- code generation, without actually needing the `present' package to
 720 | -- depend on them directly.
 721 | --
 722 | packedStrings
 723 |   :: [(TypeConstructor,a -> TH.Exp -> TH.Q TH.Exp)]
 724 | packedStrings =
 725 |   [makeStringPrinter (qualified "Data.ByteString.Internal" "ByteString")
 726 |                      (qualified "Data.ByteString.Char8" "unpack")
 727 |   ,makeStringPrinter (qualified "Data.ByteString.Lazy.Internal" "ByteString")
 728 |                      (qualified "Data.ByteString.Lazy.Char8" "unpack")
 729 |   ,makeStringPrinter (qualified "Data.Text.Internal" "Text")
 730 |                      (qualified "Data.Text" "unpack")
 731 |   ,makeStringPrinter (qualified "Data.Text.Internal.Lazy" "Text")
 732 |                      (qualified "Data.Text.Lazy" "unpack")]
 733 |   where makeStringPrinter typeName unpackFunction =
 734 |           (TypeConstructor typeName
 735 |           ,\_ internal ->
 736 |              [|let typeString = $(TH.stringE (TH.pprint typeName))
 737 |                in (typeString
 738 |                   ,\xs ->
 739 |                      ChoiceValue
 740 |                        typeString
 741 |                        [("String"
 742 |                         ,StringValue typeString
 743 |                                      ($(TH.varE unpackFunction) xs))
 744 |                        ,("Internal",$(return internal) xs)])|])
 745 |         qualified modName term =
 746 |           TH.Name (TH.OccName term)
 747 |                   (TH.NameQ (TH.ModName modName))
 748 | 
 749 | -- | Printers for list-like types.
 750 | listPrinters
 751 |   :: [(TypeConstructor,[TypeVariable] -> TH.Exp -> TH.Q TH.Exp)]
 752 | listPrinters =
 753 |   [(TypeConstructor ''[]
 754 |    ,\(typeVariable:_) _automaticPrinter ->
 755 |       (let presentVar = TH.varE (presentVarName typeVariable)
 756 |        in TH.lamE [TH.varP (presentVarName typeVariable)]
 757 |                   [|(let typeString = "[" ++ fst $(presentVar) ++ "]"
 758 |                      in (typeString
 759 |                         ,\xs ->
 760 |                            ListValue typeString (map (snd $(presentVar)) xs)))|]))]
 761 | 
 762 | -- | Printers for character-like types.
 763 | charPrinters
 764 |   :: [(TypeConstructor,a -> TH.Exp -> TH.Q TH.Exp)]
 765 | charPrinters = map makeCharPrinter [''Char]
 766 |   where makeCharPrinter name =
 767 |           (TypeConstructor name
 768 |           ,\_ automaticPrinter ->
 769 |              [|($(TH.stringE (show name))
 770 |                ,\c ->
 771 |                   ChoiceValue
 772 |                     $(TH.stringE (show name))
 773 |                     [("Character"
 774 |                      ,CharValue $(TH.stringE (show name))
 775 |                                 (return c))
 776 |                     ,("Unicode point",($(intPrinter Nothing name) (ord c)))
 777 |                     ,("Internal",$(return automaticPrinter) c)])|])
 778 | 
 779 | 
 780 | -- | Printers for pointer types.
 781 | pointerPrinters
 782 |   :: [(TypeConstructor,[TypeVariable] -> TH.Exp -> TH.Q TH.Exp)]
 783 | pointerPrinters = map makePtrPrinter [''Ptr,''ForeignPtr,''FunPtr]
 784 |   where makePtrPrinter name =
 785 |           (TypeConstructor name
 786 |           ,\(typeVariable:_) automaticPrinter ->
 787 |              (let presentVar = TH.varE (presentVarName typeVariable)
 788 |               in TH.lamE [TH.varP (presentVarName typeVariable)]
 789 |                          [|(let typeString =
 790 |                                   $(TH.stringE (show name)) ++
 791 |                                   " " ++ parensIfNeeded (fst $(presentVar))
 792 |                             in (typeString
 793 |                                ,\x ->
 794 |                                   ChoiceValue
 795 |                                     typeString
 796 |                                     [("Pointer"
 797 |                                      ,IntegerValue typeString
 798 |                                                    (show x))
 799 |                                     ,("Internal",$(return automaticPrinter) x)]))|]))
 800 | 
 801 | -- | Printers for real number types.
 802 | realPrinters
 803 |   :: [(TypeConstructor,a -> TH.Exp -> TH.Q TH.Exp)]
 804 | realPrinters = map makeIntPrinter [''Float,''Double]
 805 |   where makeIntPrinter name =
 806 |           (TypeConstructor name
 807 |           ,\_ automaticPrinter ->
 808 |              [|($(TH.stringE (show name))
 809 |                ,$(floatingPrinter (Just automaticPrinter)
 810 |                                   name))|])
 811 | 
 812 | -- | Printers for integral types.
 813 | integerPrinters
 814 |   :: [(TypeConstructor,a -> TH.Exp -> TH.Q TH.Exp)]
 815 | integerPrinters =
 816 |   map makeIntPrinter
 817 |       [''Integer
 818 |       ,''Int
 819 |       ,''Int8
 820 |       ,''Int16
 821 |       ,''Int32
 822 |       ,''Int64
 823 |       ,''Word
 824 |       ,''Word8
 825 |       ,''Word32
 826 |       ,''Word64]
 827 |   where makeIntPrinter name =
 828 |           (TypeConstructor name
 829 |           ,\_ automaticPrinter ->
 830 |              [|($(TH.stringE (show name))
 831 |                ,$(intPrinter (Just automaticPrinter)
 832 |                              name))|])
 833 | 
 834 | -- | Show a rational as x/y.
 835 | showRational :: Rational -> String
 836 | showRational x = show (numerator x) ++ "/" ++ show (denominator x)
 837 | 
 838 | -- | Floating point printer.
 839 | floatingPrinter
 840 |   :: Maybe TH.Exp -> TH.Name -> TH.Q TH.Exp
 841 | floatingPrinter mautomaticPrinter name =
 842 |   [|\x ->
 843 |       ChoiceValue
 844 |         $(TH.stringE (show name))
 845 |         $(case mautomaticPrinter of
 846 |             Nothing ->
 847 |               [|[("Floating"
 848 |                  ,IntegerValue $(TH.stringE (show name))
 849 |                                (printf "%f" x))
 850 |                 ,("Show"
 851 |                  ,IntegerValue $(TH.stringE (show name))
 852 |                                (show x))
 853 |                 ,("Rational"
 854 |                  ,IntegerValue $(TH.stringE (show name))
 855 |                                (showRational (toRational x)))]|]
 856 |             Just automaticPrinter ->
 857 |               [|[("Floating"
 858 |                  ,IntegerValue $(TH.stringE (show name))
 859 |                                (printf "%f" x))
 860 |                 ,("Show"
 861 |                  ,IntegerValue $(TH.stringE (show name))
 862 |                                (show x))
 863 |                 ,("Rational"
 864 |                  ,IntegerValue $(TH.stringE (show name))
 865 |                                (showRational (toRational x)))
 866 |                 ,("Internal",$(return automaticPrinter) x)]|])|]
 867 | 
 868 | -- | Integer printer.
 869 | intPrinter
 870 |   :: Maybe TH.Exp -> TH.Name -> TH.Q TH.Exp
 871 | intPrinter mautomaticPrinter name =
 872 |   [|\x ->
 873 |       ChoiceValue
 874 |         $(TH.stringE (show name))
 875 |         $(case mautomaticPrinter of
 876 |             Nothing ->
 877 |               [|[("Decimal"
 878 |                  ,IntegerValue $(TH.stringE (show name))
 879 |                                (show x))
 880 |                 ,("Hexadecimal"
 881 |                  ,IntegerValue $(TH.stringE (show name))
 882 |                                (Text.Printf.printf "%x" x))
 883 |                 ,("Binary"
 884 |                  ,IntegerValue $(TH.stringE (show name))
 885 |                                (Text.Printf.printf "%b" x))]|]
 886 |             Just automaticPrinter ->
 887 |               [|[("Decimal"
 888 |                  ,IntegerValue $(TH.stringE (show name))
 889 |                                (show x))
 890 |                 ,("Hexadecimal"
 891 |                  ,IntegerValue $(TH.stringE (show name))
 892 |                                (Text.Printf.printf "%x" x))
 893 |                 ,("Binary"
 894 |                  ,IntegerValue $(TH.stringE (show name))
 895 |                                (Text.Printf.printf "%b" x))
 896 |                 ,("Internal",$(return automaticPrinter) x)]|])|]
 897 | 
 898 | --------------------------------------------------------------------------------
 899 | -- Type Expression
 900 | --
 901 | -- Given a type, we generate an expression capable of printing that
 902 | -- type. It's just a simple translation from type application to
 903 | -- function application.
 904 | --
 905 | 
 906 | -- | Make an expression for presenting a type. This doesn't actually
 907 | -- do any unpacking of the data structures pertaining to the types,
 908 | -- but rather makes calls to the functions that do.
 909 | expressType
 910 |   :: [TypeVariable] -> NormalType -> TH.Q TH.Exp
 911 | expressType = go 0
 912 |   where
 913 |     go arity typeVariables =
 914 |       \case
 915 |         NormalVar ty ->
 916 |           if elem ty typeVariables
 917 |             then TH.varE (presentVarName ty)
 918 |             else return (presentUnknownVar ty arity)
 919 |         NormalCons cons -> TH.varE (presentConsName cons)
 920 |         NormalPrimitive (PrimitiveTypeConstructor typeConstructorName) ->
 921 |           expressPrimitive typeConstructorName
 922 |         NormalFunction ty ->
 923 |           return
 924 |             (TH.TupE
 925 |                [ Just (TH.LitE (TH.StringL (TH.pprint ty)))
 926 |                , Just
 927 |                    (TH.LamE
 928 |                       [TH.WildP]
 929 |                       (TH.AppE
 930 |                          (TH.ConE 'FunctionValue)
 931 |                          (TH.LitE (TH.StringL (TH.pprint ty)))))
 932 |                ])
 933 |         NormalApp f args ->
 934 |           foldl
 935 |             TH.appE
 936 |             (go (length args) typeVariables f)
 937 |             (map (go 0 typeVariables) args)
 938 | 
 939 | -- | Express a primitive printer.
 940 | expressPrimitive :: TH.Name -> TH.Q TH.Exp
 941 | expressPrimitive typeConstructorName = do
 942 |   info <- TH.reify typeConstructorName
 943 |   case info of
 944 |     TH.PrimTyConI _ arity _unlifted ->
 945 |       return
 946 |         (ignoreTypeVariables
 947 |            arity
 948 |            (TH.TupE
 949 |               [ Just (TH.LitE (TH.StringL (TH.pprint typeConstructorName)))
 950 |               , Just
 951 |                   (TH.LamE
 952 |                      [TH.WildP]
 953 |                      (TH.AppE
 954 |                         (TH.ConE 'PrimitiveValue)
 955 |                         (TH.LitE (TH.StringL (TH.pprint typeConstructorName)))))
 956 |               ]))
 957 |     _ -> fail ("Mistaken primitive type: " ++ TH.pprint typeConstructorName)
 958 | 
 959 | -- | Name for a function name for presenting a type variable of a data
 960 | -- type.
 961 | presentUnknownVar
 962 |   :: TypeVariable -> Int -> TH.Exp
 963 | presentUnknownVar (TypeVariable ty) arity =
 964 |   ignoreTypeVariables
 965 |     arity
 966 |     (TH.TupE
 967 |        [ Just (TH.LitE (TH.StringL (TH.pprint ty)))
 968 |        , Just
 969 |            (TH.LamE
 970 |               [TH.WildP]
 971 |               (TH.AppE
 972 |                  (TH.ConE 'TypeVariableValue)
 973 |                  (TH.LitE (TH.StringL (TH.pprint ty)))))
 974 |        ])
 975 | 
 976 | -- | Given the arity, make a lambda of that arity and ignore all the
 977 | -- paramters.
 978 | ignoreTypeVariables :: Int -> TH.Exp -> TH.Exp
 979 | ignoreTypeVariables arity
 980 |   | arity == 0 = id
 981 |   | otherwise = TH.ParensE . TH.LamE (replicate arity TH.WildP)
 982 | 
 983 | -- | Name for a function name for presenting a type variable of a data
 984 | -- type.
 985 | presentVarName :: TypeVariable -> TH.Name
 986 | presentVarName (TypeVariable ty) =
 987 |   TH.mkName ("presentVar_" ++ normalizeName ty)
 988 | 
 989 | -- | Name for a function name for presenting a type constructor.
 990 | presentConsName :: TypeConstructor -> TH.Name
 991 | presentConsName (TypeConstructor ty) =
 992 |   TH.mkName ("presentCons_" ++ normalizeName ty)
 993 | 
 994 | -- | Normalize a name into a regular format.
 995 | normalizeName :: TH.Name -> String
 996 | normalizeName x = concatMap replace (show x)
 997 |   where replace 'z' = "zz"
 998 |         replace c
 999 |           | isAlphaNum c = [c]
1000 |           | otherwise = "z" ++ printf "%x" (ord c)
1001 | 
1002 | --------------------------------------------------------------------------------
1003 | -- Extension classes
1004 | --
1005 | -- Some user-defined data structures might have some specific opaque
1006 | -- representations, so having some extension classes for a few of them
1007 | -- allows us to provide altnerative representations. If such instances
1008 | -- are provided, they will be prefered above the other default
1009 | -- printers.
1010 | 
1011 | -- | Get a mapping from type to instance methods of instances of
1012 | -- Present, Present1, etc.
1013 | getPresentInstances
1014 |   :: TH.Q [(TypeConstructor,ValueVariable)]
1015 | getPresentInstances = do
1016 |   p0 <- getFor ''Present0
1017 |   p1 <- getFor ''Present1
1018 |   p2 <- getFor ''Present2
1019 |   p3 <- getFor ''Present3
1020 |   p4 <- getFor ''Present4
1021 |   return (concat [p0, p1, p2, p3, p4])
1022 |   where
1023 |     getFor cls = do
1024 |       result <- TH.reify cls
1025 |       case result of
1026 |         TH.ClassI (TH.ClassD _ _ _ _ [TH.SigD method _]) instances ->
1027 |           return
1028 |             (mapMaybe
1029 |                (\i ->
1030 |                   case i of
1031 |                     TH.InstanceD _moverlap _ (TH.AppT (TH.ConT _className) (TH.ConT typeName)) _ ->
1032 |                       Just (TypeConstructor typeName, ValueVariable method)
1033 |                     _ -> Nothing)
1034 |                instances)
1035 |         _ -> return []
1036 | 
1037 | class Present0 a  where
1038 |   present0 :: (String,a -> Value)
1039 | 
1040 | class Present1 a where
1041 |   present1
1042 |     :: (String,x -> Value)
1043 |     -> (String,a x -> Value)
1044 | 
1045 | class Present2 a where
1046 |   present2
1047 |     :: (String,x -> Value)
1048 |     -> (String,y -> Value)
1049 |     -> (String,a x y -> Value)
1050 | 
1051 | class Present3 a where
1052 |   present3
1053 |     :: (String,x -> Value)
1054 |     -> (String,y -> Value)
1055 |     -> (String,z -> Value)
1056 |     -> (String,a x y z -> Value)
1057 | 
1058 | class Present4 a where
1059 |   present4
1060 |     :: (String,x -> Value)
1061 |     -> (String,y -> Value)
1062 |     -> (String,z -> Value)
1063 |     -> (String,z0 -> Value)
1064 |     -> (String,a x y z z0 -> Value)
1065 | 
1066 | class Present5 a where
1067 |   present5
1068 |     :: (String,x -> Value)
1069 |     -> (String,y -> Value)
1070 |     -> (String,z -> Value)
1071 |     -> (String,z0 -> Value)
1072 |     -> (String,z1 -> Value)
1073 |     -> (String,a x y z z0 z1 -> Value)
1074 | 
1075 | class Present6 a where
1076 |   present6
1077 |     :: (String,x -> Value)
1078 |     -> (String,y -> Value)
1079 |     -> (String,z -> Value)
1080 |     -> (String,z0 -> Value)
1081 |     -> (String,z1 -> Value)
1082 |     -> (String,z2 -> Value)
1083 |     -> (String,a x y z z0 z1 z2 -> Value)
1084 | 
1085 | --------------------------------------------------------------------------------
1086 | -- Actual Presenting
1087 | --
1088 | -- Finally, we take the type of `it' and generate a set of presenters
1089 | -- for it and present the value in a self-contained let-expression.
1090 | 
1091 | -- | Present whatever in scope is called `it'
1092 | presentIt :: TH.Q TH.Exp
1093 | presentIt = presentName (TH.mkName "it")
1094 | 
1095 | -- | Make a presenter for the name
1096 | presentName :: TH.Name -> TH.Q TH.Exp
1097 | presentName name = do
1098 |   result <- tryQ (TH.reify name)
1099 |   case result of
1100 |     Nothing -> fail "Name `it' isn't in scope."
1101 |     Just (TH.VarI _ ty _) -> TH.appE (presentType (return ty)) (TH.varE name)
1102 |     _ -> fail "The name `it' isn't a variable."
1103 |   where
1104 |     tryQ m = TH.recover (pure Nothing) (fmap Just m)
1105 | 
1106 | -- | Present the value with the given type.
1107 | presentType :: TH.Q TH.Type -> TH.Q TH.Exp
1108 | presentType getTy =
1109 |   do ty <- getTy
1110 |      let normalizeResult = normalizeType ty
1111 |      case normalizeResult of
1112 |        Left err -> fail err
1113 |        Right normalType ->
1114 |          do instances <- getPresentInstances
1115 |             typeDefinitions <- normalTypeDefinitions normalType
1116 |             presenters <-
1117 |               mapM (typeDefinitionPresenter instances) typeDefinitions
1118 |             TH.letE (map return (concat presenters))
1119 |                     (TH.infixE (Just (TH.varE 'wrapExceptions))
1120 |                                (TH.varE '(.))
1121 |                                (Just (TH.appE (TH.varE 'snd)
1122 |                                               (expressType [] normalType))))
1123 | 
1124 | --------------------------------------------------------------------------------
1125 | -- Debugging helpers
1126 | 
1127 | -- | Present a value and then use 'toShow' on it.
1128 | --
1129 | -- >>> :t $(presentShow [t|Maybe Int|])
1130 | -- $(presentShow [t|Maybe Int|]) :: Maybe Int -> String
1131 | presentShow :: TH.Q TH.Type -> TH.Q TH.Exp
1132 | presentShow ty = [|toShow False . $(presentType ty)|]
1133 | 
1134 | --------------------------------------------------------------------------------
1135 | -- Exception handling
1136 | --
1137 | -- We want to be able to handle exceptions ("bottom") in data
1138 | -- structures, which is particular to Haskell, by returning that as a
1139 | -- presentation, too. So instead of failing to present a data
1140 | -- structure just because it has _|_ in it, let's instead put an
1141 | -- ExceptionValue inside it that can be presented to the user
1142 | -- in a sensible manner.
1143 | 
1144 | -- | Wrap any _|_ in the presentation with an exception handler.
1145 | wrapExceptions :: Value -> Value
1146 | wrapExceptions = wrap . go
1147 |   where wrap =
1148 |           either (\(SomeException exception) ->
1149 |                     ExceptionValue (show (typeOf exception))
1150 |                                    (show exception))
1151 |                  id .
1152 |           trySpoon
1153 |         go =
1154 |           \case
1155 |             DataValue a b ps ->
1156 |               DataValue a
1157 |                             b
1158 |                             (map wrapExceptions ps)
1159 |             ChoiceValue ty lps ->
1160 |               ChoiceValue ty
1161 |                           (map (second wrapExceptions) lps)
1162 |             RecordValue ty c lps ->
1163 |               RecordValue ty
1164 |                           c
1165 |                           (map (second wrapExceptions) lps)
1166 |             ListValue ty ps -> seq ps (ListValue ty (map wrapExceptions ps))
1167 |             TupleValue ty ps ->
1168 |               seq ps
1169 |                   (TupleValue ty
1170 |                               (map wrapExceptions ps))
1171 |             p@(CharValue _ x) -> seqString p x
1172 |             p@(IntegerValue _ x) -> seqString p x
1173 |             p@TypeVariableValue{} -> p
1174 |             p@PrimitiveValue{} -> p
1175 |             p@FunctionValue{} -> p
1176 |             p@(StringValue _ x) -> seqString p x
1177 |             p@ExceptionValue{} -> p
1178 | 
1179 | -- | Seq a string.
1180 | seqString :: Value -> String -> Value
1181 | seqString = foldl' (\presentation x -> seq x presentation)
1182 | 
1183 | -- | Try to get a non-bottom value from the @a@, otherwise return the
1184 | -- exception.
1185 | trySpoon :: a -> Either SomeException a
1186 | trySpoon a = unsafePerformIO (try (evaluate a))
1187 | 
1188 | --------------------------------------------------------------------------------
1189 | -- Value mediums
1190 | --
1191 | -- A presentation by itself is useless, it has to be presented in a
1192 | -- medium.
1193 | 
1194 | -- | To a familiar Show-like string.
1195 | toShow :: Bool -> Value -> String
1196 | toShow qualified =
1197 |   \case
1198 |     IntegerValue _ i -> i
1199 |     ExceptionValue ex display -> "<" ++ ex ++ ": " ++ show display ++ ">"
1200 |     TypeVariableValue ty -> "<_ :: " ++ ty ++ ">"
1201 |     CharValue _ c -> "'" ++ c ++ "'"
1202 |     FunctionValue ty -> "<" ++ unwords (lines ty) ++ ">"
1203 |     DataValue _type name slots ->
1204 |       qualify name ++
1205 |       (if null slots
1206 |           then ""
1207 |           else " ") ++
1208 |       intercalate " "
1209 |                   (map recur slots)
1210 |     RecordValue _type name fields ->
1211 |       qualify name ++
1212 |       " {" ++
1213 |       intercalate ","
1214 |                   (map showField fields) ++
1215 |       "}"
1216 |       where showField (fname,slot) =
1217 |               qualify fname ++ " = " ++ toShow qualified slot
1218 |     TupleValue _type slots ->
1219 |       "(" ++
1220 |       intercalate ","
1221 |                   (map (toShow qualified) slots) ++
1222 |       ")"
1223 |     ListValue typ slots ->
1224 |       if typ == "[GHC.Types.Char]"
1225 |          then show (concatMap (\case
1226 |                                   CharValue _ c -> c
1227 |                                   ChoiceValue _ ((_,CharValue _ c):_) -> c
1228 |                                   _ -> []) slots)
1229 |          else "[" ++
1230 |               intercalate ","
1231 |                           (map (toShow qualified) slots) ++
1232 |               "]"
1233 |     PrimitiveValue p -> "<" ++ p ++ ">"
1234 |     StringValue _ string -> show string
1235 |     ChoiceValue ty ((_,x):choices) ->
1236 |       case x of
1237 |         ExceptionValue{}
1238 |           | not (null choices) -> toShow qualified (ChoiceValue ty choices)
1239 |         _ -> toShow qualified x
1240 |     ChoiceValue _ [] -> "<no presentation choices>"
1241 |   where recur p
1242 |           | atomic p = toShow qualified p
1243 |           | otherwise = "(" ++ toShow qualified p ++ ")"
1244 |           where atomic =
1245 |                   \case
1246 |                     ListValue{} -> True
1247 |                     IntegerValue{} -> True
1248 |                     CharValue{} -> True
1249 |                     StringValue{} -> True
1250 |                     ChoiceValue ty ((_,x):xs) ->
1251 |                       case x of
1252 |                         ExceptionValue{}
1253 |                           | not (null xs) -> atomic (ChoiceValue ty xs)
1254 |                         _ -> atomic x
1255 |                     DataValue _ _ [] -> True
1256 |                     PrimitiveValue _ -> True
1257 |                     _ -> False
1258 |         qualify x =
1259 |           if qualified
1260 |              then x
1261 |              else reverse (takeWhile (/= '.') (reverse x))
1262 | 
1263 | -- | A presentation of a value up to WHNF.
1264 | data WHNF
1265 |   = DataWHNF String String [(String,[Integer])]
1266 |   | TypeVariableWHNF String
1267 |   | PrimitiveWHNF String
1268 |   | FunctionWHNF String
1269 |   | CharWHNF String String
1270 |   | IntegerWHNF String String
1271 |   | ChoiceWHNF String [(String,[Integer])]
1272 |   | RecordWHNF String String [(String,String,[Integer])]
1273 |   | ListConsWHNF String [Integer] [Integer]
1274 |   | ListEndWHNF String
1275 |   | StringWHNF String String
1276 |   | TupleWHNF String [(String,[Integer])]
1277 |   | ExceptionWHNF String String
1278 |   deriving (Show)
1279 | 
1280 | -- | Produce a presentation of the value to WHNF.
1281 | toWHNF :: [Integer] -- ^ Cursor.
1282 |        -> Value     -- ^ Value to cursor into.
1283 |        -> WHNF      -- ^ A WHNF presentation of the value at @cursor@.
1284 | toWHNF = go []
1285 |   where go
1286 |           :: [Integer] -> [Integer] -> Value -> WHNF
1287 |         go stack cursor =
1288 |           \case
1289 |             DataValue typ name slots ->
1290 |               case cursor of
1291 |                 (slot:subCursor) ->
1292 |                   case lookup slot (zip [0 ..] slots) of
1293 |                     Nothing -> error "toWHNF: Invalid slot."
1294 |                     Just value -> go (push [slot]) subCursor value
1295 |                 _ ->
1296 |                   DataWHNF typ
1297 |                            name
1298 |                            (zipWith (\index slot ->
1299 |                                        (valueType slot,push (cursor ++ [index])))
1300 |                                     [0 ..]
1301 |                                     slots)
1302 |             ChoiceValue ty slots ->
1303 |               case cursor of
1304 |                 (slot:subCursor) ->
1305 |                   case lookup slot (zip [0 ..] slots) of
1306 |                     Nothing -> error "toWHNF: Invalid slot."
1307 |                     Just (_,value) -> go (push [slot]) subCursor value
1308 |                 _ ->
1309 |                   ChoiceWHNF
1310 |                     ty
1311 |                     (zipWith (\index (string,_) ->
1312 |                                 (string,push (cursor ++ [index])))
1313 |                              [0 ..]
1314 |                              slots)
1315 |             RecordValue typ name slots ->
1316 |               case cursor of
1317 |                 (slot:subCursor) ->
1318 |                   case lookup slot (zip [0 ..] slots) of
1319 |                     Nothing -> error "toWHNF: Invalid slot."
1320 |                     Just (_,value) -> go (push [slot]) subCursor value
1321 |                 _ ->
1322 |                   RecordWHNF
1323 |                     typ
1324 |                     name
1325 |                     (zipWith (\index (fname,slot) ->
1326 |                                 (valueType slot,fname,push (cursor ++ [index])))
1327 |                              [0 ..]
1328 |                              slots)
1329 |             ListValue ty slots ->
1330 |               case cursor of
1331 |                 (slot:subCursor) ->
1332 |                   case slot of
1333 |                     0 ->
1334 |                       case slots of
1335 |                         (value0:_) -> go (push [slot]) subCursor value0
1336 |                         _ -> ListEndWHNF ty
1337 |                     _ ->
1338 |                       case slots of
1339 |                         (_:value1) ->
1340 |                           go (push [slot])
1341 |                              subCursor
1342 |                              (ListValue ty value1)
1343 |                         _ -> ListEndWHNF ty
1344 |                 _ ->
1345 |                   case slots of
1346 |                     [] -> ListEndWHNF ty
1347 |                     (_:_) ->
1348 |                       ListConsWHNF ty
1349 |                                    (push cursor ++ [0])
1350 |                                    (push cursor ++ [1])
1351 |             TupleValue ty slots ->
1352 |               case cursor of
1353 |                 (slot:subCursor) ->
1354 |                   case lookup slot (zip [0 ..] slots) of
1355 |                     Nothing -> error "toWHNF: Invalid slot."
1356 |                     Just value -> go (push [slot]) subCursor value
1357 |                 _ ->
1358 |                   TupleWHNF ty
1359 |                             (zipWith (\index slot ->
1360 |                                         (valueType slot
1361 |                                         ,push (cursor ++ [index])))
1362 |                                      [0 ..]
1363 |                                      slots)
1364 |             TypeVariableValue ty -> TypeVariableWHNF ty
1365 |             PrimitiveValue ty -> PrimitiveWHNF ty
1366 |             FunctionValue ty -> FunctionWHNF ty
1367 |             CharValue ty ch -> CharWHNF ty ch
1368 |             IntegerValue ty rep -> IntegerWHNF ty rep
1369 |             StringValue ty str -> StringWHNF ty str
1370 |             ExceptionValue ty c -> ExceptionWHNF ty c
1371 |           where push xs = stack ++ xs
1372 | 
1373 | -- | Get the type of a value.
1374 | valueType :: Value -> String
1375 | valueType =
1376 |   \case
1377 |      DataValue ty _ _ -> ty
1378 |      TypeVariableValue ty -> ty
1379 |      PrimitiveValue ty -> ty
1380 |      FunctionValue ty -> ty
1381 |      CharValue ty _ -> ty
1382 |      IntegerValue ty _ -> ty
1383 |      ChoiceValue ty _ -> ty
1384 |      RecordValue ty _ _ -> ty
1385 |      ListValue ty _ -> ty
1386 |      StringValue ty _ -> ty
1387 |      TupleValue ty _ -> ty
1388 |      ExceptionValue ty _ -> ty
1389 | 
1390 | -- | Make JSON from WNHF.
1391 | whnfJson :: WHNF -> String
1392 | whnfJson =
1393 |   \case
1394 |     DataWHNF ty name slots ->
1395 |       jsonObject
1396 |         [("constructor",jsonString "data")
1397 |         ,("type",jsonString ty)
1398 |         ,("name",jsonString name)
1399 |         ,("slots"
1400 |          ,jsonList (map (\(typ,sid) ->
1401 |                            jsonObject
1402 |                              [("type",jsonString typ)
1403 |                              ,("id",jsonList (map jsonInteger sid))])
1404 |                         slots))]
1405 |     TypeVariableWHNF var ->
1406 |       jsonObject
1407 |         [("constructor",jsonString "type-variable"),("type",jsonString var)]
1408 |     PrimitiveWHNF name ->
1409 |       jsonObject
1410 |         [("constructor",jsonString "primitive"),("type",jsonString name)]
1411 |     FunctionWHNF ty ->
1412 |       jsonObject [("constructor",jsonString "primitive"),("type",jsonString ty)]
1413 |     CharWHNF ty string ->
1414 |       jsonObject
1415 |         [("constructor",jsonString "char")
1416 |         ,("type",jsonString ty)
1417 |         ,("string",jsonString string)]
1418 |     IntegerWHNF ty string ->
1419 |       jsonObject
1420 |         [("constructor",jsonString "integer")
1421 |         ,("type",jsonString ty)
1422 |         ,("string",jsonString string)]
1423 |     ChoiceWHNF ty slots ->
1424 |       jsonObject
1425 |         [("constructor",jsonString "choice")
1426 |         ,("type",jsonString ty)
1427 |         ,("slots"
1428 |          ,jsonList (map (\(typ,sid) ->
1429 |                            jsonObject
1430 |                              [("title",jsonString typ)
1431 |                              ,("id",jsonList (map jsonInteger sid))])
1432 |                         slots))]
1433 |     RecordWHNF ty name slots ->
1434 |       jsonObject
1435 |         [("constructor",jsonString "record")
1436 |         ,("type",jsonString ty)
1437 |         ,("name",jsonString name)
1438 |         ,("slots"
1439 |          ,jsonList (map (\(typ,name',sid) ->
1440 |                            jsonObject
1441 |                              [("type",jsonString typ)
1442 |                              ,("name",jsonString name')
1443 |                              ,("id",jsonList (map jsonInteger sid))])
1444 |                         slots))]
1445 |     ListConsWHNF typ x xs ->
1446 |       jsonObject
1447 |         [("constructor",jsonString "list-cons")
1448 |         ,("type",jsonString typ)
1449 |         ,("car",jsonList (map jsonInteger x))
1450 |         ,("cdr",jsonList (map jsonInteger xs))]
1451 |     ListEndWHNF typ ->
1452 |       jsonObject [("constructor",jsonString "list-end"),("type",jsonString typ)]
1453 |     StringWHNF typ string ->
1454 |       jsonObject
1455 |         [("constructor",jsonString "string")
1456 |         ,("type",jsonString typ)
1457 |         ,("string",jsonString string)]
1458 |     TupleWHNF ty slots ->
1459 |       jsonObject
1460 |         [("constructor",jsonString "tuple")
1461 |         ,("type",jsonString ty)
1462 |         ,("slots"
1463 |          ,jsonList (map (\(typ,sid) ->
1464 |                            jsonObject
1465 |                              [("type",jsonString typ)
1466 |                              ,("id",jsonList (map jsonInteger sid))])
1467 |                         slots))]
1468 |     ExceptionWHNF typ shown ->
1469 |       jsonObject
1470 |         [("constructor",jsonString "exception")
1471 |         ,("type",jsonString typ)
1472 |         ,("string",jsonString shown)]
1473 |   where jsonString :: String -> String
1474 |         jsonString = (\x -> "\"" ++ x ++ "\"") . go
1475 |           where go s1 =
1476 |                   case s1 of
1477 |                     (x:xs)
1478 |                       | x < '\x20' ->
1479 |                         '\\' :
1480 |                         encControl x
1481 |                                    (go xs)
1482 |                     ('"':xs) -> '\\' : '"' : go xs
1483 |                     ('\\':xs) -> '\\' : '\\' : go xs
1484 |                     (x:xs) -> x : go xs
1485 |                     "" -> ""
1486 |                 encControl x xs =
1487 |                   case x of
1488 |                     '\b' -> 'b' : xs
1489 |                     '\f' -> 'f' : xs
1490 |                     '\n' -> 'n' : xs
1491 |                     '\r' -> 'r' : xs
1492 |                     '\t' -> 't' : xs
1493 |                     _
1494 |                       | x < '\x10' -> 'u' : '0' : '0' : '0' : hexxs
1495 |                       | x < '\x100' -> 'u' : '0' : '0' : hexxs
1496 |                       | x < '\x1000' -> 'u' : '0' : hexxs
1497 |                       | otherwise -> 'u' : hexxs
1498 |                       where hexxs = showHex (fromEnum x) xs
1499 |         jsonObject fields =
1500 |           "{" ++
1501 |           intercalate ", "
1502 |                       (map makeField fields) ++
1503 |           "}"
1504 |           where makeField (name,value) = jsonString name ++ ": " ++ value
1505 |         jsonList xs = "[" ++ intercalate ", " xs ++ "]"
1506 |         jsonInteger :: Integer -> String
1507 |         jsonInteger = show
1508 | 


--------------------------------------------------------------------------------
/src/test/tests.ghci:
--------------------------------------------------------------------------------
 1 | :set -v0
 2 | :set -ddump-splices
 3 | -- This tests for recursive types not being an infinite loop.
 4 | data List a = Cons a (List a) | Nil
 5 | :presentDebug Nil :: List Int
 6 | 
 7 | -- -- This tests for let generalization.
 8 | -- :presentDebug X 0 (S 'a') :: X Int Char
 9 | 
10 | -- data X a b = S Char | X Int (X b a)
11 | -- -- This tests for ambiguous but unused types.
12 | -- :presentDebug X 0 (S 'a')
13 | 


--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
1 | resolver: nightly-2020-09-18
2 | 


--------------------------------------------------------------------------------
/stack.yaml.lock:
--------------------------------------------------------------------------------
 1 | # This file was autogenerated by Stack.
 2 | # You should not edit this file by hand.
 3 | # For more information, please see the documentation at:
 4 | #   https://docs.haskellstack.org/en/stable/lock_files
 5 | 
 6 | packages: []
 7 | snapshots:
 8 | - completed:
 9 |     size: 531502
10 |     url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/9/18.yaml
11 |     sha256: edd0f8d6cfbb25109c95f4d6a3126f0ff5b9a03e38b1926e6c5245cf7ed43f49
12 |   original: nightly-2020-09-18
13 | 


--------------------------------------------------------------------------------
/test/Lifts.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TemplateHaskell #-}
 2 | {-# OPTIONS_GHC -fno-warn-orphans #-}
 3 | 
 4 | -- | Derive needed instances of Lift.
 5 | 
 6 | module Lifts where
 7 | 
 8 | import Language.Haskell.TH.Lift
 9 | import Language.Haskell.TH.Syntax
10 | 
11 | $(deriveLiftMany [''Type, ''TyVarBndr, ''TyLit])
12 | 
13 | lifted :: Q Type -> Q Exp
14 | lifted m = m >>= lift
15 | 


--------------------------------------------------------------------------------
/test/Main.hs:
--------------------------------------------------------------------------------
1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-}
2 | 


--------------------------------------------------------------------------------
/test/NormalizeSpec.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE KindSignatures #-}
 2 | {-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
 3 | 
 4 | -- | Test type normalization.
 5 | 
 6 | module NormalizeSpec where
 7 | 
 8 | import Control.Monad.Trans.Reader
 9 | import Lifts
10 | import Present
11 | import Test.Hspec
12 | 
13 | spec :: SpecWith ()
14 | spec = do
15 |   it
16 |     "Int"
17 |     (shouldBe
18 |        (normalizeType $(lifted [t|Int|]))
19 |        (Right (NormalCons (TypeConstructor ''Int))))
20 |   it
21 |     "Maybe Int"
22 |     (shouldBe
23 |        (normalizeType $(lifted [t|Maybe Int|]))
24 |        (Right
25 |           (NormalApp
26 |              (NormalCons (TypeConstructor ''Maybe))
27 |              [NormalCons (TypeConstructor ''Int)])))
28 |   it
29 |     "IdentityT m"
30 |     (shouldBe
31 |        (normalizeType $(lifted [t|forall r (m :: * -> *) a. ReaderT r m a|]))
32 |        (Right
33 |           (NormalApp
34 |              (NormalCons (TypeConstructor ''Maybe))
35 |              [NormalCons (TypeConstructor ''Int)])))
36 | 


--------------------------------------------------------------------------------