ASTHandler.hs

{-# LANGUAGE ExistentialQuantification #-}

module UHC.Light.Compiler.EHC.ASTHandler
( ASTParser (..)
, ASTHandler' (..)
, emptyASTHandler'
, ASTHandler (..)
, ASTHandlerMp
, ASTSuffixInfo (..)
, ASTSuffixRel, mkASTSuffixRel, mkASTSuffixRel', emptyASTSuffixRel, astsuffixLookup, astsuffixLookupSuff, astsuffixLookupLens
, asthdlrOutputIO
, asthdlrMkInputFPath
, astsuffixLookupTmLens )
where
import UHC.Light.Compiler.EHC.Common
import UHC.Light.Compiler.EHC.CompileUnit
import UHC.Light.Compiler.EHC.CompileRun
import Data.Typeable
import GHC.Generics
import qualified Data.Map as Map
import qualified UHC.Util.RelMap as Rel
import UHC.Util.Lens
import qualified UHC.Util.ScanUtils as ScanUtils
import UHC.Light.Compiler.Base.ParseUtils
import UHC.Util.Time



{-# LINE 41 "src/ehc/EHC/ASTHandler.chs" #-}
data ASTParser ast
  = forall prs inp sym symmsg pos .
      ( EHParser prs inp sym symmsg pos
      ) =>
		ASTParser
		  { unASTParser 	:: EHPrs prs inp sym pos ast
		  }

{-# LINE 55 "src/ehc/EHC/ASTHandler.chs" #-}
data ASTHandler' ast
  = -- forall prs inp sym symmsg pos . -- msg .
      -- ( PP msg
      -- , EHParser prs inp sym symmsg pos
      -- ) =>
		ASTHandler'
		  {
		  --- * Meta

		  --- | Meta info: name of ast
			_asthdlrName				:: !String

		  --- * File

		  --- | Construct output FPath from module name, path, suffix
		  , _asthdlrMkInputFPath		:: EHCOpts -> EHCompileUnit -> HsName -> FPath -> String -> FPath

		  --- | Construct output FPath from module name, path, suffix
		  , _asthdlrMkOutputFPath		:: EHCOpts -> HsName -> FPath -> String -> FPath

		  --- | Suffix info
		  , _asthdlrSuffixRel			:: ASTSuffixRel ast

		  --- * Compile unit

		  --- | Update EHCompileUnit
		  , _asthdlrEcuStore			:: EcuUpdater ast

		  --- * Output, pretty printing

		  --- | Generate a pretty printed text version
		  , _asthdlrPretty				:: EHCOpts -> EHCompileUnit -> ast -> Maybe PP_Doc

		  --- | Generate a serialized binary version directly on file, yielding True if this could be done
		  , _asthdlrPutSerializeFileIO 	:: FilePath -> ast -> IO Bool

		  --- * Output

		  --- | Write to an ast to a file in the IO monad, return True if could be done
		  , _asthdlrOutputIO			:: ASTFileContent -> EHCOpts -> EHCompileUnit -> HsName -> FPath -> FilePath -> ast -> IO Bool

		  --- * Input, textual, parsing

		  --- | Scanning parameterisation
		  , _asthdlrParseScanOpts 		:: EHCOpts -> EHParseOpts -> ScanUtils.ScanOpts

		  --- | Parsing
		  , _asthdlrParser				:: EHCOpts -> EHParseOpts -> Maybe (ASTParser ast)

		  --- * Input, parsing

		  --- | Input an ast
		  , _asthdlrInput				:: forall m . EHCCompileRunner m => ASTFileContent -> HsName -> EHCompilePhaseT m (Maybe ast)

		  --- | Read/decode from serialized binary version on file
		  , _asthdlrGetSerializeFileIO 	:: EHCOpts -> FPath -> IO (Maybe ast)

		  --- | Check after deserialization
		  , _asthdlrPostInputCheck 		:: EHCOpts -> EHCompileUnit -> HsName -> FPath -> ast -> [Err]

		  }
		  deriving Typeable

{-# LINE 124 "src/ehc/EHC/ASTHandler.chs" #-}
emptyASTHandler' :: forall ast . ASTHandler' ast
emptyASTHandler'
  = ASTHandler'
      { _asthdlrName 				= "Unknown AST"
      , _asthdlrSuffixRel 			= (emptyASTSuffixRel :: ASTSuffixRel ast)

      , _asthdlrMkInputFPath		= \_ _ _ fp s -> fpathSetSuff s fp
      , _asthdlrMkOutputFPath		= mkOutputFPath

      , _asthdlrEcuStore			= const id

      , _asthdlrPretty				= \_ _ _ -> Nothing
      , _asthdlrPutSerializeFileIO	= \_ _ -> return False
      , _asthdlrOutputIO 			= \_ _ _ _ _ _ _ -> return False

      , _asthdlrInput 				= \_ _ -> return Nothing
      , _asthdlrParseScanOpts		= \_ _ -> ScanUtils.defaultScanOpts
      , _asthdlrParser				= \_ _ -> (Nothing :: Maybe (ASTParser ast))
      , _asthdlrGetSerializeFileIO	= \_ _ -> return Nothing
      , _asthdlrPostInputCheck		= \_ _ _ _ _ -> []
      }

{-# LINE 156 "src/ehc/EHC/ASTHandler.chs" #-}
data ASTHandler
  = forall ast .
      Typeable ast =>
        ASTHandler (ASTHandler' ast)

{-# LINE 163 "src/ehc/EHC/ASTHandler.chs" #-}
type ASTHandlerMp = Map.Map ASTType ASTHandler

{-# LINE 171 "src/ehc/EHC/ASTHandler.chs" #-}
-- | Per suffix AST specific info
data ASTSuffixInfo ast
  = ASTSuffixInfo
      { _astsuffinfoSuff		:: String
      , _astsuffinfoASTLensMp	:: Map.Map ASTFileTiming (Lens EHCompileUnit (Maybe ast))
      , _astsuffinfoModfTimeMp	:: Map.Map ASTFileTiming (Lens EHCompileUnit (Maybe ClockTime))
      }
  deriving (Typeable, Generic)

instance Eq (ASTSuffixInfo ast) where
  i1 == i2 = _astsuffinfoSuff i1 == _astsuffinfoSuff i2

instance Ord (ASTSuffixInfo ast) where
  i1 `compare` i2 = _astsuffinfoSuff i1 `compare` _astsuffinfoSuff i2

{-# LINE 190 "src/ehc/EHC/ASTHandler.chs" #-}
type ASTSuffixRel ast = Rel.Rel ASTSuffixKey (ASTSuffixInfo ast)

emptyASTSuffixRel :: ASTSuffixRel ast
emptyASTSuffixRel = Rel.empty

mkASTSuffixRel'
  :: AssocL
       ASTSuffixKey
       ( String
       , AssocL ASTFileTiming (Lens EHCompileUnit (Maybe ast))
       , AssocL ASTFileTiming (Lens EHCompileUnit (Maybe ClockTime))
       )
     -> ASTSuffixRel ast
mkASTSuffixRel' l = Rel.fromList
  [ ( sk
    , ASTSuffixInfo
        s
        (Map.fromList il)
        (Map.fromList cl)
    )
  | (sk,(s,il,cl)) <- l
  ]

mkASTSuffixRel
  :: AssocL
       ASTSuffixKey
       ( String
       , Lens EHCompileUnit (Maybe ast)
       , Maybe (Lens EHCompileUnit (Maybe ClockTime))
       )
     -> ASTSuffixRel ast
mkASTSuffixRel l = mkASTSuffixRel' $
  [ ( sk
    , ( s
      , [(ASTFileTiming_Current,i)]
      , maybe [] (\c -> [(ASTFileTiming_Current,c)]) mc
    ) )
  | (sk,(s,i,mc)) <- l
  ]

-- | Lookup suffix info
astsuffixLookup :: ASTSuffixKey -> ASTSuffixRel ast -> Maybe (ASTSuffixInfo ast)
astsuffixLookup = Rel.lookupDom

-- | Lookup suffix
astsuffixLookupSuff :: ASTSuffixKey -> ASTSuffixRel ast -> Maybe String
astsuffixLookupSuff k r = fmap _astsuffinfoSuff $ astsuffixLookup k r

-- | Lookup lens
astsuffixLookupLens :: ASTSuffixKey -> ASTFileTiming -> ASTSuffixRel ast -> Maybe (Lens EHCompileUnit (Maybe ast))
astsuffixLookupLens sk tk r = do
  i <- astsuffixLookup sk r
  Map.lookup tk $ _astsuffinfoASTLensMp i

{-# LINE 260 "src/ehc/EHC/ASTHandler.chs" #-}
-- | Lookup lens for modf time of
astsuffixLookupTmLens :: ASTSuffixKey -> ASTFileTiming -> ASTSuffixRel ast -> Maybe (Lens EHCompileUnit (Maybe ClockTime))
astsuffixLookupTmLens sk tk r = do
  i <- astsuffixLookup sk r
  Map.lookup tk $ _astsuffinfoModfTimeMp i

{-# LINE 272 "src/ehc/EHC/ASTHandler.chs" #-}
-- | Write to an ast to a file in the IO monad, return True if could be done
asthdlrOutputIO :: ASTHandler' ast -> ASTFileContent -> EHCOpts -> EHCompileUnit -> HsName -> FPath -> FilePath -> ast -> IO Bool
asthdlrOutputIO hdlr how opts ecu modNm fpC fnC ast = do
    fpathEnsureExists fpC
    case how of
      ASTFileContent_Text -> do
        case _asthdlrPretty hdlr opts ecu ast of
          Just ppAst -> do
            putPPFPath fpC ppAst 1000
            return True
          _ -> return False
      ASTFileContent_Binary -> do
        _asthdlrPutSerializeFileIO hdlr fnC ast
      _ -> return False

{-# LINE 291 "src/ehc/EHC/ASTHandler.chs" #-}
-- | Construct a FPath given a handler
asthdlrMkInputFPath :: ASTHandler' ast -> EHCOpts -> EHCompileUnit -> ASTSuffixKey -> HsName -> FPath -> FPath
asthdlrMkInputFPath hdlr opts ecu skey modNm fp = _asthdlrMkInputFPath hdlr opts ecu modNm fp suff
  where suff = maybe "" id $ astsuffixLookupSuff skey $ _asthdlrSuffixRel hdlr