{-|
Module      : MetaHS.DataModel.MetaModel
Description : The MetaHS metamodel
Copyright   : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps
License     : -- This file is distributed under the  terms of the Apache License 2.0.
              For more information, see the file "LICENSE", which is included in the distribution.
Stability   : experimental
MetaHS metamodel
-}

{-# OPTIONS_GHC -funbox-strict-fields #-}

module MetaHS.DataModel.MetaModel
    ( Element(..)
    , Pair
    , Relation
    , MetaModel(..)
    , pPrint
    ) where

import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Text.PrettyPrint
import Text.PrettyPrint.HughesPJClass
import Prelude hiding ((<>))

-- | The various elements that can be used in the metamodel.
data Element
    = Program
        { name :: !String
        -- ^ The name of the program.
        }
    -- ^ Top level program
    | Module
        { name :: !String
        -- ^ The qualified name of the module.
        }
    -- ^ Represents a module
    | ModuleHead
        { name :: !String
        -- ^ The qualified name of the module.
        }
    -- ^ Represents a module head
    | ModuleImport
        { name :: !String
        -- ^ The qualified name of the imported module.
        }
    -- ^ Represents a module import
    | ModuleExport
        { name :: !String
        -- ^ The qualified name of the exported module.
        }
    -- ^ Represents a module export
    | Function
        { name :: !String
        -- ^ The qualified name of the function.
        }
    -- ^ Represents a function
    | DataType
        { name :: !String
        -- ^ The qualified name of the data declaration.
        }
    -- ^ Represents a datatype declaration.
    | TypeSynonym
        { name :: !String
        -- ^ The qualified name of the type synonym.
        }
    -- ^ Represents a type synonym.
    | TypeSignature
        { name :: !String
        -- ^ The qualified name of the type signature.
        }
        -- ^ Represents a type signature.
    | TypeClass
        { name :: !String
        -- ^ The qualified name of the type instance.
        }
        -- ^ Represents a type instance.
    | Instance
        { name :: !String
        -- ^ The qualified name of the type instance.
        }
    | Pragma
        { name :: !String
        -- ^ The qualified name of the inline Pragma.
        }
        -- ^ Represents an inline Pragma.
    | UnknownType
        { name :: !String
        -- ^ The "?" qualified name of the unknown type.
        }
    -- ^ Represents a type which is unknown.
    | Location
        { locationPath        :: !String
        -- ^ The path to the file containing the source code.
        , locationStartLine   :: !Int
        -- ^ The start line.
        , locationStartColumn :: !Int
        -- ^ The start column.
        , locationEndLine     :: !Int
        -- ^ The end line.
        , locationEndColumn   :: !Int
        -- ^ The end column.
        }
    -- ^ Represents a source code location.
    | StringValue
        { stringValue :: !String
        -- ^ The String value.
        }
    -- ^ Contains a generic String value.
    | IntValue
        { intValue :: !Int
        -- ^ The Int value.
        }
    -- ^ Contains a generic Int value.
    deriving (Show, Read, Eq, Ord)

-- | A Pair is defined as a tuple of Elements
type Pair = (Element,Element)

-- | A relation is defined as a set of Pair types.
--   E.g., _contains, _source, _uses, LCOM
type Relation = Set.Set (Element,Element)

-- | A metamodel is implemented as a mapping between a String and Relation.
--   The key string will denote the type of relation between the pairs in the
--   value relation.
type MetaModelImpl = Map.Map String Relation

-- | The MetaModel type.
newtype MetaModel = MetaModel { getMetaModelImpl :: MetaModelImpl }
    deriving (Read,Show)

-- | Pretty print instance for Elements.
instance Pretty Element where
    pPrint Program { name = n } = text "Program" <+> qt n
    pPrint Module { name = n } = text "Module" <+> qt n
    pPrint ModuleHead { name = n } = text "ModuleHead" <+> qt n
    pPrint ModuleImport { name = n } = text "ModuleImport" <+> qt n
    pPrint ModuleExport { name = n } = text "ModuleExport" <+> qt n
    pPrint Function { name = n } = text "Function" <+> qt n
    pPrint DataType { name = n } = text "DataType" <+> qt n
    pPrint TypeSynonym { name = n } = text "TypeSynonym" <+> qt n
    pPrint TypeSignature { name = n } = text "TypeSignature" <+> qt n
    pPrint TypeClass { name = n } = text "TypeClass" <+> qt n
    pPrint Instance { name = n } = text "Instance" <+> qt n
    pPrint Pragma { name = n } = text "Pragma" <+> qt n
    pPrint UnknownType { name = n } = text "UnknownType" <+> qt n
    pPrint Location { locationPath = p
                    , locationStartLine = sl
                    , locationStartColumn = sc
                    , locationEndLine = el
                    , locationEndColumn = ec
                    } = text "Location" <+> qt p <+> int sl <+> int sc
                        <+> int el <+> int ec
    pPrint StringValue { stringValue = v } = text "StringValue" <+> qt v
    pPrint IntValue { intValue = v } = text "IntValue" <+> qt (show v)

-- | Pretty print instance for the MetaModel.
instance Pretty MetaModel where
    pPrint metaModel =
        if null metaModelMap
        then
            text "MetaModel"
        else
            text "MetaModel" $$
            vcat ( map f (Map.keys metaModelMap) ) $$
            text ""
        where
            metaModelMap = getMetaModelImpl metaModel

            f :: String -> Doc
            f key = -- function f iterates through the keys
                text "  " <> text (show key) <> char ':' $$
                g ( fromMaybe Set.empty $ Map.lookup key metaModelMap)

            g :: Relation -> Doc
            g relation =
                if null relation
                then
                    text ""
                else
                    vcat . map (docLine "    ") $ Set.elems relation
                where
                    docLine prefix v = text prefix <> pPrint v

-- | Returns the provided String as a quoted Doc
qt :: String -> Doc
qt t = char '"' <> text t <> char '"'