modulo 1.3 → 1.5
raw patch · 9 files changed
+304/−34 lines, 9 filesdep ~haskell-src
Dependency ranges changed: haskell-src
Files
- modulo.cabal +2/−2
- src/Language/Modulo.hs +8/−1
- src/Language/Modulo/C.hs +74/−14
- src/Language/Modulo/Haskell.hs +182/−1
- src/Language/Modulo/JavaScript.hs +4/−0
- src/Language/Modulo/Lisp.hs +4/−7
- src/Language/Modulo/Parse.hs +23/−4
- src/Language/Modulo/Rename.hs +2/−2
- src/Main.hs +5/−3
modulo.cabal view
@@ -1,6 +1,6 @@ name: modulo-version: 1.3+version: 1.5 cabal-version: >= 1.6 author: Hans Hoglund maintainer: Hans Hoglund <hans@hanshoglund.se>@@ -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:
src/Language/Modulo.hs view
@@ -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)
src/Language/Modulo/C.hs view
@@ -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
src/Language/Modulo/Haskell.hs view
@@ -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
src/Language/Modulo/JavaScript.hs view
@@ -16,5 +16,9 @@ -- ------------------------------------------------------------------------------------- +{-+ 'fae_audio_engine_version': ['pointer', [] ],+-}+ module Language.Modulo.JavaScript ( ) where
src/Language/Modulo/Lisp.hs view
@@ -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)
src/Language/Modulo/Parse.hs view
@@ -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,
src/Language/Modulo/Rename.hs view
@@ -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
src/Main.hs view
@@ -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