module Language.Haskell.Homplexity.CodeFragment (
CodeFragment (fragmentName, fragmentSlice)
, occurs
, occursOf
, allOccurs
, allOccursOf
, Program (..)
, programT
, program
, Module (..)
, moduleT
, Function (..)
, functionT
, TypeSignature (..)
, typeSignatureT
, fragmentLoc
) where
import Data.Data
import Data.Functor
import Data.Generics.Uniplate.Data
import Data.List
import Data.Maybe
import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Homplexity.SrcSlice
newtype Program = Program { allModules :: [Module SrcLoc] }
deriving (Data, Typeable, Show)
program :: [Module SrcLoc] -> Program
program = Program
programT :: Proxy Program
programT = Proxy
data Function = Function {
functionNames :: [String]
, functionLocations :: [SrcLoc]
, functionRhs :: [Rhs SrcLoc]
, functionBinds :: [Binds SrcLoc]
}
deriving (Data, Typeable, Show)
functionT :: Proxy Function
functionT = Proxy
data TypeSignature = TypeSignature { loc :: SrcLoc
, identifiers :: [Name SrcLoc]
, theType :: Type SrcLoc }
deriving (Data, Typeable, Show)
typeSignatureT :: Proxy TypeSignature
typeSignatureT = Proxy
data ClassSignature = ClassSignature
deriving (Data, Typeable)
class (Show c, Data (AST c), Data c) => CodeFragment c where
type AST c
matchAST :: AST c -> Maybe c
fragmentName :: c -> String
fragmentSlice :: c -> SrcSlice
fragmentSlice = srcSlice
fragmentLoc :: (CodeFragment c) => c -> SrcLoc
fragmentLoc = getPointLoc
. fragmentSlice
mergeBinds = catMaybes
instance CodeFragment Function where
type AST Function = Decl SrcLoc
matchAST (FunBind _ matches) = Just
Function {..}
where
(functionLocations,
(unName <$>) . take 1 -> functionNames,
functionRhs,
catMaybes -> functionBinds) = unzip4 $ map extract matches
extract (Match srcLoc name _ rhs binds) = (srcLoc, name, rhs, binds)
matchAST (PatBind (singleton -> functionLocations) pat
(singleton -> functionRhs )
(maybeToList -> functionBinds )) = Just Function {..}
where
functionNames = wildcards ++ map unName (universeBi pat :: [Name SrcLoc])
wildcards = mapMaybe wildcard (universe pat)
where
wildcard PWildCard {} = Just ".."
wildcard _ = Nothing
matchAST _ = Nothing
fragmentName Function {..} = unwords $ "function":functionNames
singleton :: a -> [a]
singleton = (:[])
occurs :: (CodeFragment c, Data from) => from -> [c]
occurs = mapMaybe matchAST . childrenBi
occursOf :: (Data from, CodeFragment c) => Proxy c -> from -> [c]
occursOf _ = occurs
allOccurs :: (CodeFragment c, Data from) => from -> [c]
allOccurs = mapMaybe matchAST . universeBi
allOccursOf :: (Data from, CodeFragment c) => Proxy c -> from -> [c]
allOccursOf _ = allOccurs
instance CodeFragment Program where
type AST Program = Program
matchAST = Just
fragmentName _ = "program"
instance CodeFragment (Module SrcLoc) where
type AST (Module SrcLoc)= Module SrcLoc
matchAST = Just
fragmentName (Module _ (Just (ModuleHead _ (ModuleName _ theName) _ _)) _ _ _) =
"module " ++ theName
fragmentName (Module _ Nothing _ _ _) =
"<unnamed module>"
fragmentName (XmlPage _ (ModuleName _ theName) _ _ _ _ _) = "XML page " ++ theName
fragmentName (XmlHybrid _ (Just (ModuleHead _ (ModuleName _ theName) _ _))
_ _ _ _ _ _ _) = "module with XML " ++ theName
fragmentName (XmlHybrid _ Nothing _ _ _ _ _ _ _ ) = "<unnamed module with XML>"
moduleT :: Proxy (Module SrcLoc)
moduleT = Proxy
instance CodeFragment TypeSignature where
type AST TypeSignature = Decl SrcLoc
matchAST (TypeSig loc identifiers theType) = Just TypeSignature {..}
matchAST _ = Nothing
fragmentName TypeSignature {..} = "type signature for "
++ intercalate ", " (map unName identifiers)
unName :: Name a -> String
unName (Symbol _ s) = s
unName (Ident _ i) = i