Skip to content

Instantly share code, notes, and snippets.

@piq9117
Forked from Gabriella439/Main.hs
Created April 8, 2021 00:58
Show Gist options
  • Save piq9117/09967f1a2482a8925163a5cf1024eb45 to your computer and use it in GitHub Desktop.
Save piq9117/09967f1a2482a8925163a5cf1024eb45 to your computer and use it in GitHub Desktop.
Example use of GHC generics to derive datatype parser
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Main where
import Data.Void (Void)
import Data.Text (Text)
import GHC.Generics
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer (decimal, float)
import qualified Data.Text as Text
data Foo = Foo { x :: Double, y :: Double, z :: Double } | Baz { a :: Int }
deriving (Generic, Read, Show, Parse)
type Parser = Parsec Void Text
class Parse (a :: *) where
parse :: Parser a
default parse :: (Generic a, GenericParse (Rep a)) => Parser a
parse = do
rep <- genericParse
return (to rep)
class GenericParse (f :: * -> *) where
genericParse :: Parser (f a)
instance GenericParse (K1 i Double) where
genericParse = do
x <- float
return (K1 x)
instance GenericParse (K1 i Int) where
genericParse = do
x <- decimal
return (K1 x)
instance (Selector s, GenericParse primitive) => GenericParse (M1 S s primitive) where
genericParse = do
let selectorName = selName (undefined :: M1 S s primitive a)
chunk (Text.pack selectorName)
space
"="
space
primitive <- genericParse
return (M1 primitive)
instance (GenericParse fieldsLeft, GenericParse fieldsRight) =>
GenericParse (fieldsLeft :*: fieldsRight) where
genericParse = do
fieldsLeft <- genericParse
space
","
space
fieldsRight <- genericParse
return (fieldsLeft :*: fieldsRight)
instance (Constructor c, GenericParse fields) =>
GenericParse (M1 C c fields) where
genericParse = do
let constructorName = conName (undefined :: M1 C c fields a)
chunk (Text.pack constructorName)
space
"{"
space
fields <- genericParse
space
"}"
return (M1 fields)
instance (GenericParse constructorsLeft, GenericParse constructorsRight) =>
GenericParse (constructorsLeft :+: constructorsRight) where
genericParse = fmap L1 genericParse <|> fmap R1 genericParse
instance GenericParse constructors => GenericParse (M1 D d constructors) where
genericParse = do
constructors <- genericParse
return (M1 constructors)
instance GenericParse U1 where
genericParse = do
return U1
instance GenericParse V1 where
genericParse = empty
main :: IO ()
main = do
parseTest (parse @Foo) "Baz{ a = 1 }"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment