diff --git a/modulo.cabal b/modulo.cabal --- a/modulo.cabal +++ b/modulo.cabal @@ -1,6 +1,6 @@ name: modulo -version: 1.3 +version: 1.5 cabal-version: >= 1.6 author: Hans Hoglund maintainer: Hans Hoglund @@ -31,7 +31,7 @@ parsec >= 3.1.2 && < 4, prettify >= 1.0 && < 2, language-c, - haskell-src, + haskell-src == 1.0.1.5, atto-lisp hs-source-dirs: src exposed-modules: diff --git a/src/Language/Modulo.hs b/src/Language/Modulo.hs --- a/src/Language/Modulo.hs +++ b/src/Language/Modulo.hs @@ -85,6 +85,9 @@ toModuleName, getModuleNameList, + -- ** Documentation + Doc(..), + -- ** Names Name(..), getName, @@ -103,6 +106,7 @@ ) where import Data.Ord +import Data.String import Numeric.Natural import Foreign.C.Types @@ -112,6 +116,8 @@ import qualified Data.List.NonEmpty as NonEmpty +newtype Doc = Doc { getDoc :: String } + deriving (Eq, Ord, Show, IsString) -- | -- A module is a named container of imports and declarations. @@ -122,9 +128,10 @@ data Module = Module { + modDoc :: Doc, modName :: ModuleName, -- ^ Name of module modImports :: [(ModuleName, Maybe String)], -- ^ Imports with optional import conventions - modDecls :: [Decl] -- ^ List of declarations + modDecls :: [(Doc, Decl)] -- ^ List of declarations } deriving (Eq, Show) diff --git a/src/Language/Modulo/C.hs b/src/Language/Modulo/C.hs --- a/src/Language/Modulo/C.hs +++ b/src/Language/Modulo/C.hs @@ -38,7 +38,9 @@ printModule, renderModule, printModuleStyle, - renderModuleStyle, + renderModuleStyle, + + printModuleComm, ) where import Data.Default @@ -81,7 +83,7 @@ includeStyle :: ImportStyle, -- ^ How to write import declarations includeDirective :: String, -- ^ Import directive, usually @include@. guardMangler :: [String] -> String, -- ^ Mangler for names of header guards - innerHeader :: [String] -> String, -- ^ Inner header mangler + innerHeader :: [String] -> String -> String, -- ^ Inner header mangler (components moduleDoc) innerFooter :: [String] -> String, -- ^ Inner footer mangler -- Prefix @@ -119,10 +121,12 @@ mappend = (<>) -stdInnerHeader :: CStyle -> [String] -> String -stdInnerHeader _ ns = concat (post " @{\n" cs) ++ end - where - c1 = ["/** "] ++ repeat " " +stdInnerHeader :: CStyle -> [String] -> String -> String +stdInnerHeader _ ns doc = begin ++ concat (post " @{\n" cs) ++ end + where + begin = "/** @addtogroup " ++ concat ns ++ "\n" ++ doc ++ "\n" + + c1 = repeat " " c2 = repeat "@defgroup " c3 = map concat . drop 1 . List.inits $ ns c4 = repeat " " @@ -328,23 +332,72 @@ renderModuleStyle :: CStyle -> Module -> (String, CTranslUnit, String) renderModuleStyle style mod = (header, decls, footer) where - header = convertHeader style mod' + header = convertHeader style False mod' decls = convertTopLevel style mod' footer = convertFooter style mod' mod' = flattenModule style mod + + + +-- | +-- Print a module using the default style. +-- +printModuleComm :: Module -> String +printModuleComm = printModuleStyleComm def + +-- | +-- Print a module using the specified style. +-- +printModuleStyleComm :: CStyle -> Module -> String +printModuleStyleComm style = (\(x,y,z) -> x ++ concatSep "\n\n" (map sdd y) ++ z) . renderModuleStyleComm style + where + sdd (doc, decl) = sd doc ++ "\n" ++ (show . pretty) decl ++ ";" + sd "" = "" + sd str = "/**" ++ (removeEmptyLast . deindent) str ++ "*/" + +-- Hacky functions to remove strange indentation +deindent :: String -> String +deindent = unlines . fmap f . lines + where + f (' ':' ':' ':' ':' ':' ':' ':' ':xs) = " "++xs + f xs = xs + +removeEmptyLast :: String -> String +removeEmptyLast = reverse . f . reverse + where + f ('\n':'\n':xs) = "\n"++xs + f ('\n':' ':' ':' ':' ':' ':'\n':xs) = "\n"++xs + f xs = xs + +-- | +-- Render a module using the specified style, preserving comments. +-- +-- Returns a C header file, represented as a 'CTranslUnit' with enclosing header and footer strings. +-- +renderModuleStyleComm :: CStyle -> Module -> (String, [(String, CDecl)], String) +renderModuleStyleComm style mod = (header, decls, footer) + where + -- TODO module docs in header + header = convertHeader style True mod' + decls = convertTopLevelComm style mod' + footer = convertFooter style mod' + mod' = flattenModule style mod + + ------------------------------------------------------------------------------------- -- Header and footer -convertHeader :: CStyle -> Module -> String -convertHeader st mod = mempty +-- Args: style withDocs module +convertHeader :: CStyle -> Bool -> Module -> String +convertHeader st withDocs mod = mempty ++ "\n" ++ guardBegin (guardStyle st) guard ++ "\n" ++ imports ++ "\n\n" - ++ innerHeader st name + ++ innerHeader st name (if withDocs then getDoc (modDoc mod) else "") ++ "\n\n" where name = getModuleNameList . modName $ mod @@ -397,7 +450,7 @@ -- The module returned from this function will have no QName constructors. -- flattenModule :: CStyle -> Module -> Module -flattenModule st (Module n is ds) = Module n is (map (flattenDecl st) ds) +flattenModule st (Module doc n is ds) = Module doc n is (map (fmap $ flattenDecl st) ds) flattenDecl st (TypeDecl n t) = TypeDecl (translType st n) (fmap (flattenType st) t) flattenDecl st (FunctionDecl n t) = FunctionDecl (translFun st n) (flattenFunType st t) @@ -453,11 +506,18 @@ ------------------------------------------------------------------------------------- -- Top-level declarations - +-- TODO use doc convertTopLevel :: CStyle -> Module -> CTranslUnit -convertTopLevel st (Module n is ds) = CTranslUnit cds defInfo +convertTopLevel st (Module doc n is ds) = CTranslUnit cds defInfo where - cds = map (CDeclExt . convertDecl st) ds + cds = map (CDeclExt . convertDecl st . snd) ds + +convertTopLevelComm :: CStyle -> Module -> [(String, CDecl)] +convertTopLevelComm st (Module doc n is ds) = fmap (first getDoc . second (convertDecl st)) ds + where + first f = swap . fmap f . swap + second = fmap + swap (a,b) = (b,a) convertDecl :: CStyle -> Decl -> CDecl convertDecl st (TypeDecl n Nothing) = declOpaque st n diff --git a/src/Language/Modulo/Haskell.hs b/src/Language/Modulo/Haskell.hs --- a/src/Language/Modulo/Haskell.hs +++ b/src/Language/Modulo/Haskell.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DisambiguateRecordFields, TypeFamilies, +{-# LANGUAGE DisambiguateRecordFields, TypeFamilies, OverloadedStrings, StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- @@ -14,5 +14,186 @@ -- ------------------------------------------------------------------------------------- +{- + module (...) where + data FaeString + foreign import ccall "fae_fae_version_string" + c_VersionString :: IO (Ptr FaeString) + + +-} + module Language.Modulo.Haskell ( + -- ** Styles + HaskellStyle(..), + stdHaskellStyle, + -- ** Rendering + printModuleHaskell, + renderModuleHaskell, + printModuleHaskellStyle, + renderModuleHaskellStyle ) where + +import Data.Default +import Data.Semigroup +import Data.Char (chr) +import Data.Text (pack) +import Data.String +import Language.Haskell.Syntax hiding (Module) +import Language.Haskell.Pretty + +import Language.Modulo.C +import Language.Modulo.Util +import Language.Modulo.Util.Unmangle +import Language.Modulo + +import qualified Data.List as List +import qualified Language.Haskell.Syntax as Hs + +data HaskellStyle = + HaskellStyle { + cStyle :: CStyle -- ^ For generating foreign declarations + } + +stdHaskellStyle = HaskellStyle { + cStyle = stdStyle + } + +-- | Default instance using 'stdStyle'. +instance Default HaskellStyle where + def = stdHaskellStyle +-- | Left-biased Semigroup instance. +instance Semigroup HaskellStyle where + a <> b = a +-- | Left-biased Monoid instance. +instance Monoid HaskellStyle where + mempty = def + mappend = (<>) + +-- | +-- Print a module using the default style. +-- +printModuleHaskell :: Module -> String +printModuleHaskell = printModuleHaskellStyle def + +-- | +-- Print a module using the specified style. +-- +printModuleHaskellStyle :: HaskellStyle -> Module -> String +printModuleHaskellStyle style = (++ "\n\n") . prettyPrint . renderModuleHaskellStyle style + +-- | +-- Render a module using the default style. +-- +-- Returns a Haskell file, represented as a syntax tree. +-- +renderModuleHaskell :: Module -> HsModule +renderModuleHaskell = renderModuleHaskellStyle def + +-- | +-- Render a module using the specified style. +-- +-- Returns a Haskell file, represented as a syntax tree. +-- +renderModuleHaskellStyle :: HaskellStyle -> Module -> HsModule +renderModuleHaskellStyle st = convertTopLevel st + +convertTopLevel :: HaskellStyle -> Module -> HsModule +convertTopLevel st (Module doc n is ds) = + HsModule def (convertModule n) Nothing [] $ fmap (convertDecl st . snd) ds + +convertDecl :: HaskellStyle -> Decl -> HsDecl +convertDecl st (TypeDecl n Nothing) = declOpaque st n +convertDecl st (TypeDecl n (Just t)) = declType st n t -- typedef T N; +convertDecl st (FunctionDecl n t) = declFun st n t -- T n (as); +convertDecl st (TagDecl t) = notSupported "Tag decls" -- T; +convertDecl st (ConstDecl n v t) = notSupported "Constants" -- T n; or T n = v; +convertDecl st (GlobalDecl n v t) = notSupported "Globals" -- T n; or T n = v; + +declOpaque :: HaskellStyle -> Name -> HsDecl +declOpaque st (Name n) = HsDataDecl def [] (HsIdent n) [] [] [] +declOpaque st (QName _ n) = HsDataDecl def [] (HsIdent n) [] [] [] + +declType :: HaskellStyle -> Name -> Type -> HsDecl +declType st n t = HsTypeDecl def (HsIdent $ getName n) [] (convertType st t) + +declFun :: HaskellStyle -> Name -> FunType -> HsDecl +declFun st n t = HsForeignImport def "ccall" HsUnsafe cName hsName hsType + where + cName = getName (translFun (cStyle st) n) + hsName = HsIdent (getName n) + hsType = convertFunType st t + + +-- TODO partial on (CompType (Struct..)), (for struct, union and bitfield) +convertType :: HaskellStyle -> Type -> HsType +convertType st (AliasType n) = convertAlias st n +convertType st (PrimType t) = convertPrimType st t +convertType st (RefType t) = convertRefType st t +convertType st (FunType t) = convertFunType st t +convertType st (CompType t) = convertCompType st t + +convertAlias :: HaskellStyle -> Name -> HsType +convertAlias st (Name n) = HsTyCon $ (UnQual (HsIdent n)) +convertAlias st (QName m n) = HsTyCon $ (Qual (convertModule m) (HsIdent n)) + +convertPrimType :: HaskellStyle -> PrimType -> HsType +convertPrimType st Bool = HsTyCon (UnQual "CInt") +convertPrimType st Void = unit_tycon +convertPrimType st Char = HsTyCon (UnQual "CChar") +convertPrimType st Short = HsTyCon (UnQual "CShort") +convertPrimType st Int = HsTyCon (UnQual "CInt") +convertPrimType st Long = HsTyCon (UnQual "CLong") +convertPrimType st LongLong = notSupported "long long with Haskell" +convertPrimType st UChar = HsTyCon (UnQual "CUChar") +convertPrimType st UShort = HsTyCon (UnQual "CUShort") +convertPrimType st UInt = HsTyCon (UnQual "CUInt") +convertPrimType st ULong = HsTyCon (UnQual "CULong") +convertPrimType st ULongLong = notSupported "(unsigned) long long with Haskell" +convertPrimType st Float = HsTyCon (UnQual "CFloat") +convertPrimType st Double = HsTyCon (UnQual "CDouble") +convertPrimType st LongDouble = notSupported "long double with Haskell" +convertPrimType st Int8 = HsTyCon (UnQual "Int8") +convertPrimType st Int16 = HsTyCon (UnQual "Int16") +convertPrimType st Int32 = HsTyCon (UnQual "Int32") +convertPrimType st Int64 = HsTyCon (UnQual "Int64") +convertPrimType st UInt8 = HsTyCon (UnQual "Word8") +convertPrimType st UInt16 = HsTyCon (UnQual "Word16") +convertPrimType st UInt32 = HsTyCon (UnQual "Word32") +convertPrimType st UInt64 = HsTyCon (UnQual "Word64") +convertPrimType st Size = HsTyCon (UnQual "CSize") +convertPrimType st Ptrdiff = HsTyCon (UnQual "CPtrdiff") +convertPrimType st Intptr = HsTyCon (UnQual "CIntPtr") +convertPrimType st UIntptr = notSupported "Uintptr with Haskell" +convertPrimType st SChar = notSupported "Signed chars with Haskell" + +convertRefType :: HaskellStyle -> RefType -> HsType +convertRefType st (Pointer t) = HsTyCon (UnQual "Ptr") `HsTyApp` convertType st t +convertRefType st (Array t n) = notSupported "Array types with Haskell" +-- -- TODO + +convertFunType :: HaskellStyle -> FunType -> HsType +convertFunType st = go + where + go (Function [] r) = {-(HsTyCon (UnQual "IO")) `HsTyApp`-} convertType st r + go (Function (t:ts) r) = convertType st t `HsTyFun` convertFunType st (Function ts r) + +convertCompType :: HaskellStyle -> CompType -> HsType +convertCompType st (Enum as) = HsTyCon (UnQual "CInt") +convertCompType st (Struct as) = notSupported "Compound types with Haskell" +convertCompType st (Union as) = notSupported "Compound types with Haskell" +convertCompType st (BitField as) = notSupported "Compound types with Haskell" + +instance IsString HsName where + fromString = HsIdent + +instance IsString Hs.Module where + fromString = Hs.Module + +instance Default SrcLoc where + def = SrcLoc "" 0 0 + +convertModule :: ModuleName -> Hs.Module +convertModule = Hs.Module . concatSep "." . getModuleNameList + +notSupported x = error $ "Not supported yet: " ++ x diff --git a/src/Language/Modulo/JavaScript.hs b/src/Language/Modulo/JavaScript.hs --- a/src/Language/Modulo/JavaScript.hs +++ b/src/Language/Modulo/JavaScript.hs @@ -16,5 +16,9 @@ -- ------------------------------------------------------------------------------------- +{- + 'fae_audio_engine_version': ['pointer', [] ], +-} + module Language.Modulo.JavaScript ( ) where diff --git a/src/Language/Modulo/Lisp.hs b/src/Language/Modulo/Lisp.hs --- a/src/Language/Modulo/Lisp.hs +++ b/src/Language/Modulo/Lisp.hs @@ -38,10 +38,6 @@ import qualified Data.List as List --- import qualified Data.List as List --- import qualified Data.Char as Char --- import qualified Data.List.NonEmpty as NonEmpty - data LispStyle = LispStyle { cStyle :: CStyle, -- ^ For generating foreign declarations @@ -76,7 +72,7 @@ -- Print a module using the specified style. -- printModuleLispStyle :: LispStyle -> Module -> String -printModuleLispStyle style = concatSep "\n" . map show . renderModuleLispStyle style +printModuleLispStyle style = (++ "\n\n") . concatSep "\n" . map show . renderModuleLispStyle style -- TODO more intelligent splitting -- | @@ -99,9 +95,9 @@ convertPackage st = [list [symbol "in-package", keyword (package st)]] convertTopLevel :: LispStyle -> Module -> [Lisp] -convertTopLevel st (Module n is ds) = cds +convertTopLevel st (Module doc n is ds) = cds where - cds = concatMap (convertDecl st) ds + cds = concatMap (convertDecl st . snd) ds convertDecl :: LispStyle -> Decl -> [Lisp] convertDecl st (TypeDecl n Nothing) = declOpaque st n @@ -252,6 +248,7 @@ keywordName :: Name -> Lisp keywordName = keyword . convertName {- getName-} +-- TODO there should be in the style convertName :: Name -> String convertName (Name n) = {-withPrefix "#" $ -} toLowerString $ concatSep "-" (unmangle n) convertName (QName m n) = {-withPrefix "#" $ -} toLowerString $ concatSep "-" (stripPackage (getModuleNameList m) ++ unmangle n) diff --git a/src/Language/Modulo/Parse.hs b/src/Language/Modulo/Parse.hs --- a/src/Language/Modulo/Parse.hs +++ b/src/Language/Modulo/Parse.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DisambiguateRecordFields, TypeFamilies, +{-# LANGUAGE DisambiguateRecordFields, TypeFamilies, OverloadedStrings, StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- @@ -21,6 +21,7 @@ ) where import Control.Monad +import Data.Maybe import Control.Applicative hiding ((<|>), optional, many) import Text.Parsec hiding (parse) @@ -66,13 +67,18 @@ modParser :: Parser Module modParser = do optional lspace + + doc <- fmap (Doc . fromMaybe "") $ optionMaybe docComment + optional lspace + reserved lexer "module" name <- modNameParser llex $ char '{' imps <- many impParser - decls <- many declParser + docDecls <- many docDeclParser llex $ char '}' - return $ Module name imps decls + + return $ Module doc name imps docDecls modNameParser :: Parser ModuleName modNameParser = do @@ -87,6 +93,13 @@ semi lexer return (name, conv) +docDeclParser :: Parser (Doc, Decl) +docDeclParser = do + doc <- fmap (Doc . fromMaybe "") $ optionMaybe docComment + optional lspace + decl <- declParser + return $ (doc, decl) + declParser :: Parser Decl declParser = mzero <|> typeDeclParser @@ -264,6 +277,12 @@ name <- nameParser return $ AliasType name + +docComment :: Parser String +docComment = do + string "/**" + manyTill anyChar (try (string "*/")) + ------------------------------------------------------------------------------------- nameParser :: Parser Name @@ -300,7 +319,7 @@ lexer :: TokenParser () lexer = makeTokenParser $ LanguageDef { - commentStart = "/*", + commentStart = "/*!", commentEnd = "*/", commentLine = "//", nestedComments = True, diff --git a/src/Language/Modulo/Rename.hs b/src/Language/Modulo/Rename.hs --- a/src/Language/Modulo/Rename.hs +++ b/src/Language/Modulo/Rename.hs @@ -40,7 +40,7 @@ -- * Returned module has no Name constructors -- rename :: [Module] -> Module -> Module -rename deps mod@(Module n is ds) = Module n is (map renameDecl ds) +rename deps mod@(Module doc n is ds) = Module doc n is (map (fmap renameDecl) ds) where renameDecl (TypeDecl n t) = TypeDecl (simplify $ qualify mod n) (fmap renameType t) renameDecl (FunctionDecl n t) = FunctionDecl (simplify $ qualify mod n) (renameFunType t) @@ -86,7 +86,7 @@ | n `elem` mNs = Just $ modName m | otherwise = findName ms n where - mNs = catMaybes . map getDeclName . modDecls $ m + mNs = catMaybes . map (getDeclName . snd) . modDecls $ m -- If the given name is a suffix of the module name, simplify diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -15,6 +15,7 @@ import Language.Modulo import Language.Modulo.C import Language.Modulo.Lisp +import Language.Modulo.Haskell import Language.Modulo.Load import Language.Modulo.Parse import Language.Modulo.Rename @@ -67,7 +68,7 @@ readPackage = Package . maybe "user" id -version = "modulo-1.0" +version = "modulo-1.5" header = "Usage: modulo [options]\n" ++ "Usage: modulo [options] files...\n" ++ "\n" ++ @@ -139,6 +140,7 @@ Right m -> m printMod :: ModLang -> Module -> String - printMod C = printModule - printMod Lisp = printModuleLisp + printMod C = printModuleComm + printMod Lisp = printModuleLisp + printMod Haskell = printModuleHaskell