module Derive.List.Internal where
import Derive.List.Extra
import Data.Semigroup
import Language.Haskell.TH
import GHC.Exts (IsList (..))
data DeriveListConfig = DeriveListConfig
{ _getEmptyName :: String -> String
, _getAppendName :: String -> String
, _getToListName :: String -> String
}
data DeriveListNames = DeriveListNames
{ theType :: Name
, theConstructor :: Name
, theEmpty :: Name
, theAppend :: Name
, theToList :: Name
} deriving (Show,Eq,Ord)
deriveList :: Name -> Name -> DecsQ
deriveList = deriveListWith defaultDeriveListConfig
deriveMonoid :: Name -> Name -> DecsQ
deriveMonoid = deriveMonoidWith defaultDeriveListConfig
deriveSemigroup :: Name -> Name -> DecsQ
deriveSemigroup = deriveSemigroupWith defaultDeriveListConfig
deriveIsList :: Name -> Name -> DecsQ
deriveIsList = deriveIsListWith defaultDeriveListConfig
deriveListWith :: DeriveListConfig -> Name -> Name -> DecsQ
deriveListWith config@DeriveListConfig{..} theType theConstructor = fmap concat . traverse id $
[ deriveSemigroup_ names
, deriveMonoid_ names
, deriveIsList_ names
, makeEmpty names
, makeAppend names
, makeToList names
]
where
names = makeDeriveListNames config theType theConstructor
deriveMonoidWith :: DeriveListConfig -> Name -> Name -> DecsQ
deriveMonoidWith config@DeriveListConfig{..} theType theConstructor = fmap concat . traverse id $
[ deriveMonoid_ names
, makeEmpty names
, makeAppend names
, makeToList names
]
where
names = makeDeriveListNames config theType theConstructor
deriveSemigroupWith :: DeriveListConfig -> Name -> Name -> DecsQ
deriveSemigroupWith config@DeriveListConfig{..} theType theConstructor = fmap concat . traverse id $
[ deriveSemigroup_ names
, makeAppend names
, makeToList names
]
where
names = makeDeriveListNames config theType theConstructor
deriveIsListWith :: DeriveListConfig -> Name -> Name -> DecsQ
deriveIsListWith config@DeriveListConfig{..} theType theConstructor = fmap concat . traverse id $
[ deriveIsList_ names
, makeToList names
]
where
names = makeDeriveListNames config theType theConstructor
deriveSemigroup_ :: DeriveListNames -> DecsQ
deriveSemigroup_ DeriveListNames{..} = do
[d| instance Semigroup $theTypeT where
(<>) = $theAppendE
|]
where
theTypeT = saturateT theType
theAppendE = varE theAppend
deriveMonoid_ :: DeriveListNames -> DecsQ
deriveMonoid_ DeriveListNames{..} = do
[d| instance Monoid $theTypeT where
mempty = $theEmptyE
mappend = $theAppendE
|]
where
theTypeT = saturateT theType
theEmptyE = varE theEmpty
theAppendE = varE theAppend
deriveIsList_ :: DeriveListNames -> DecsQ
deriveIsList_ DeriveListNames{..} = do
[d| instance IsList $theTypeT where
type Item $theTypeT = $theTypeT
fromList = $theConstructorE
toList = $theToListE
|]
where
theTypeT = saturateT theType
theConstructorE = conE theConstructor
theToListE = varE theToList
makeEmpty :: DeriveListNames -> DecsQ
makeEmpty DeriveListNames{..} = return [definitionD, inlinableD]
where
definitionD = FunD theEmpty [Clause [] (NormalB bodyE) []]
bodyE = ConE theConstructor `AppE` (ListE [])
inlinableD = PragmaD (InlineP theEmpty Inlinable ConLike AllPhases)
makeAppend :: DeriveListNames -> DecsQ
makeAppend DeriveListNames{..} = do
definitionD <- [d| $theAppendP = \x y -> $theConstructorE ($theToListE x <> $theToListE y) |]
return$ concat [definitionD, inlinableD]
where
theConstructorE = conE theConstructor
theToListE = varE theToList
theAppendP = varP theAppend
inlinableD = [PragmaD (InlineP theAppend Inlinable FunLike AllPhases)]
makeToList :: DeriveListNames -> DecsQ
makeToList DeriveListNames{..} = traverse id [definitionD, inlinableD]
where
definitionD = do
tsN <- newName "ts"
tN <- newName "t"
return$ FunD theToList
[ Clause [ConP theConstructor [VarP tsN]] (NormalB (VarE tsN)) []
, Clause [VarP tN] (NormalB (ListE [VarE tN])) []
]
inlinableD = return$ PragmaD (InlineP theToList Inlinable FunLike AllPhases)
makeDeriveListNames :: DeriveListConfig -> Name -> Name -> DeriveListNames
makeDeriveListNames DeriveListConfig{..} theType theConstructor = DeriveListNames{..}
where
theEmpty = mkName $ _getEmptyName (nameBase theType)
theAppend = mkName $ _getAppendName (nameBase theType)
theToList = mkName $ _getToListName (nameBase theType)
defaultDeriveListConfig :: DeriveListConfig
defaultDeriveListConfig = DeriveListConfig{..}
where
_getEmptyName = (\typename -> "empty"<>typename)
_getAppendName = (\typename -> "append"<>typename)
_getToListName = (\typename -> "to"<>typename<>"List")