Expose.hs

gistfile1.txt

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

{-

showVar :: DynFlags -> Var -> String
showVar df var =
  case var of
    $(conPat ''Var "TyVar" [p|() varName _ varType|]) ->
      show ("TyVar",showppr df varName,"#",showppr df varType)
    $(conPat ''Var "TcTyVar" [p|() varName _ varType tcDetails|]) ->
      show ("TcTyVar")
    $(conPat ''Var "Id" [p|() varName _ varType scope deets info|]) ->
      show ("Var")
      
-}      

-- | Expose things that are not exposed by module encapsulation.

module Expose where

import Data.List
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

-- | Get a pattern for a constructor.
conPat :: Name -> String -> Q Pat -> Q Pat
conPat typ name pat =
  do unpat <- pat
     case unpat of
       ConP unit fields
         | nameString unit == "()" -> do
           info <- reify typ
           case info of
             TyConI dec ->
               case dec of
                 DataD _cxt _ _ cons _deriving -> fromConstructors fields cons
                 NewtypeD _cxt _ _ con _deriving -> fromConstructors fields [con]
                 _ ->
                   error "Don't support getting a constructor for this kind of thing."
             _ -> error "Don't support getting a constructor for this kind of thing." undefined
       _ -> error ("Pattern should be like this: [p|() x y z ..|], you gave: " ++ show unpat)
  where nameString (Name (OccName string) _) =
          string
        fromConstructors fields =
          maybe (error "Couldn't find that constructor.")
                (\n -> conP n (map return fields)) .
          find ((== name) . nameString) . map conName
          where conName =
                  \case
                    NormalC n _ -> n
                    RecC n _ -> n
                    InfixC _ n _ -> n
                    ForallC _ _ c -> conName c