Module.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}

module Descript.Free.Data.Import.Module
  ( ModulePath (..)
  , ModuleDecl (..)
  , defModuleDecl
  , moduleDeclScope
  , modulePathScope
  ) where

import Descript.Free.Data.Atom
import Descript.Misc
import Data.Monoid
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty

-- | A path to a module.
data ModulePath an
  = ModulePath
  { modulePathAnn :: an
  , modulePathElems :: NonEmpty (Symbol an)
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | An module declaration.
data ModuleDecl an
  = ModuleDecl
  { moduleDeclAnn :: an
  , moduleDeclPath :: ModulePath an
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

instance Ann ModuleDecl where
  getAnn = moduleDeclAnn

instance Ann ModulePath where
  getAnn = modulePathAnn

instance Printable ModuleDecl where
  aprintRec sub (ModuleDecl _ path) = pimp' $ "module " <> sub path
    where pimp' = pimpIf $ NonEmpty.length (modulePathElems path) == 1

instance Printable ModulePath where
  aprintRec sub (ModulePath _ syms)
    = pintercal ">" $ map sub $ NonEmpty.toList syms

instance (Show an) => Summary (ModuleDecl an) where
  summaryRec = pprintSummaryRec

instance (Show an) => Summary (ModulePath an) where
  summaryRec = pprintSummaryRec

-- | If a module declaration isn't provided in a source file, this one
-- is implicitly used. Contains one path element - the file's name.
defModuleDecl :: SFile -> ModuleDecl ()
defModuleDecl = ModuleDecl () . scopeModulePath . defaultFileScope

scopeModulePath :: AbsScope -> ModulePath ()
scopeModulePath = ModulePath () . NonEmpty.map (Symbol ()) . absScopePath

-- | The scope of a module with this declaration.
moduleDeclScope :: ModuleDecl an -> AbsScope
moduleDeclScope (ModuleDecl _ path) = modulePathScope path

modulePathScope :: ModulePath an -> AbsScope
modulePathScope (ModulePath _ xs) = AbsScope $ NonEmpty.map symbolLiteral xs