content: {-|
  Copyright   :  Copyright (c) 2016, RISE SICS AB
  License     :  BSD3 (see the LICENSE file)
  Maintainer  :  rcas@acm.org
  -}
  {-
  Main authors:
    Roberto Castaneda Lozano <rcas@acm.org>
  
  Contributing authors:
    Daniel Lundén <daniel.lunden@sics.se>
  This file is part of Unison, see http://unison-code.github.io
  -}
  {-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
  module SpecsGen.Driver (SpecsGen(..), writeHsFile, runSpecsGen) where
  
  import System.FilePath
  import System.Console.CmdArgs
  import Data.Yaml
  import qualified Data.ByteString.Char8 as B8
  import Language.Haskell.Pretty
  import Data.Maybe
  import System.Directory
  import System.IO
  
  import SpecsGen.SimpleYaml
  import SpecsGen.HsGen
  import SpecsGen.OperandInfoGen
  import SpecsGen.AlignedPairsGen
  import SpecsGen.InstructionDeclGen
  import SpecsGen.ReadOpGen
  import SpecsGen.ShowInstanceGen
  import SpecsGen.ReadWriteInfoGen
  import SpecsGen.ItineraryGen
  import SpecsGen.SizeGen
  import SpecsGen.InstructionTypeGen
  import SpecsGen.AllInstructionsGen
  import SpecsGen.ItineraryDeclGen
  import SpecsGen.ParentGen
  import SpecsGen.RegisterClassDeclGen
  
  data SpecsGen =
      SpecsGen {files :: [FilePath], targetName :: String, outputDir :: String,
                constantExtend :: Bool, infiniteRegClass :: [String],
                abstractRegClass :: [String], promoteEffect :: [String],
                regClass :: [String], boundRegClass :: [String],
                rematFile :: Maybe FilePath, preProcessFile :: Maybe FilePath}
      deriving (Data, Typeable, Show)
  
  specsgen = cmdArgsMode $ SpecsGen
             {
               files = def &= args &= typ "FILES",
               targetName = "",
               outputDir = "" &= typFile,
               constantExtend = False,
               infiniteRegClass = [],
               abstractRegClass = [],
               promoteEffect = [],
               regClass = [],
               boundRegClass = [],
               rematFile = Nothing,
               preProcessFile = Nothing
             }
      &= summary "Generates partial Haskell files (.hs) with target information from the given YAML description (.yaml)\nRoberto Castaneda Lozano rcas@acm.org"
  
  runSpecsGen tPreMod tExtension =
      do sg @ SpecsGen{..} <- cmdArgsRun specsgen
         yaml  <- mapM strictReadFile files
         remat <- maybe (return "") strictReadFile rematFile
         prep  <- maybe (return "") strictReadFile preProcessFile
         let is   = concatMap yamlInstructions yaml
             is'  = maybePreProcess prep is
             is1  = expand is'
             is2  = is1 ++ extendRemats is1 (yamlInstructions remat)
             is3  = maybePreProcess prep is2
             is4  = is3 ++
                    if constantExtend then mapMaybe constantExtendedOperation is3
                    else []
             is5 = map (promote promoteEffect) is4
             is6 = map (update regClass) is5
             is7 = map (makeBound boundRegClass) is6
             is8 = tPreMod is7 -- Hand off yaml to target for target-specific modifications
             abstractRegClass' = abstractRegClass ++ ["Unknown"]
         writeHsFile outputDir "OperandInfo"
           (emitOperandInfo targetName (infiniteRegClass, abstractRegClass') is8)
         writeHsFile outputDir "AlignedPairs" (emitAlignedPairs targetName is8)
         writeHsFile outputDir (targetName ++ "InstructionDecl") (emitInstructionDecl targetName is8)
         writeHsFile outputDir "ReadOp" (emitReadOp targetName is8)
         writeHsFile outputDir "ShowInstance" (emitShowInstance targetName is8)
         writeHsFile outputDir "ReadWriteInfo" (emitReadWriteInfo targetName is8)
         writeHsFile outputDir "Itinerary" (emitItinerary targetName is8)
         writeHsFile outputDir "Size" (emitSize targetName is8)
         writeHsFile outputDir "InstructionType" (emitInstructionType targetName is8)
         writeHsFile outputDir "AllInstructions" (emitAllInstructions targetName is8)
         writeHsFile outputDir (targetName ++ "ItineraryDecl") (emitItineraryDecl targetName is8)
         writeHsFile outputDir "Parent" (emitParent targetName is8)
         writeHsFile outputDir (targetName ++ "RegisterClassDecl") (emitRegisterClassDecl targetName is8)
         tExtension sg is8
  
  maybePreProcess "" is   = is
  maybePreProcess prep is = preProcess is (yamlInstructions prep)
  
  writeHsFile dir base f =
      let name = dir </> addExtension base ".hs"
          hs   = (topComment ++ concatMap (\d -> prettyPrint d ++ "\n\n") f)
      in updateFile name hs
  
  updateFile name content =
    do oldContent <- readIfExists name
       maybeUpdateFile name oldContent content
       return ()
  
  maybeUpdateFile _ (Just oldContent) newContent
    | oldContent == newContent = return ()
  maybeUpdateFile name _ newContent =
    writeFile name newContent
  
  yamlInstructions "" = []
  yamlInstructions is = yInstructions $ simplify $ decodeYaml is
  
  topComment = "-- This file has been generated by specsgen. Do not modify by hand!\n\n"
  
  decodeYaml :: String -> Value
  decodeYaml s =
    case decodeEither $ B8.pack s of
      (Left err) -> error err
      Right yaml -> yaml
  
  readIfExists file =
    do fileExists <- doesFileExist file
       if fileExists then
         (do content <- strictReadFile file
             return (Just content))
         else return Nothing
  
  strictReadFile f =
    do h <- openFile f ReadMode
       c <- strictHGetContents h
       return c
  
  strictHGetContents h =
    do c <- hGetContents h
       length c `seq` return c
  