module Language.Haskell.Derive.Gadt.Class.Read where
import Language.Haskell.Derive.Gadt.Common
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set(Set)
import qualified Data.Set as S
import Data.Monoid(Monoid(..))
import Language.Haskell.Meta hiding (parseExp,parseType)
import Language.Haskell.Meta.Utils
import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.Extension
import Language.Haskell.Exts.Fixity
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Pretty
import qualified Language.Haskell.TH.Syntax as TH
import qualified Language.Haskell.TH.Lib as TH
import Control.Applicative
import Control.Monad
import Text.PrettyPrint
import Data.Function
import Data.List
test1 = deriveReadGadts =<< TH.runIO (readFile "GADTTest.hs")
deriveReadGadts :: String -> TH.Q [TH.Dec]
deriveReadGadts s = do
case parseModuleGadts s of
Left e -> fail e
Right is -> concat <$> mapM deriveReadGadtInfo is
deriveReadGadtInfo :: GadtInfo -> TH.Q [TH.Dec]
deriveReadGadtInfo info = do
let grps = instanceGroups info
go (t,xs) = let ys = fmap (\(n,ary)->(prettyPrint n, ary)) xs
in deriveReadConsQ t ys
concat <$> mapM go (nubBy ((==) `on` fst) grps)
deriveReadConsQ :: Type -> [(String, Int)] -> TH.Q [TH.Dec]
deriveReadConsQ ty cons = do
let ary = maximum (fmap snd cons)
p <- TH.newName "p"
xs <- replicateM ary (TH.newName "x")
s0:s1:ss <- replicateM (max 2 (ary+2)) (TH.newName "s")
let ps = fmap TH.VarP [p,s0]
doOne con xs s0 ss =
let go _ [s] = [TH.noBindS
(TH.tupE [foldl TH.appE (TH.conE (TH.mkName con))
(fmap TH.varE xs)
,TH.varE s])]
go (x:xs) (s0:s1:ss) = TH.bindS
(TH.tupP [TH.varP x, TH.varP s1])
[|readsPrec 11 $(TH.varE s0)|] : go xs (s1:ss)
e0 = TH.bindS
(TH.tupP [TH.litP (TH.stringL con), TH.varP s1])
[|lex $(TH.varE s0)|]
es = go xs ss
in TH.compE (e0:es)
es = flip fmap cons (\(con,ary) ->
let ys = take ary xs
zs = s1 : take ary ss
in doOne con ys s0 zs)
e <- [|concat $(TH.listE (fmap (\x -> [|readParen ($(TH.varE p) > 10) $(TH.lamE [TH.varP s0] x) $(TH.varE s0)|]) es))|]
let dec = mkFunD (TH.mkName "readsPrec") ps e
inst = TH.instanceD
(return [])
(TH.conT ''Read `TH.appT` return (toType ty))
[return dec]
sequence [inst]