-- Copyright 2020 United States Government as represented by the Administrator
-- of the National Aeronautics and Space Administration. All Rights Reserved.
--
-- Disclaimers
--
-- No Warranty: THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT ANY WARRANTY
-- OF ANY KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT
-- LIMITED TO, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL CONFORM TO
-- SPECIFICATIONS, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A
-- PARTICULAR PURPOSE, OR FREEDOM FROM INFRINGEMENT, ANY WARRANTY THAT THE
-- SUBJECT SOFTWARE WILL BE ERROR FREE, OR ANY WARRANTY THAT DOCUMENTATION, IF
-- PROVIDED, WILL CONFORM TO THE SUBJECT SOFTWARE. THIS AGREEMENT DOES NOT, IN
-- ANY MANNER, CONSTITUTE AN ENDORSEMENT BY GOVERNMENT AGENCY OR ANY PRIOR
-- RECIPIENT OF ANY RESULTS, RESULTING DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR
-- ANY OTHER APPLICATIONS RESULTING FROM USE OF THE SUBJECT SOFTWARE. FURTHER,
-- GOVERNMENT AGENCY DISCLAIMS ALL WARRANTIES AND LIABILITIES REGARDING
-- THIRD-PARTY SOFTWARE, IF PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES
-- IT "AS IS."
--
-- Waiver and Indemnity: RECIPIENT AGREES TO WAIVE ANY AND ALL CLAIMS AGAINST
-- THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS
-- ANY PRIOR RECIPIENT. IF RECIPIENT'S USE OF THE SUBJECT SOFTWARE RESULTS IN
-- ANY LIABILITIES, DEMANDS, DAMAGES, EXPENSES OR LOSSES ARISING FROM SUCH USE,
-- INCLUDING ANY DAMAGES FROM PRODUCTS BASED ON, OR RESULTING FROM, RECIPIENT'S
-- USE OF THE SUBJECT SOFTWARE, RECIPIENT SHALL INDEMNIFY AND HOLD HARMLESS THE
-- UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY
-- PRIOR RECIPIENT, TO THE EXTENT PERMITTED BY LAW. RECIPIENT'S SOLE REMEDY
-- FOR ANY SUCH MATTER SHALL BE THE IMMEDIATE, UNILATERAL TERMINATION OF THIS
-- AGREEMENT.
--
-- | Generate Copilot struct definitions and instances from structs defined in
-- a C header file.
--
-- Working with Copilot structs requires three definitions: the datatype,
-- a @Struct@ instance, and a @Typed@ instance.
--
-- This module converts the C structs into 'CStruct's, and then converts
-- those 'CStruct's into Copilot (i.e., Haskell) data type declarations and
-- instance declarations represented as strings.
module Language.Trans.CStructs2Copilot where

-- External imports
import Data.Char ( isUpper, toLower )
import Data.List ( intercalate )

-- External imports: auxiliary
import Data.List.Extra ( toHead, toTail )

-- Internal imports: C AST
import qualified Language.C.AbsC          as C
import           Language.Copilot.CStruct ( CField (CArray, CPlain),
                                            CStruct (..) )

-- Internal imports: Copilot's representation of C structs
import Language.Trans.CStruct2CopilotStruct ( camelCaseTypeName, mkCStruct )

-- | Convert all the 'CStruct's in a header file into the declarations needed
-- in Copilot to use it.
cstructs2CopilotDecls :: C.TranslationUnit -> Either String [ String ]
cstructs2CopilotDecls :: TranslationUnit -> Either String [String]
cstructs2CopilotDecls (C.MkTranslationUnit [ExternalDeclaration]
gs) =
  [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String])
-> Either String [[String]] -> Either String [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExternalDeclaration -> Either String [String])
-> [ExternalDeclaration] -> Either String [[String]]
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 ((CStruct -> [String])
-> Either String CStruct -> Either String [String]
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CStruct -> [String]
cstruct2CopilotDecls  (Either String CStruct -> Either String [String])
-> (ExternalDeclaration -> Either String CStruct)
-> ExternalDeclaration
-> Either String [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExternalDeclaration -> Either String CStruct
mkCStruct) [ExternalDeclaration]
gs

-- | Convert a 'CStruct' into the declarations needed in Copilot to use it.
cstruct2CopilotDecls :: CStruct -> [ String ]
cstruct2CopilotDecls :: CStruct -> [String]
cstruct2CopilotDecls CStruct
cstruct = [ CStruct -> String
cStructToCopilotStruct CStruct
cstruct
                               , CStruct -> String
structInstance         CStruct
cstruct
                               , CStruct -> String
typedInstance          CStruct
cstruct
                               ]

-- ** Individual conversions

-- | Convert a 'CStruct' definition into a Copilot Struct declaration.
--
-- For example, given the struct generated by the following definition:
--
-- @
--   struct {
--     uint8_t f1;
--   } a_struct_t;
-- @
--
-- the corresponding Haskell definition would be:
--
-- @
-- data AStruct = AStruct
--     { aSF1 :: Word8 }
--   deriving Generic
-- @
cStructToCopilotStruct :: CStruct -> String
cStructToCopilotStruct :: CStruct -> String
cStructToCopilotStruct CStruct
cstruct = [String] -> String
unlines
    [ String
"data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
datatype String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
constructor
    , String
"   deriving Generic"
    ]
  where

    -- The name of the type (e.g., @AStruct@).
    datatype :: String
datatype = String -> String
cStructName2Haskell (CStruct -> String
cStructName CStruct
cstruct)

    -- The name of the constructor (e.g., @AStruct@).
    constructor :: String
constructor = String -> String
cStructName2Haskell (CStruct -> String
cStructName CStruct
cstruct) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fields

    -- The fields in the struct (e.g., @aSF1 :: Word 8@), formated as record
    -- fields: separated by commas, enclosed in curly brackets, and indented.
    fields :: String
fields = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
                     ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"}"])
                     ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a. (a -> a) -> [a] -> [a]
toTail (String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
                     ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a. (a -> a) -> [a] -> [a]
toHead (String
"{ " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
                     ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (CField -> String) -> [CField] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (CStruct -> CField -> String
toField CStruct
cstruct) (CStruct -> [CField]
cStructFields CStruct
cstruct)

    -- Convert a 'CStruct' field into a Copilot record field declaration.
    --
    -- The second case (@CArray@) uses depedent types to promote the length of
    -- the array to type level.
    toField :: CStruct -> CField -> String
    toField :: CStruct -> CField -> String
toField CStruct
cstruct' (CPlain String
t String
n) = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty
      where
        name :: String
name = CStruct -> String -> String
fieldName CStruct
cstruct' String
n
        ty :: String
ty   = String
"Field" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
n
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
cTypeName2HaskellType String
t

    toField CStruct
cstruct' (CArray String
t String
n Integer
l) = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty
      where
        name :: String
name = CStruct -> String -> String
fieldName CStruct
cstruct' String
n
        ty :: String
ty   = String
"Field" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
n
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Array"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
l
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
cTypeName2HaskellType String
t
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

-- | Convert a 'CStruct' definition into a Copilot @Struct@ instance
-- declaration. For example, for the struct:
--
-- @
--   struct {
--     uint8_t f1;
--   } a_struct_t;
-- @
--
-- the corresponding @Struct@ instance would be:
--
-- @
--   instance Struct AStruct where
--     typeName = typeNameDefault
--     toValues = toValuesDefault
-- @
structInstance :: CStruct -> String
structInstance :: CStruct -> String
structInstance CStruct
cstruct = [String] -> String
unlines
    [ String
"instance Struct " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
instanceName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where"
    , String
"  typeName = typeNameDefault"
    , String
"  toValues = toValuesDefault"
    ]
  where
    instanceName :: String
instanceName = String -> String
cStructName2Haskell (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ CStruct -> String
cStructName CStruct
cstruct

-- | Convert a 'CStruct' definition to Copilot @Typed@ instance declaration.
-- For example, for the struct:
--
-- @
--   struct {
--     uint8_t f1;
--   } a_struct_t;
-- @
--
-- the corresponding @Typed@ instance could be:
--
-- @
--   instance Typed AStruct where
--     typeOf = typeOfDefault
-- @
typedInstance :: CStruct -> String
typedInstance :: CStruct -> String
typedInstance CStruct
cstruct = [String] -> String
unlines
    [ String
"instance Typed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
instanceName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where"
    , String
"  typeOf = typeOfDefault"
    ]
  where
    instanceName :: String
instanceName = String -> String
cStructName2Haskell (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ CStruct -> String
cStructName CStruct
cstruct

-- * Auxiliary functions

-- | Provide a suitable field name for a record field of a 'CStruct' in Haskell.
--
-- For example, given the struct:
--
-- @
--   struct {
--     uint8_t f1;
--   } a_struct_t;
-- @
--
-- the field name in the Haskell record would be @aSF1@, where the @aS@ and
-- comes from @a_struct_t@ and the final @F1@ comes from @f1@.
fieldName :: CStruct -> String -> String
fieldName :: CStruct -> String -> String
fieldName CStruct
cstruct String
n =
    String -> String
summary (String -> String
cStructName2Haskell (CStruct -> String
cStructName CStruct
cstruct)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
cStructName2Haskell String
n
  where
    summary :: String -> String
    summary :: String -> String
summary = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isUpper

-- | Convert a C struct name (e.g., @some_type_t@) to a Haskell type name
-- (e.g., @SomeType@).
cStructName2Haskell :: String -> String
cStructName2Haskell :: String -> String
cStructName2Haskell = String -> String
camelCaseTypeName

-- | Return the corresponding type in Copilot/Haskell for a given type.
cTypeName2HaskellType :: String -> String
cTypeName2HaskellType :: String -> String
cTypeName2HaskellType String
"float"    = String
"Float"
cTypeName2HaskellType String
"double"   = String
"Double"
cTypeName2HaskellType String
"int"      = String
"Int"
cTypeName2HaskellType String
"uint8_t"  = String
"Word8"
cTypeName2HaskellType String
"uint16_t" = String
"Word16"
cTypeName2HaskellType String
"uint32_t" = String
"Word32"
cTypeName2HaskellType String
"uint64_t" = String
"Word64"
cTypeName2HaskellType String
"int8_t"   = String
"Int8"
cTypeName2HaskellType String
"int16_t"  = String
"Int16"
cTypeName2HaskellType String
"int32_t"  = String
"Int32"
cTypeName2HaskellType String
"int64_t"  = String
"Int64"
cTypeName2HaskellType String
"bool"     = String
"Bool"
cTypeName2HaskellType String
t          = String -> String
camelCaseTypeName String
t