modelable

{-# LANGUAGE DefaultSignatures, DeriveGeneric, TypeOperators, FlexibleContexts, StandaloneDeriving, ScopedTypeVariables, FlexibleInstances, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}

module Main (
    main
) where

import Data.Text (Text)

import qualified Data.Map as Map
import Data.Foldable (Foldable)
import qualified Data.Foldable as Foldable
import Data.Traversable (Traversable)
import qualified Data.Traversable as Traversable

import Data.List

import GHC.Generics hiding (moduleName)
import qualified GHC.Generics

-- A type representation

data TypeName = TypeName { moduleName :: String, typeName :: String }
    deriving (Show, Eq, Ord)
    
data TypeDefF t = Declare { declared :: TypeDeclF t }
                | Import { imported :: TypeName }
    deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
    
data TypeDeclF t = Data { fullName :: TypeName, typeVariables :: Integer, constructors :: [ConstructorDeclF t] }
    deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

type TypeDecl = TypeDeclF TypeExpr
    
data ConstructorDeclF t = ConstructorDeclF { constructorName :: String, fields :: [FieldDeclF t] }
    deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

data FieldDeclF t = FieldDeclF { fieldName :: String, fieldType :: t }
    deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
   
data TypeExprF t = Type t | Variable Integer | Application (TypeExprF t) (TypeExprF t)
    deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

type TypeExpr = TypeExprF TypeName
    
definedType :: TypeDefF t -> TypeName
definedType (Declare d) = fullName d
definedType (Import i) = i

isDeclare :: TypeDefF t -> Bool
isDeclare (Declare _) = True
isDeclare _ = False

declarations :: [TypeDefF t] -> [TypeDeclF t]
declarations = map declared . filter isDeclare

joinTypeExpr :: TypeExprF (TypeExprF t) -> TypeExprF t
joinTypeExpr (Type t) = t
joinTypeExpr (Application f a) = Application (joinTypeExpr f) (joinTypeExpr a)
joinTypeExpr (Variable x) = Variable x

data RecursiveTypeExpr = Fix { unFix :: TypeExprF (TypeDefF RecursiveTypeExpr) }


simplifyTypeExpr :: RecursiveTypeExpr -> TypeExpr
simplifyTypeExpr = fmap definedType . unFix

-- A type, with dependencies

data DataModelF t = DataModel { rootType :: TypeExpr, dependencies :: Map.Map TypeName (TypeDeclF t) }
    deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
    
type DataModel = DataModelF TypeExpr
    

emptyModel :: TypeName -> RecursiveTypeExpr
emptyModel = Fix . Type . Import

externalModel :: String -> String -> RecursiveTypeExpr
externalModel moduleName typeName = emptyModel TypeName {moduleName = moduleName, typeName = typeName }

simplifyDecl :: (Functor f) => f RecursiveTypeExpr -> f TypeExpr
simplifyDecl = fmap simplifyTypeExpr

flattenModel :: RecursiveTypeExpr -> DataModel
flattenModel model = DataModel {
    rootType = simplifyTypeExpr model,
    dependencies = allDependencies model
}

referencedDefinitions :: RecursiveTypeExpr -> [TypeDefF RecursiveTypeExpr]
referencedDefinitions = Foldable.toList . unFix

allDependencies :: RecursiveTypeExpr -> Map.Map TypeName TypeDecl
allDependencies = go Map.empty . referencedBy
    where
        go ::  Map.Map TypeName (TypeDeclF RecursiveTypeExpr) ->  Map.Map TypeName (TypeDeclF RecursiveTypeExpr) ->  Map.Map TypeName TypeDecl
        go explored unexplored =
            if Map.null unexplored
            then fmap simplifyDecl explored
            else go nowExplored nowUnexplored
                where
                    nowExplored = Map.union explored unexplored
                    referenced = Map.unions . map referencedBy . concatMap Foldable.toList . Map.elems $ unexplored
                    nowUnexplored = Map.difference referenced nowExplored
        referencedBy :: RecursiveTypeExpr -> Map.Map TypeName (TypeDeclF RecursiveTypeExpr)
        referencedBy = Map.fromList . map (\x -> (fullName x, x)) . declarations . referencedDefinitions

flatModel :: (Modelable a) => a -> DataModel
flatModel = flattenModel . dataModel

 
-- Modelable class
           
class Modelable a where
    dataModel :: a -> RecursiveTypeExpr

    default dataModel :: (Generic a, GModelable (Rep a)) => a -> RecursiveTypeExpr
    dataModel (_ :: a) = gdataModel (undefined :: Rep a ())

class Modelable1 f where
    dataModel1 :: (Modelable a) => f a -> RecursiveTypeExpr

    default dataModel1 :: (Generic1 f, GModelable (Rep (f a)), Modelable a) => f a -> RecursiveTypeExpr
    dataModel1 (_ :: f a) = gdataModel (undefined :: Rep (f a) ())
    
instance (Modelable1 f, Modelable a) => Modelable (f a) where
    dataModel = dataModel1
    
-- GModelable
    
class GModelable f where
    gdataModel :: f () -> RecursiveTypeExpr

class GConstructors f where
    gconstructors :: f () -> [ConstructorDeclF RecursiveTypeExpr]
        
class GFields f where
    gfields :: f () -> [FieldDeclF RecursiveTypeExpr]
   
    

-- Data types
        
instance (GConstructors a, Datatype d) => GModelable (M1 D d a) where
    gdataModel d = (Fix . Type . Declare) Data {
            fullName = TypeName {moduleName = GHC.Generics.moduleName d, typeName = datatypeName d},
            typeVariables = 0,
            constructors = gconstructors (undefined :: a ())
    }   

-- Construtors

instance (GConstructors a, GConstructors b) => GConstructors ((:+:) a  b) where
    gconstructors _ = gconstructors (undefined :: a ()) ++ gconstructors (undefined :: b ())
    
instance (GFields a, Constructor c) => GConstructors (M1 C c a) where
    gconstructors c = [ConstructorDeclF {
        constructorName = conName c,
        fields = gfields (undefined :: a ())
    }]

-- Fields
    
instance (GModelable a, Selector s) => GFields (M1 S s a) where
    gfields s = [FieldDeclF (selName s) (gdataModel (undefined :: a ()))]

instance GFields U1 where
    gfields _ = []

instance (GFields a, GFields b) => GFields ((:*:) a  b) where
    gfields _ = gfields (undefined :: a ()) ++ gfields (undefined :: b ())

-- Type References
    
instance (Modelable a) => GModelable (K1 i a) where
    gdataModel _ = dataModel (undefined :: a)


-- GTypeable

class GTypeable f where
    gtype :: f () -> TypeName
    
instance (Datatype d) => GTypeable (M1 D d a) where
    gtype d = TypeName {moduleName = GHC.Generics.moduleName d, typeName = datatypeName d}
    
defaultExternalModel :: (Generic a, GTypeable (Rep a)) => a -> RecursiveTypeExpr
defaultExternalModel (_ :: a) = emptyModel . gtype $ (undefined :: Rep a ())
    
-- DataModel

instance Modelable Bool where
    dataModel = defaultExternalModel
instance Modelable Char where
    dataModel = defaultExternalModel	 
instance Modelable Double where
    dataModel = defaultExternalModel	 
instance Modelable Float where
    dataModel = defaultExternalModel	 
instance Modelable Int where
    dataModel = defaultExternalModel	 
instance Modelable Ordering where
    dataModel = defaultExternalModel	 
instance Modelable () where
    dataModel = defaultExternalModel

instance Modelable Text where
    dataModel _ = externalModel "Data.Text" "Text"

   

instance Modelable1 Maybe

instance Modelable1 []
 
-- example

data Concert = Concert [Artist]

deriving instance Generic Concert
instance Modelable Concert

data Album = Album Artist [Track]

deriving instance Generic Album
instance Modelable Album
    
data Artist = Artist Text Genre

deriving instance Generic Artist
instance Modelable Artist

data Track = Track Int String

deriving instance Generic Track
instance Modelable Track

data Genre = Jazz | Metal

deriving instance Generic Genre
instance Modelable Genre

data ExampleTree = Branch Int ExampleTree ExampleTree | Leaf

deriving instance Generic ExampleTree
instance Modelable ExampleTree

main = putStrLn . pretty . flatModel $ (undefined :: Album)

-- Pretty printing

class Pretty a where
    pretty :: a -> String
    
instance Pretty (TypeName) where
    pretty name = moduleName name ++ "." ++ typeName name

instance (Pretty t) => Pretty ([TypeDeclF t]) where
    pretty = concatMap pretty 
    
instance (Pretty t) => Pretty (TypeDeclF t) where
    pretty typeDecl = "data " ++ (pretty . fullName) typeDecl ++ " " ++ (show . typeVariables) typeDecl ++ "\n" ++ (pretty . constructors) typeDecl
    
instance (Pretty t) => Pretty ([ConstructorDeclF t]) where
    pretty = concat . fmap (\c -> "\t" ++ pretty c ++ "\n" )
    
instance (Pretty t) => Pretty (ConstructorDeclF t) where
    pretty constructor = constructorName constructor ++ " " ++ (pretty . fields) constructor
    
instance (Pretty t) => Pretty ([FieldDeclF t]) where
    pretty fields =
        if all (null . fieldName) fields
        then intercalate " " . fmap pretty $ fields
        else "{ " ++ intercalate ", " (fmap pretty fields)  ++ " }"

instance (Pretty t) => Pretty (FieldDeclF t) where
    pretty field =
        if (null . fieldName) field
        then (pretty . fieldType) field
        else fieldName field ++ " :: " ++ (pretty . fieldType) field
        
instance (Pretty t) => Pretty (DataModelF t) where
    pretty model = (pretty . Map.elems . dependencies) model ++ "\n" ++ (pretty . rootType) model
    
instance (Pretty t) => Pretty (TypeExprF t) where
    pretty (Type t) = pretty t
    pretty (Variable x) = show x
    pretty (Application f a) = "(" ++ pretty f ++ " " ++ pretty a ++ ")"