{-# LANGUAGE FlexibleContexts, QuasiQuotes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}

module Drasil.Generator.Code (
  -- * Generators
  genCode, genCodeZoo,
  -- * Internal Functions
  codedDirName
) where

import Prelude hiding (id)
import Control.Lens ((^.))
import Data.Char (toLower)
import Data.List (intercalate)
import Data.Time.Clock (getCurrentTime, utctDay)
import Data.Time.Calendar (showGregorian)

import Drasil.FileHandling (FileLayout, directory, ps)
import Drasil.GOOL (unJC, unPC, unCSC, unCPPC, unSC, CodeType(..), ProgData,
  OOProg, LoggingFor (unLC))
import Drasil.GProc (unJLC, unMLC, ProcProg, NativeVector)
import Language.Drasil (Space(..), Expr)
import Language.Drasil.Code (getSampleData, generateCode, generateCodeProc,
  generator, readWithDataDesc, sampleInputDD, mkCodeSpec,
  Architecture(impType, modularity),
  Choices(Choices, maps, lang, architecture, optFeats, dataInfo),
  ConstantRepr(..), ConstantStructure(..),
  DataInfo(constRepr, inputStructure, constStructure), ImplementationType(..),
  LogConfig(logging), Logging(LogVar), Maps(spaceMatch), Modularity(..),
  OptionalFeatures(logConfig), SpaceMatch, Structure(..),
  Lang(Julia, Java, Python, CSharp, Cpp, Swift, Matlab),
  HasCodeSpec(extInputs), CodeSpec, SomeProgGenerator(..))
import Language.Drasil.GOOL (unPP, unJP, unCSP, unCPPP, unSP, unJLP, unMLP,
  PackageData, SoftwareDossierSym)
import Drasil.SRS (SmithEtAlSRS, programName)

-- | Generate an ICO-style executable software artifact.
genCode :: SmithEtAlSRS -> Choices -> IO FileLayout
genCode :: SmithEtAlSRS -> Choices -> IO FileLayout
genCode SmithEtAlSRS
syst Choices
chs = PathSegment -> [FileLayout] -> FileLayout
forall (f :: * -> *).
Foldable f =>
PathSegment -> f FileLayout -> FileLayout
directory [ps|src|] ([FileLayout] -> FileLayout) -> IO [FileLayout] -> IO FileLayout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Lang -> IO FileLayout) -> [Lang] -> IO [FileLayout]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Lang -> IO FileLayout
genLangCode (Choices -> [Lang]
lang Choices
chs)
  where
    genLangCode :: Lang -> IO FileLayout
    genLangCode :: Lang -> IO FileLayout
genLangCode Lang
Java = Lang
-> (JavaCode ProgData -> ProgData)
-> (JavaProject PackageData -> PackageData)
-> IO FileLayout
forall (progRepr :: * -> *) vis smt md svr att prg
       (packRepr :: * -> *).
(OOProg progRepr vis smt md svr att prg,
 SoftwareDossierSym packRepr, Monad packRepr) =>
Lang
-> (progRepr prg -> ProgData)
-> (packRepr PackageData -> PackageData)
-> IO FileLayout
genCall Lang
Java JavaCode ProgData -> ProgData
forall a. JavaCode a -> a
unJC JavaProject PackageData -> PackageData
forall a. JavaProject a -> a
unJP
    genLangCode Lang
Python = Lang
-> (PythonCode ProgData -> ProgData)
-> (PythonProject PackageData -> PackageData)
-> IO FileLayout
forall (progRepr :: * -> *) vis smt md svr att prg
       (packRepr :: * -> *).
(OOProg progRepr vis smt md svr att prg,
 SoftwareDossierSym packRepr, Monad packRepr) =>
Lang
-> (progRepr prg -> ProgData)
-> (packRepr PackageData -> PackageData)
-> IO FileLayout
genCall Lang
Python PythonCode ProgData -> ProgData
forall a. PythonCode a -> a
unPC PythonProject PackageData -> PackageData
forall a. PythonProject a -> a
unPP
    genLangCode Lang
CSharp = Lang
-> (CSharpCode ProgData -> ProgData)
-> (CSharpProject PackageData -> PackageData)
-> IO FileLayout
forall (progRepr :: * -> *) vis smt md svr att prg
       (packRepr :: * -> *).
(OOProg progRepr vis smt md svr att prg,
 SoftwareDossierSym packRepr, Monad packRepr) =>
Lang
-> (progRepr prg -> ProgData)
-> (packRepr PackageData -> PackageData)
-> IO FileLayout
genCall Lang
CSharp CSharpCode ProgData -> ProgData
forall a. CSharpCode a -> a
unCSC CSharpProject PackageData -> PackageData
forall a. CSharpProject a -> a
unCSP
    genLangCode Lang
Cpp = Lang
-> (CppCode CppSrcCode CppHdrCode ProgData -> ProgData)
-> (CppProject PackageData -> PackageData)
-> IO FileLayout
forall (progRepr :: * -> *) vis smt md svr att prg
       (packRepr :: * -> *).
(OOProg progRepr vis smt md svr att prg,
 SoftwareDossierSym packRepr, Monad packRepr) =>
Lang
-> (progRepr prg -> ProgData)
-> (packRepr PackageData -> PackageData)
-> IO FileLayout
genCall Lang
Cpp CppCode CppSrcCode CppHdrCode ProgData -> ProgData
forall a. CppCode CppSrcCode CppHdrCode a -> a
unCPPC CppProject PackageData -> PackageData
forall a. CppProject a -> a
unCPPP
    genLangCode Lang
Swift = Lang
-> (SwiftCode ProgData -> ProgData)
-> (SwiftProject PackageData -> PackageData)
-> IO FileLayout
forall (progRepr :: * -> *) vis smt md svr att prg
       (packRepr :: * -> *).
(OOProg progRepr vis smt md svr att prg,
 SoftwareDossierSym packRepr, Monad packRepr) =>
Lang
-> (progRepr prg -> ProgData)
-> (packRepr PackageData -> PackageData)
-> IO FileLayout
genCall Lang
Swift SwiftCode ProgData -> ProgData
forall a. SwiftCode a -> a
unSC SwiftProject PackageData -> PackageData
forall a. SwiftProject a -> a
unSP
    genLangCode Lang
Julia = Lang
-> (JuliaCode ProgData -> ProgData)
-> (JuliaProject PackageData -> PackageData)
-> IO FileLayout
forall (progRepr :: * -> *) vis smt md prg (packRepr :: * -> *).
(ProcProg progRepr vis smt md prg, NativeVector progRepr,
 SoftwareDossierSym packRepr, Monad packRepr) =>
Lang
-> (progRepr prg -> ProgData)
-> (packRepr PackageData -> PackageData)
-> IO FileLayout
genCallProc Lang
Julia JuliaCode ProgData -> ProgData
forall a. JuliaCode a -> a
unJLC JuliaProject PackageData -> PackageData
forall a. JuliaProject a -> a
unJLP
    genLangCode Lang
Matlab = Lang
-> (MatlabCode ProgData -> ProgData)
-> (MatlabProject PackageData -> PackageData)
-> IO FileLayout
forall (progRepr :: * -> *) vis smt md prg (packRepr :: * -> *).
(ProcProg progRepr vis smt md prg, NativeVector progRepr,
 SoftwareDossierSym packRepr, Monad packRepr) =>
Lang
-> (progRepr prg -> ProgData)
-> (packRepr PackageData -> PackageData)
-> IO FileLayout
genCallProc Lang
Matlab MatlabCode ProgData -> ProgData
forall a. MatlabCode a -> a
unMLC MatlabProject PackageData -> PackageData
forall a. MatlabProject a -> a
unMLP

    genCall
      :: (OOProg progRepr vis smt md svr att prg, SoftwareDossierSym packRepr, Monad packRepr)
      => Lang
      -> (progRepr prg -> ProgData)
      -> (packRepr PackageData -> PackageData)
      -> IO FileLayout
    genCall :: forall (progRepr :: * -> *) vis smt md svr att prg
       (packRepr :: * -> *).
(OOProg progRepr vis smt md svr att prg,
 SoftwareDossierSym packRepr, Monad packRepr) =>
Lang
-> (progRepr prg -> ProgData)
-> (packRepr PackageData -> PackageData)
-> IO FileLayout
genCall Lang
lng progRepr prg -> ProgData
unProgRepr packRepr PackageData -> PackageData
unPackRepr = do
      String
time <- Day -> String
showGregorian (Day -> String) -> (UTCTime -> Day) -> UTCTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Day
utctDay (UTCTime -> String) -> IO UTCTime -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
      [Expr]
samples <- IO [Expr]
readSampleData
      let loggingOpts :: [Logging]
loggingOpts = LogConfig -> [Logging]
logging (LogConfig -> [Logging]) -> LogConfig -> [Logging]
forall a b. (a -> b) -> a -> b
$ OptionalFeatures -> LogConfig
logConfig (OptionalFeatures -> LogConfig) -> OptionalFeatures -> LogConfig
forall a b. (a -> b) -> a -> b
$ Choices -> OptionalFeatures
optFeats Choices
chs
      let realUnProgRepr :: SomeProgGenerator
realUnProgRepr = if Logging
LogVar Logging -> [Logging] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Logging]
loggingOpts then (LoggingFor progRepr prg -> ProgData) -> SomeProgGenerator
forall (repr :: * -> *) vis smt md svr att prg.
OOProg repr vis smt md svr att prg =>
(repr prg -> ProgData) -> SomeProgGenerator
SomeProgGenerator (progRepr prg -> ProgData
unProgRepr (progRepr prg -> ProgData)
-> (LoggingFor progRepr prg -> progRepr prg)
-> LoggingFor progRepr prg
-> ProgData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggingFor progRepr prg -> progRepr prg
forall (r :: * -> *) a. LoggingFor r a -> r a
unLC) else (progRepr prg -> ProgData) -> SomeProgGenerator
forall (repr :: * -> *) vis smt md svr att prg.
OOProg repr vis smt md svr att prg =>
(repr prg -> ProgData) -> SomeProgGenerator
SomeProgGenerator progRepr prg -> ProgData
unProgRepr
      FileLayout -> IO FileLayout
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileLayout -> IO FileLayout) -> FileLayout -> IO FileLayout
forall a b. (a -> b) -> a -> b
$ Lang
-> SomeProgGenerator
-> (packRepr PackageData -> PackageData)
-> DrasilState
-> FileLayout
forall (packRepr :: * -> *).
(SoftwareDossierSym packRepr, Monad packRepr) =>
Lang
-> SomeProgGenerator
-> (packRepr PackageData -> PackageData)
-> DrasilState
-> FileLayout
generateCode Lang
lng SomeProgGenerator
realUnProgRepr packRepr PackageData -> PackageData
unPackRepr (DrasilState -> FileLayout) -> DrasilState -> FileLayout
forall a b. (a -> b) -> a -> b
$ Lang -> String -> [Expr] -> Choices -> CodeSpec -> DrasilState
generator Lang
lng String
time [Expr]
samples Choices
chs CodeSpec
spec

    genCallProc
      :: (ProcProg progRepr vis smt md prg, NativeVector progRepr, SoftwareDossierSym packRepr, Monad packRepr)
      => Lang
      -> (progRepr prg -> ProgData)
      -> (packRepr PackageData -> PackageData)
      -> IO FileLayout
    genCallProc :: forall (progRepr :: * -> *) vis smt md prg (packRepr :: * -> *).
(ProcProg progRepr vis smt md prg, NativeVector progRepr,
 SoftwareDossierSym packRepr, Monad packRepr) =>
Lang
-> (progRepr prg -> ProgData)
-> (packRepr PackageData -> PackageData)
-> IO FileLayout
genCallProc Lang
lng progRepr prg -> ProgData
unProgRepr packRepr PackageData -> PackageData
unPackRepr = do
      String
time <- Day -> String
showGregorian (Day -> String) -> (UTCTime -> Day) -> UTCTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Day
utctDay (UTCTime -> String) -> IO UTCTime -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
      [Expr]
samples <- IO [Expr]
readSampleData
      FileLayout -> IO FileLayout
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileLayout -> IO FileLayout) -> FileLayout -> IO FileLayout
forall a b. (a -> b) -> a -> b
$ Lang
-> (progRepr prg -> ProgData)
-> (packRepr PackageData -> PackageData)
-> DrasilState
-> FileLayout
forall (progRepr :: * -> *) vis smt md prg (packRepr :: * -> *).
(ProcProg progRepr vis smt md prg, NativeVector progRepr,
 SoftwareDossierSym packRepr, Monad packRepr) =>
Lang
-> (progRepr prg -> ProgData)
-> (packRepr PackageData -> PackageData)
-> DrasilState
-> FileLayout
generateCodeProc Lang
lng progRepr prg -> ProgData
unProgRepr packRepr PackageData -> PackageData
unPackRepr (DrasilState -> FileLayout) -> DrasilState -> FileLayout
forall a b. (a -> b) -> a -> b
$ Lang -> String -> [Expr] -> Choices -> CodeSpec -> DrasilState
generator Lang
lng String
time [Expr]
samples Choices
chs CodeSpec
spec

    spec :: CodeSpec
    spec :: CodeSpec
spec = SmithEtAlSRS -> Choices -> CodeSpec
mkCodeSpec SmithEtAlSRS
syst Choices
chs

    readSampleData :: IO [Expr]
    readSampleData :: IO [Expr]
readSampleData =
      case Choices -> Maybe String
getSampleData Choices
chs of
        Just String
sd -> String -> DataDesc' -> IO [Expr]
readWithDataDesc String
sd (DataDesc' -> IO [Expr]) -> DataDesc' -> IO [Expr]
forall a b. (a -> b) -> a -> b
$ [CodeVarChunk] -> DataDesc'
sampleInputDD (CodeSpec
spec CodeSpec
-> Getting [CodeVarChunk] CodeSpec [CodeVarChunk] -> [CodeVarChunk]
forall s a. s -> Getting a s a -> a
^. Getting [CodeVarChunk] CodeSpec [CodeVarChunk]
forall c. HasCodeSpec c => Lens' c [CodeVarChunk]
Lens' CodeSpec [CodeVarChunk]
extInputs)
        Maybe String
Nothing -> [Expr] -> IO [Expr]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

genCodeZoo :: SmithEtAlSRS -> [Choices] -> IO [FileLayout]
genCodeZoo :: SmithEtAlSRS -> [Choices] -> IO [FileLayout]
genCodeZoo SmithEtAlSRS
syst = (Choices -> IO FileLayout) -> [Choices] -> IO [FileLayout]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Choices -> IO FileLayout) -> [Choices] -> IO [FileLayout])
-> (Choices -> IO FileLayout) -> [Choices] -> IO [FileLayout]
forall a b. (a -> b) -> a -> b
$ \Choices
chcs -> do
    let dir :: String
dir = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> Choices -> String
codedDirName (SmithEtAlSRS
syst SmithEtAlSRS -> Getting String SmithEtAlSRS String -> String
forall s a. s -> Getting a s a -> a
^. Getting String SmithEtAlSRS String
forall c. HasSmithEtAlSRS c => Lens' c String
Lens' SmithEtAlSRS String
programName) Choices
chcs
    FileLayout
layout <- SmithEtAlSRS -> Choices -> IO FileLayout
genCode SmithEtAlSRS
syst Choices
chcs
    FileLayout -> IO FileLayout
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileLayout -> IO FileLayout) -> FileLayout -> IO FileLayout
forall a b. (a -> b) -> a -> b
$ PathSegment -> [FileLayout] -> FileLayout
forall (f :: * -> *).
Foldable f =>
PathSegment -> f FileLayout -> FileLayout
directory [ps|{dir}|] [FileLayout
layout]

-- | Find name of folders created for a "zoo" of executable softifacts.
--
-- FIXME: This is a hack. The generation phase should emit what artifacts it
-- created.
codedDirName :: String -> Choices -> String
codedDirName :: String -> Choices -> String
codedDirName String
n Choices {
  architecture :: Choices -> Architecture
architecture = Architecture
a,
  optFeats :: Choices -> OptionalFeatures
optFeats = OptionalFeatures
o,
  dataInfo :: Choices -> DataInfo
dataInfo = DataInfo
d,
  maps :: Choices -> Maps
maps = Maps
m} =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" [String
n, Modularity -> String
codedMod (Modularity -> String) -> Modularity -> String
forall a b. (a -> b) -> a -> b
$ Architecture -> Modularity
modularity Architecture
a, ImplementationType -> String
codedImpTp (ImplementationType -> String) -> ImplementationType -> String
forall a b. (a -> b) -> a -> b
$ Architecture -> ImplementationType
impType Architecture
a, [Logging] -> String
codedLog ([Logging] -> String) -> [Logging] -> String
forall a b. (a -> b) -> a -> b
$ LogConfig -> [Logging]
logging (LogConfig -> [Logging]) -> LogConfig -> [Logging]
forall a b. (a -> b) -> a -> b
$ OptionalFeatures -> LogConfig
logConfig OptionalFeatures
o,
    Structure -> String
codedStruct (Structure -> String) -> Structure -> String
forall a b. (a -> b) -> a -> b
$ DataInfo -> Structure
inputStructure DataInfo
d, ConstantStructure -> String
codedConStruct (ConstantStructure -> String) -> ConstantStructure -> String
forall a b. (a -> b) -> a -> b
$ DataInfo -> ConstantStructure
constStructure DataInfo
d,
    ConstantRepr -> String
codedConRepr (ConstantRepr -> String) -> ConstantRepr -> String
forall a b. (a -> b) -> a -> b
$ DataInfo -> ConstantRepr
constRepr DataInfo
d, SpaceMatch -> String
codedSpaceMatch (SpaceMatch -> String) -> SpaceMatch -> String
forall a b. (a -> b) -> a -> b
$ Maps -> SpaceMatch
spaceMatch Maps
m]

codedMod :: Modularity -> String
codedMod :: Modularity -> String
codedMod Modularity
Unmodular = String
"U"
codedMod Modularity
Modular = String
"M"

codedImpTp :: ImplementationType -> String
codedImpTp :: ImplementationType -> String
codedImpTp ImplementationType
Program = String
"P"
codedImpTp ImplementationType
Library = String
"L"

codedLog :: [Logging] -> String
codedLog :: [Logging] -> String
codedLog [] = String
"NoL"
codedLog [Logging]
_ = String
"L"

codedStruct :: Structure -> String
codedStruct :: Structure -> String
codedStruct Structure
Bundled = String
"B"
codedStruct Structure
Unbundled = String
"U"

codedConStruct :: ConstantStructure -> String
codedConStruct :: ConstantStructure -> String
codedConStruct ConstantStructure
Inline = String
"I"
codedConStruct ConstantStructure
WithInputs = String
"WI"
codedConStruct (Store Structure
s) = Structure -> String
codedStruct Structure
s

codedConRepr :: ConstantRepr -> String
codedConRepr :: ConstantRepr -> String
codedConRepr ConstantRepr
Var = String
"V"
codedConRepr ConstantRepr
Const = String
"C"

codedSpaceMatch :: SpaceMatch -> String
codedSpaceMatch :: SpaceMatch -> String
codedSpaceMatch SpaceMatch
sm = case SpaceMatch
sm Space
Real of
  [CodeType
Double, CodeType
Float] -> String
"D"
  [CodeType
Float, CodeType
Double] -> String
"F"
  [CodeType]
_ -> String -> String
forall a. HasCallStack => String -> a
error String
"Unexpected SpaceMatch for Projectile"