ASTHandler.hs

{-# LANGUAGE ExistentialQuantification #-}

module UHC.Light.Compiler.EHC.ASTHandler
( ASTParser (..)
, ASTLens
, 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.Base
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" #-}
type ASTLens ast = Lens EHCompileUnit (Maybe ast)

{-# LINE 63 "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

		  --- * AST

		  --- | Lens into AST, if any
		  , _asthdlrASTLens 			:: Maybe (ASTLens ast)

		  --- * 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 pretty printed text version as AST with trace info
		  , _asthdlrPrettyTrace			:: 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

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

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

		  --- * AST info extraction

		  --- | Module name and imports
		  , _asthdlrModnameImports 		:: forall m . EHCCompileRunner m => PrevFileSearchKey -> EHCompilePhaseT m (Maybe (HsName,[HsName]))

		  --- * AST predicates

		  --- | Is valid?
		  , _asthdlrASTIsValid 		:: ast -> Bool

		  }
		  deriving Typeable

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

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

      , _asthdlrEcuStore			= const id

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

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

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

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

{-# LINE 201 "src/ehc/EHC/ASTHandler.chs" #-}
-- | Per suffix AST specific info
data ASTSuffixInfo ast
  = ASTSuffixInfo
      { _astsuffinfoSuff		:: String
      , _astsuffinfoASTLensMp	:: Map.Map ASTFileTiming (ASTLens ast)
      , _astsuffinfoModfTimeMp	:: Map.Map ASTFileTiming (Lens EHCompileUnit (Maybe ClockTime))
      , _astsuffinfoUpdParseOpts:: EHParseOpts -> EHParseOpts
      }
  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 221 "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 (ASTLens ast)
       , AssocL ASTFileTiming (Lens EHCompileUnit (Maybe ClockTime))
       , EHParseOpts -> EHParseOpts
       )
     -> ASTSuffixRel ast
mkASTSuffixRel' l = Rel.fromList
  [ ( sk
    , ASTSuffixInfo
        s
        (Map.fromList il)
        (Map.fromList cl)
        updopts
    )
  | (sk,(s,il,cl,updopts)) <- l
  ]

mkASTSuffixRel
  :: AssocL
       ASTSuffixKey
       ( String
       , ASTLens ast
       , Maybe (Lens EHCompileUnit (Maybe ClockTime))
       )
     -> ASTSuffixRel ast
mkASTSuffixRel l = mkASTSuffixRel' $
  [ ( sk
    , ( s
      , [(ASTFileTiming_Current,i)]
      , maybe [] (\c -> [(ASTFileTiming_Current,c)]) mc
      , id
    ) )
  | (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 (ASTLens ast)
astsuffixLookupLens sk tk r = do
  i <- astsuffixLookup sk r
  Map.lookup tk $ _astsuffinfoASTLensMp i

{-# LINE 294 "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 306 "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_ASTText -> do
        case _asthdlrPrettyTrace 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 331 "src/ehc/EHC/ASTHandler.chs" #-}
-- | Construct a FPath given a handler
asthdlrMkInputFPath :: ASTHandler' ast -> EHCOpts -> EHCompileUnit -> ASTFileSuffOverride -> HsName -> FPath -> FPath
asthdlrMkInputFPath hdlr opts ecu overr modNm fp = _asthdlrMkInputFPath hdlr opts ecu modNm fp suff
  where suff = case overr of
          ASTFileSuffOverride_Suff skey -> maybe "" id $ astsuffixLookupSuff skey $ _asthdlrSuffixRel hdlr
          ASTFileSuffOverride_AsIs      -> fpathSuff fp