gpah-0.0.1: src/Generics/GPAH/Deriving/Analyze.hs
{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, ScopedTypeVariables #-}
module Generics.GPAH.Deriving.Analyze where
import Generics.GPAH.Deriving.Base
import Generics.GPAH.Utils
import Language.Haskell.Exts
import Language.Haskell.Exts.Comments
import qualified Data.Map as M
import Data.List
import Data.Monoid
analyzeModule :: ParseResult (Module, [Comment]) -> Analysis
analyzeModule (ParseOk ((Module _ _ _ _ _ _ decls),_)) = foldr (\ decl acc -> analyzeDecl decl `mappend` acc) mempty decls
analyzeModule _ = mempty
analyzeDecl :: Decl -> Analysis
-- NORMAL
---------
-- data
analyzeDecl (DataDecl _ DataType _ _ name _ ds) = let lds = length ds
nds = map derivingName ds
in mempty {
sizeStruct = 1
, normalStruct = 1
, sizePos = (fromBool $ not $ null ds)
, normalPos = (fromBool $ not $ null ds)
, sizeDer = lds
, normalDer = lds
, topDer = (M.fromList $ zip nds (repeat 1))
}
-- ok
-- newtype
analyzeDecl (DataDecl _ NewType _ _ name _ ds) = let lds = length ds
nds = map derivingName ds
in mempty {
sizeStruct = 1
, normalStruct = 1
, newtypeStructContains = 1
, sizePos = (fromBool $ not $ null ds)
, normalPos = (fromBool $ not $ null ds)
, newtypePosContains = (fromBool $ not $ null ds)
, sizeDer = lds
, normalDer = lds
, newtypeDerContains = lds
}
-- ok
-- GADT
-------
-- data
analyzeDecl (GDataDecl _ DataType _ name _ _ _ ds) = let lds = length ds
nds = map derivingName ds
in mempty {
sizeStruct = 1
, gadtStruct = 1
, sizePos = (fromBool $ not $ null ds)
, gadtPos = (fromBool $ not $ null ds)
, sizeDer = lds
, gadtDer = lds
, topDer = (M.fromList $ zip nds (repeat 1))
}
-- ok
-- newtype
analyzeDecl (GDataDecl _ NewType _ name _ _ _ ds) = let lds = length ds
nds = map derivingName ds
in mempty {
sizeStruct = 1
, gadtStruct = 1
, newtypeStructContains = 1
, sizePos = (fromBool $ not $ null ds)
, gadtPos = (fromBool $ not $ null ds)
, newtypePosContains = (fromBool $ not $ null ds)
, sizeDer = lds
, gadtDer = lds
, newtypeDerContains = lds
}
-- ok
-- FAMSTRUCT
------------
-- data
analyzeDecl (DataInsDecl _ DataType _ _ ds) = let lds = length ds
nds = map derivingName ds
in mempty {
sizeStruct = 1
, famStruct = 1
, newtypeStructContains = 1
, sizePos = (fromBool $ not $ null ds)
, famPos = (fromBool $ not $ null ds)
, newtypePosContains = (fromBool $ not $ null ds)
, sizeDer = lds
, famDer = lds
, newtypeDerContains = lds
}
-- ok
-- newtype
analyzeDecl (DataInsDecl _ NewType _ _ ds) = let lds = length ds
nds = map derivingName ds
in mempty {
sizeStruct = 1
, famStruct = 1
, newtypeStructContains = 1
, sizePos = (fromBool $ not $ null ds)
, famPos = (fromBool $ not $ null ds)
, newtypePosContains = (fromBool $ not $ null ds)
, sizeDer = lds
, famDer = lds
, newtypeDerContains = lds
}
-- ok
-- GADTFAMSTRUCT
----------------
-- data
analyzeDecl (GDataInsDecl _ DataType typeParams _ _ ds) = let lds = length ds
nds = map derivingName ds
in mempty {
sizeStruct = 1
, gadtFamStruct = 1
, newtypeStructContains = 1
, sizePos = (fromBool $ not $ null ds)
, gadtFamPos = (fromBool $ not $ null ds)
, newtypePosContains = (fromBool $ not $ null ds)
, sizeDer = lds
, gadtFamDer = lds
, newtypeDerContains = lds
}
-- ok
-- newtype
analyzeDecl (GDataInsDecl _ NewType typeParams _ _ ds) = let lds = length ds
nds = map derivingName ds
in mempty {
sizeStruct = 1
, gadtFamStruct = 1
, newtypeStructContains = 1
, sizePos = (fromBool $ not $ null ds)
, gadtFamPos = (fromBool $ not $ null ds)
, newtypePosContains = (fromBool $ not $ null ds)
, sizeDer = lds
, gadtFamDer = lds
, newtypeDerContains = lds
}
-- ok
-- standalone deriving
analyzeDecl (DerivDecl _ _ derClass typeParams) = mempty { stdAloneDecl = 1}
analyzeDecl (InstDecl _ _ derClass typeParams _) = let isDeriveableInstance = qNameToString derClass `elem` deriveableClasses
in mempty {
sizeInst = 1
, overloadInst = fromBool isDeriveableInstance
, topOverload = if isDeriveableInstance
then M.singleton (qNameToString derClass) 1
else M.empty
}
analyzeDecl _ = mempty