content: {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE LambdaCase                 #-}
  {-# LANGUAGE MultiParamTypeClasses      #-}
  {-# LANGUAGE QuasiQuotes                #-}
  {-# LANGUAGE TemplateHaskell            #-}
  
  --
  -- Ivory QuasiQuoter.
  --
  -- Copyright (C) 2014, Galois, Inc.
  -- All rights reserved.
  --
  
  module Ivory.Language.Syntax.Concrete.QQ
    ( ivory
    , ivoryFile
    , ivoryBlk
    )
      where
  
  import           Data.Char
  import           Data.Maybe
  import qualified Data.Text.Lazy                              as L
  import qualified Data.Text.Lazy.IO                           as L
  import           Prelude                                     hiding (const, exp,
                                                                init)
  import           System.FilePath
  
  import           Language.Haskell.TH                         hiding (Exp, Stmt,
                                                                Type)
  import qualified Language.Haskell.TH                         as Q
  import           Language.Haskell.TH.Quote
  import           Language.Haskell.TH.Syntax                  (addDependentFile)
  
  import qualified Ivory.Language.Const                        as I
  import qualified Ivory.Language.Module                       as I
  import qualified Ivory.Language.Proxy                        as I
  import qualified Ivory.Language.Syntax                       as I
  
  import           Ivory.Language.Syntax.Concrete.QQ.AreaQQ
  import           Ivory.Language.Syntax.Concrete.QQ.BitDataQQ
  import           Ivory.Language.Syntax.Concrete.QQ.Common
  import           Ivory.Language.Syntax.Concrete.QQ.ExprQQ
  import           Ivory.Language.Syntax.Concrete.QQ.ProcQQ
  import           Ivory.Language.Syntax.Concrete.QQ.StmtQQ
  import           Ivory.Language.Syntax.Concrete.QQ.StructQQ
  import           Ivory.Language.Syntax.Concrete.QQ.TypeQQ
  
  import           Ivory.Language.Syntax.Concrete.Lexer        (scan)
  import           Ivory.Language.Syntax.Concrete.ParseAST     hiding (tyDef)
  import qualified Ivory.Language.Syntax.Concrete.ParseCore    as P
  import qualified Ivory.Language.Syntax.Concrete.Parser       as P
  
  --------------------------------------------------------------------------------
  
  mkParser :: P.Parser a -> FilePath -> L.Text -> a
  mkParser p fp txt = P.runParser (scan fp txt) p
  
  topParser :: FilePath -> L.Text -> [GlobalSym]
  topParser = mkParser P.topParser
  
  stmtsParser :: FilePath -> L.Text -> [Stmt]
  stmtsParser = mkParser P.stmtsParser
  
  --------------------------------------------------------------------------------
  -- QuasiQuoters
  
  -- | Quasiquoter for defining Ivory statements in C-like syntax.  No module
  -- generated.
  ivory :: QuasiQuoter
  ivory = justDecQQ decP
    where
    decP str = do
      loc <- location
      let defs = reverse (topParser (loc_filename loc) (L.pack str))
      decs    <- mapM mkDef defs
      return (concat decs)
  
  -- | Quasiquoter for defining blocks of Ivory statements.
  ivoryBlk :: QuasiQuoter
  ivoryBlk = justExpQQ stmtsP
    where
    stmtsP str = do
      loc <- location
      let ss = reverse (stmtsParser (loc_filename loc) (L.pack str))
      fromProgram ss
  
  -- | Parse a file.  Use
  --
  -- ivoryFile|foo.ivory|]
  --
  -- To parse file ```foo.ivory``` Generates a module definition by default with a
  -- module name that is constructed from the filename and path such that
  --
  -- "dira/dirb/foobar.ivory"
  --
  -- has a module name
  --
  -- diradirbfoobar
  --
  -- Like `quoteFile` except we also process the filename.
  ivoryFile :: QuasiQuoter
  ivoryFile = justDecQQ decP
    where
    decP filePath = do
      str <- runIO (L.readFile filePath)
      addDependentFile filePath
      let defs      = reverse (topParser filePath str)
      decs         <- mapM mkDef defs
      let fileName  = concat
                    $ filter (not . (any isPathSeparator))
                    $ splitDirectories
                    $ dropExtensions filePath
      theModule    <- ivoryMod (map toLower fileName)
                               (catMaybes $ map getModData defs)
      return (concat decs ++ theModule)
  
  justDecQQ :: (String -> Q [Dec]) -> QuasiQuoter
  justDecQQ decQQ = QuasiQuoter
    { quoteExp  = err "quoteExp"
    , quotePat  = err "quotePat"
    , quoteDec  = decQQ
    , quoteType = err "quoteType"
    }
    where
    err str = error $ str ++ " not implemented for Ivory quasiquoter."
  
  justExpQQ :: (String -> Q Q.Exp) -> QuasiQuoter
  justExpQQ expQQ = QuasiQuoter
    { quoteExp  = expQQ
    , quotePat  = err "quotePat"
    , quoteDec  = err "quoteDec"
    , quoteType = err "quoteType"
    }
    where
    err str = error $ str ++ " not implemented for Ivory quasiquoter."
  
  --------------------------------------------------------------------------------
  
  -- | Filter module data from all global definitions.
  getModData :: GlobalSym -> Maybe ModuleData
  getModData sym = case sym of
    GlobalProc        d -> Just (ModProc d)
    GlobalInclProc    d -> Just (ModImportProc d)
    GlobalExtern      e -> Just (ModExtern e)
    GlobalStruct      d -> Just (ModStruct d)
    GlobalBitData{}     -> Nothing
    GlobalTypeDef{}     -> Nothing
    GlobalConstDef{}    -> Nothing
    GlobalInclude     d -> Just (ModInclude d)
    GlobalArea        a -> Just (ModArea a)
    GlobalAreaImport  a -> Just (ModAreaImport a)
  
  mkDef :: GlobalSym -> Q [Dec]
  mkDef def = case def of
    GlobalProc       d      -> fromProc d
    GlobalInclProc   d      -> fromInclProc d
    GlobalExtern     e      -> fromExtern e
    GlobalStruct     d      -> fromStruct d
    GlobalBitData    d      -> fromBitData d
    GlobalTypeDef    tyDef  -> fromTypeDef tyDef
    GlobalConstDef   const  -> fromConstDef const
    GlobalArea       a      -> fromArea a
    GlobalAreaImport a      -> fromAreaImport a
    -- No definition to make for includes, source depends.
    GlobalInclude{}         -> return []
  
  -- | Define an Ivory module, one per Haskell module.
  ivoryMod :: String -> [ModuleData] -> Q [Dec]
  ivoryMod _modName []    = return []
  ivoryMod  modName incls = do
    modTy <- mkModTy
    mi    <- modImp
    return [modTy, mi]
    where
    modImp :: Q Dec
    modImp = do
      bd <- modBody
      return $ ValD (VarP $ mkName modName)
                    (NormalB bd)
                    []
  
    modBody = do
      nm       <- stringE modName
      let pkg   = AppE (VarE 'I.package) nm
      let doblk = map (NoBindS . ivorySymMod) incls
      return (AppE pkg (DoE doblk))
  
    mkModTy = return $ SigD (mkName modName) (ConT ''I.Module)
  
    -- | Include an Ivory symbol into the Ivory module.
    ivorySymMod :: ModuleData -> Q.Exp
    ivorySymMod m = case m of
      ModProc   d
        -> AppE (VarE 'I.incl) (VarE $ mkName (procSym d))
      ModStruct d
        -> AppE (VarE 'I.defStruct)
                (SigE (ConE 'I.Proxy)
                      (AppT (ConT ''I.Proxy) (LitT (StrTyLit (structSym d)))))
      ModInclude incl
        -> AppE (VarE 'I.depend) (VarE $ mkName $ inclModule incl)
      ModImportProc proc
        -> AppE (VarE 'I.incl) (VarE $ mkName $ procInclSym proc)
      ModExtern ext
        -> AppE (VarE 'I.inclSym) (VarE $ mkName $ externSym ext)
      ModArea a
        -> AppE (VarE d) (VarE $ mkName $ allocRefVar $ areaInit a)
        where
          d = if areaConst a then 'I.defConstMemArea else 'I.defMemArea
      ModAreaImport a
        -> AppE (VarE d) (VarE $ mkName $ aiSym a)
        where
          d = if aiConst a then 'I.defConstMemArea else 'I.defMemArea
  
  
  
  --------------------------------------------------------------------------------
  
  -- | Data to put in the Ivory module.
  data ModuleData =
      ModProc       ProcDef
    | ModStruct     StructDef
    | ModInclude    IncludeDef
    | ModImportProc IncludeProc
    | ModExtern     Extern
    | ModArea       AreaDef
    | ModAreaImport AreaImportDef
    deriving (Show, Read, Eq, Ord)
  
  --------------------------------------------------------------------------------
  
  fromExtern :: Extern -> Q [Dec]
  fromExtern (Extern sym file ty loc) = do
    tyQ <- runToQ (fromType ty)
    d   <- def
    let nm  = mkName sym
    let imp = ValD (VarP nm) (NormalB d) []
    ln  <- lnPragma loc
    return (ln ++ [SigD nm (fst tyQ), imp])
    where
    def = do
      let nm = AppE (VarE 'I.extern) (LitE $ StringL sym)
      return (AppE nm (LitE $ StringL file))
  
  --------------------------------------------------------------------------------
  
  -- My own `quoteFile` implementation to grab the file name to pass to module
  -- construction.
  -- quoteFile :: QuasiQuoter -> QuasiQuoter
  -- quoteFile (QuasiQuoter { quoteExp  = qe
  --                        , quotePat  = qp
  --                        , quoteType = qt
  --                        , quoteDec  = qd }
  --           )
  --   = QuasiQuoter { quoteExp  = get qe
  --                 , quotePat  = get qp
  --                 , quoteType = get qt
  --                 , quoteDec  = get qd
  --                 }
  --   where
  --    get :: (String -> Q a) -> String -> Q a
  --    get old_quoter file_name = do file_cts <- runIO (readFile file_name)
  --                                  addDependentFile file_name
  --                                  old_quoter file_cts
  --                                  return file_name
  
  --------------------------------------------------------------------------------
  
  -- Testing
  
  {-
  dump :: QuasiQuoter
  dump = QuasiQuoter
    { quoteExp  = \str -> return $ LitE (StringL str)
    }
  -}
  