modulo 1.5 → 1.7.2
raw patch · 9 files changed
+431/−103 lines, 9 filesdep +directorydep +pandocdep +pandoc-types
Dependencies added: directory, pandoc, pandoc-types, process
Files
- modulo.cabal +8/−2
- src/Language/Modulo.hs +4/−1
- src/Language/Modulo/C.hs +11/−6
- src/Language/Modulo/Haskell.hs +51/−20
- src/Language/Modulo/Lisp.hs +39/−30
- src/Language/Modulo/Pandoc.hs +216/−0
- src/Language/Modulo/Parse.hs +57/−24
- src/Language/Modulo/Rename.hs +7/−6
- src/Main.hs +38/−14
modulo.cabal view
@@ -1,6 +1,6 @@ name: modulo-version: 1.5+version: 1.7.2 cabal-version: >= 1.6 author: Hans Hoglund maintainer: Hans Hoglund <hans@hanshoglund.se>@@ -32,7 +32,12 @@ prettify >= 1.0 && < 2, language-c, haskell-src == 1.0.1.5,- atto-lisp+ atto-lisp,++ pandoc-types == 1.10,+ pandoc == 1.11.1,+ process,+ directory hs-source-dirs: src exposed-modules: Language.Modulo@@ -41,6 +46,7 @@ Language.Modulo.Lisp Language.Modulo.Haskell Language.Modulo.JavaScript+ Language.Modulo.Pandoc Language.Modulo.Load Language.Modulo.Parse
src/Language/Modulo.hs view
@@ -128,6 +128,9 @@ data Module = Module { + -- TODO properties:+ -- transient :: Bool (ignore last component in name for mangling)+ -- visibility :: Public | Internal modDoc :: Doc, modName :: ModuleName, -- ^ Name of module modImports :: [(ModuleName, Maybe String)], -- ^ Imports with optional import conventions@@ -237,7 +240,7 @@ -- | A function type. data FunType - = Function [Type] Type -- ^ The C function type @Tn(T1, ... Tn-1)@.+ = Function [(Maybe Name, Type)] Type -- ^ The C function type @Tn(T1, ... Tn-1)@. deriving (Eq, Show) data CompType
src/Language/Modulo/C.hs view
@@ -22,8 +22,8 @@ stdStyle, cairoStyle, gtkStyle,- -- appleStyle,- -- haskellStyle,+ appleStyle,+ haskellStyle, -- ** Conversion translType,@@ -44,7 +44,9 @@ ) where import Data.Default+import Data.Foldable (toList) import Data.Semigroup+import Control.Arrow import Language.Modulo import Language.Modulo.Util@@ -83,8 +85,8 @@ 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 -> String, -- ^ Inner header mangler (components moduleDoc)- innerFooter :: [String] -> String, -- ^ Inner footer mangler+ innerHeader :: [String] -> String -> String, -- ^ Inner header mangler (receives module name, documentation)+ innerFooter :: [String] -> String, -- ^ Inner footer mangler (receives module name) -- Prefix typePrefixMangler :: [String] -> String, -- ^ Prefix for types@@ -452,12 +454,14 @@ flattenModule :: CStyle -> Module -> Module flattenModule st (Module doc n is ds) = Module doc n is (map (fmap $ flattenDecl st) ds) +flattenDecl :: CStyle -> Decl -> Decl 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) flattenDecl st (TagDecl t) = TagDecl (flattenType st t) flattenDecl st (ConstDecl n v t) = ConstDecl (translConst st n) v (flattenType st t) flattenDecl st (GlobalDecl n v t) = GlobalDecl (translGlobal st n) v (flattenType st t) +flattenType :: CStyle -> Type -> Type flattenType st (PrimType t) = PrimType t flattenType st (AliasType n) = AliasType $ flattenAlias st n flattenType st (RefType t) = RefType $ flattenRefType st t@@ -472,7 +476,7 @@ flattenRefType st (Array t n) = Array (flattenType st t) n flattenFunType :: CStyle -> FunType -> FunType-flattenFunType st (Function as r) = Function (fmap (flattenType st) as) (flattenType st r)+flattenFunType st (Function as r) = Function (fmap (second $ flattenType st) as) (flattenType st r) flattenCompType :: CStyle -> CompType -> CompType flattenCompType st (Enum ns) = Enum $ fmap (translEnumField st) ns@@ -655,7 +659,8 @@ where (typ, decls) = convertType st r args :: [CDecl]- args = map (\t -> declParam st Nothing t) as+ args = map (\(n,t) -> declParam st n t) $ as+ -- TODO #34 use name convertCompType :: CStyle -> CompType -> ([CTypeSpec], [CDerivedDeclr]) convertCompType st (Enum as) = ([typ], [])
src/Language/Modulo/Haskell.hs view
@@ -35,6 +35,7 @@ ) where import Data.Default+import Data.Foldable (toList) import Data.Semigroup import Data.Char (chr) import Data.Text (pack)@@ -100,31 +101,56 @@ convertTopLevel :: HaskellStyle -> Module -> HsModule convertTopLevel st (Module doc n is ds) = - HsModule def (convertModule n) Nothing [] $ fmap (convertDecl st . snd) ds+ -- TODO docs+ -- TODO nice export spec (excluding opaque struct types etc)+ HsModule def (convertModule n) Nothing imps decls+ where+ imps = standardForeignImports ++ concatMap (uncurry convertImport) is+ decls = concatMap (convertDecl st . snd) ds -convertDecl :: HaskellStyle -> Decl -> HsDecl+convertImport :: ModuleName -> Maybe String -> [HsImportDecl]+convertImport _ (Just "C") = [] -- Skip C imports+convertImport n _ = [HsImportDecl def (convertModule n) False Nothing Nothing]++standardForeignImports = [+ HsImportDecl def (Hs.Module "Foreign") False Nothing Nothing,+ HsImportDecl def (Hs.Module "Foreign.C") False Nothing Nothing]++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;+-- Uses return here as only opaque needs to emit an extra declaration+-- We might change the types of declType, declFun etc instead+convertDecl st (TypeDecl n (Just t)) = return $ declType st n t -- typedef T N;+convertDecl st (FunctionDecl n t) = return $ declFun st n t -- T n (as);+convertDecl st (TagDecl t) = return $ notSupported "Tag decls" -- T;+convertDecl st (ConstDecl n v t) = return $ notSupported "Constants" -- T n; or T n = v;+convertDecl st (GlobalDecl n v t) = return $ 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) [] [] []+declOpaque :: HaskellStyle -> Name -> [HsDecl] +declOpaque st (Name n) = error "Expected qualified name"+declOpaque st (QName _ n) = [HsDataDecl def [] (HsIdent $ n ++ "_") [] [] [], + HsTypeDecl def (HsIdent $ n) [] $+ HsTyCon (UnQual "Ptr") `HsTyApp` HsTyCon (UnQual (HsIdent $ n ++ "_"))] declType :: HaskellStyle -> Name -> Type -> HsDecl -declType st n t = HsTypeDecl def (HsIdent $ getName n) [] (convertType st t)+declType st n t = HsTypeDecl def (HsIdent $ getNameEnd n) [] (convertType st t) +-- TODO check purity properties and add IO if needed declFun :: HaskellStyle -> Name -> FunType -> HsDecl -declFun st n t = HsForeignImport def "ccall" HsUnsafe cName hsName hsType+declFun st n t = HsForeignImport def "ccall" HsUnsafe cName hsName (addIO hsType) where- cName = getName (translFun (cStyle st) n)- hsName = HsIdent (getName n)+ cName = getName (translFun (cStyle st) n) -- Always returns an unqualified name (TODO document in C module)+ hsName = HsIdent $ getNameEnd n hsType = convertFunType st t +addIO (HsTyFun a b) = HsTyFun a (addIO b)+addIO b = HsTyApp (HsTyVar $ HsIdent "IO") b +-- TODO move+-- | Returns the last part of an unqualified name.+getNameEnd (QName _ x) = x+getNameEnd _ = error "Expected qualified name"+ -- TODO partial on (CompType (Struct..)), (for struct, union and bitfield) convertType :: HaskellStyle -> Type -> HsType convertType st (AliasType n) = convertAlias st n@@ -134,8 +160,9 @@ 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))+convertAlias st n = HsTyCon $ UnQual $ HsIdent $ getNameEnd n+-- 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")@@ -176,13 +203,14 @@ 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)+ go (Function ((_,t):ts) r) = convertType st t `HsTyFun` convertFunType st (Function ts r)+ -- TODO #34 use param names 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"+convertCompType st (Struct as) = convertType st voidPtr+convertCompType st (Union as) = convertType st voidPtr+convertCompType st (BitField as) = notSupported "Haskell: bitfields" instance IsString HsName where fromString = HsIdent@@ -197,3 +225,6 @@ convertModule = Hs.Module . concatSep "." . getModuleNameList notSupported x = error $ "Not supported yet: " ++ x++-- TODO move+voidPtr = RefType (Pointer $ PrimType Void)
src/Language/Modulo/Lisp.hs view
@@ -22,10 +22,15 @@ printModuleLisp, renderModuleLisp, printModuleLispStyle,- renderModuleLispStyle+ renderModuleLispStyle,+ + -- ** Names+ convertName,+ convertType, ) where import Data.Default+import Data.Foldable (toList) import Data.Semigroup import Data.Char (chr) import Data.Text (pack)@@ -40,15 +45,19 @@ data LispStyle = LispStyle {- cStyle :: CStyle, -- ^ For generating foreign declarations- package :: String, -- ^ Package in which to generate definitions- safeOpaque :: Bool -- ^ If true, generate a wrapper class for each opaque type.+ cStyle :: CStyle, -- ^ For generating foreign declarations+ package :: String, -- ^ Package in which to generate definitions+ prefixMangler :: [String] -> [String], -- ^ A mangler for prefixes.+ safeOpaque :: Bool, -- ^ If true, generate a wrapper class for each opaque type.+ primBoolType :: Maybe PrimType -- ^ Type of primitive booleans (default Int). } stdLispStyle = LispStyle { cStyle = stdStyle, package = "cl-user",- safeOpaque = True+ prefixMangler = tail,+ safeOpaque = True,+ primBoolType = Nothing } -- | Default instance using 'stdStyle'.@@ -141,28 +150,29 @@ list [symbol "x", list [symbol "type", metaName]], list [symbol "make-instance", qualTypeName, keyword slot, symbol "x"]] - slot = withSuffix "-ptr" $ convertName n- qualMetaName = symbol $ withPrefix "'" $ withSuffix "-type" $ convertName n - metaName = symbol $ withSuffix "-type" $ convertName n - qualTypeName = symbol $ withPrefix "'" $ convertName n- typeName = symbol $ convertName n+ slot = withSuffix "-ptr" $ convertName st n+ qualMetaName = symbol $ withPrefix "'" $ withSuffix "-type" $ convertName st n + metaName = symbol $ withSuffix "-type" $ convertName st n + qualTypeName = symbol $ withPrefix "'" $ convertName st n+ typeName = symbol $ convertName st n -- return $ list [symbol "defctype", symbolName n, keyword "pointer"] declType :: LispStyle -> Name -> Type -> [Lisp] -declType st n t = return $ list [symbol "defctype", symbolName n, convertType st t]+declType st n t = return $ list [symbol "defctype", symbolName st n, convertType st t] declFun :: LispStyle -> Name -> FunType -> [Lisp] declFun st n (Function as r) = return $ list $ [symbol "defcfun", list [name, cname], ret] ++ args where- name = symbolName n+ name = symbolName st n ret = convertType st r cname = string $ convertCFunName (cStyle st) n argNames = map (symbol . return . chr) [97..(97+25)]- argTypes = map (convertType st) as + argTypes = map (\(_,t) -> convertType st t) $ as+ -- TODO #34 use names args = map (\(n,t) -> list [n, t]) (zip argNames argTypes) @@ -174,10 +184,12 @@ convertType st (CompType t) = convertCompType st t convertAlias :: LispStyle -> Name -> Lisp-convertAlias st n = symbolName n+convertAlias st n = symbolName st n convertPrimType :: LispStyle -> PrimType -> Lisp-convertPrimType st Bool = keyword "boolean"+convertPrimType st Bool = case primBoolType st of+ Nothing -> keyword "boolean"+ Just primBoolType -> list [keyword "boolean", convertPrimType st primBoolType] convertPrimType st Void = keyword "void" convertPrimType st Char = keyword "char" convertPrimType st Short = keyword "short" @@ -211,7 +223,8 @@ convertRefType :: LispStyle -> RefType -> Lisp convertRefType st (Pointer t) = list [keyword "pointer", convertType st t]-convertRefType st (Array t n) = notSupported "Array types with Lisp"+convertRefType st (Array t n) = convertRefType st (Pointer t)+-- convertRefType st (Array t n) = notSupported "Array types with Lisp" -- TODO convertFunType :: LispStyle -> FunType -> Lisp@@ -239,23 +252,18 @@ keyword :: String -> Lisp keyword x = Symbol (pack $ ":" ++ x) -stringName :: Name -> Lisp-stringName = string . convertName {- getName-}--symbolName :: Name -> Lisp-symbolName = symbol . convertName {- getName-}+stringName :: LispStyle -> Name -> Lisp+stringName st = string . convertName st {- getName-} -keywordName :: Name -> Lisp-keywordName = keyword . convertName {- getName-}+symbolName :: LispStyle -> Name -> Lisp+symbolName st = symbol . convertName st {- 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)+keywordName :: LispStyle -> Name -> Lisp+keywordName st = keyword . convertName st {- getName-} -stripPackage :: [String] -> [String]-stripPackage = tail--- TODO only strip prefix that matches (unmangle (package st))+convertName :: LispStyle -> Name -> String+convertName st (Name n) = toLowerString $ concatSep "-" $ unmangle n+convertName st (QName m n) = toLowerString $ concatSep "-" $ (prefixMangler st) (getModuleNameList m) ++ unmangle n convertCTypeName :: CStyle -> Name -> String convertCTypeName st n = getName (translType st n)@@ -266,6 +274,7 @@ -- TODO type fun const global enumF structF unionF +-- TODO move voidPtr = RefType (Pointer $ PrimType Void)
+ src/Language/Modulo/Pandoc.hs view
@@ -0,0 +1,216 @@++{-# LANGUAGE DisambiguateRecordFields, TypeFamilies,+ StandaloneDeriving, DeriveFunctor, DeriveFoldable, GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+-- License : BSD-style+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : GHC+--+-- Renders module descriptions (and documentation) as plain Pandoc.+--+-------------------------------------------------------------------------------------++module Language.Modulo.Pandoc (+ -- ** Styles+ PandocStyle(..),+ stdPandocStyle,+ -- ** Rendering+ -- printModulePandoc,+ renderModulePandoc,+ ) where++import Data.Default+import Data.Semigroup+import Data.Char (chr)+import Data.Text (pack)++import Language.Modulo.C+import Language.Modulo.Util+import Language.Modulo.Util.Unmangle+import Language.Modulo+import qualified Language.Modulo.C as C+import qualified Language.Modulo.Haskell as Haskell+import qualified Language.Modulo.Lisp as Lisp++-- DEBUG +import Control.Monad+import System.Directory+import System.Process+import Text.Pandoc.Options+import Text.Pandoc.Templates+import Language.Modulo.Load+import Language.Modulo.Parse+import Language.Modulo.Rename+-- DEBUG++import qualified Data.List as List+import Text.Pandoc.Definition+import Text.Pandoc.Writers.HTML+import Text.Pandoc.Writers.LaTeX+import Text.Pandoc.Readers.Markdown++data PandocStyle = PandocStyle+ deriving (Eq, Ord, Show)++stdMeta = Meta [] [] []+blockToPandoc = Pandoc stdMeta . return+blocksToPandoc = Pandoc stdMeta+mdStringToPandoc = readMarkdown def+instance Semigroup Pandoc where+ (<>) = mappend+instance Monoid Pandoc where+ mempty = Pandoc stdMeta mempty+ Pandoc m1 bs1 `mappend` Pandoc m2 bs2 = Pandoc (m1 {-First-}) (bs1 <> bs2)++stdPandocStyle = PandocStyle++renderModulePandoc :: Module -> Pandoc+renderModulePandoc = renderModulePandocStyle stdPandocStyle+++renderModulePandocStyle :: PandocStyle -> Module -> Pandoc+renderModulePandocStyle st mod = Pandoc stdMeta [+ Header 2 ("", [], [("id",show $ modName mod)]) [Str (show $ modName mod)]+ -- CodeBlock nullAttr "import X.X.X",+ -- CodeBlock nullAttr "foo : Ptr -> Ptr"+ ] <> is <> ds+ where+ is = mconcat $ fmap (uncurry $ convertImport st) $ modImports mod+ ds = mconcat $ fmap (uncurry $ convertDocDecl st) $ modDecls mod++-- TODO link+convertImport :: PandocStyle -> ModuleName -> Maybe String -> Pandoc+convertImport st name conv = blockToPandoc $ CodeBlock nullAttr $ "import " ++ show name++convertDocDecl :: PandocStyle -> Doc -> Decl -> Pandoc+convertDocDecl st doc decl = blocksToPandoc [+ CodeBlock css $ unname $ getDeclName decl+ ]+ <>+ (mdStringToPandoc $ getDoc $ doc)+ where+ -- unname = maybe "" (show . C.translFun def)+ -- unname = maybe "" getShortName+ unname = if isTypeDecl decl + then ("(defclass " ++) . (++ " ())") . maybe "" (Lisp.convertName def) + else (\x -> "(defun " ++ x ++ " (" ++ List.intercalate " " (argNames decl) ++ "))") . maybe "" (Lisp.convertName def)+ where+ isTypeDecl (TypeDecl _ _) = True+ isTypeDecl _ = False++ argNames (FunctionDecl _ ft) = argNames2 ft+ argNames2 (Function as r) = fmap (showT.snd) as ++ [showT r]+ showT = show . Lisp.convertType def+ -- TODO #34 use name++ css = (".codeName", [], [("", "")])+ + getShortName (QName _ n) = n++++ +-- allFilesMatching :: FilePath -> (FilePath -> Bool) -> IO [FilePath]++++++++main = documentFiles ["/Users/hans/audio/modules"] "/Users/hans/audio/modules"+-- main = documentFile ["/Users/hans/audio/modules"] "/Users/hans/audio/modules/Fa/Signal.module"++document :: [ModulePath] -> String -> IO Pandoc+document mpaths str = do+ mod <- unsafeRename mpaths . unsafeParse $ str+ putStr $ "Documenting " ++ show (modName mod) ++ "\n"+ return $ renderModulePandoc mod++documentFiles :: [ModulePath] -> FilePath -> IO ()+documentFiles mpaths path = do+ paths <- listFilesMatching path (List.isSuffixOf ".module")+ pandocs <- mapM (\path -> document mpaths =<< readFile path) paths+ strs <- toHtmlStr $ mconcat pandocs+ writeFile "test.html" $ strs+ return ()+ where+ cssBody = mempty+ <> "body > pre { "+ <> " padding: 20px; "+ <> " margin-top: 15px; "+ <> " margin-bottom: 15px; "+ <> " background: #faffff; "+ <> " border-radius: 12px; "+ <> " border: 1px solid LightGrey; "+ <> " box-shadow: 3px 3px 5px #eee; "+ <> " overflow: auto; "+ <> "}"+ <> ""+ <> ""+ <> ""+ <> ""+ <> ""+ <> ""+ <> ""+ <> ""+ + toHtmlStr :: Pandoc -> IO String+ toHtmlStr str = do+ Right templ <- getDefaultTemplate Nothing "html"+ return $ flip writeHtmlString str $ def {+ writerTemplate = templ,+ writerStandalone = True,+ writerTableOfContents = True,+ writerVariables = [("highlighting-css", cssBody)] }++documentFile :: [ModulePath] -> FilePath -> IO ()+documentFile mpaths path = do + pd <- document mpaths =<< readFile path+ writeFile "test.html" $ writeHtmlString def pd +++++unsafeRename :: [ModulePath] -> Module -> IO Module+unsafeRename paths m = do+ deps <- loadDependencies (withStdModulePaths paths) m+ return $ rename deps m+ +unsafeParse :: String -> Module+unsafeParse s = case (parse s) of+ Left e -> error $ "Parse error: " ++ show e+ Right m -> m+ ++listFilesMatching :: FilePath -> (FilePath -> Bool) -> IO [FilePath]+listFilesMatching path pred = fmap (filter pred) $ listFilesR path++listFilesR :: FilePath -> IO [FilePath]+listFilesR = listFilesR' . (<> "/")++listFilesR' path = let+ isDODD :: String -> Bool+ isDODD f = not $ (List.isSuffixOf "/." f) || (List.isSuffixOf "/.." f)+ -- isDODD _ = True++ listDirs :: [FilePath] -> IO [FilePath]+ listDirs = filterM doesDirectoryExist . fmap (<> "/")++ listFiles :: [FilePath] -> IO [FilePath]+ listFiles = filterM doesFileExist++ joinFN :: String -> String -> FilePath+ joinFN p1 p2 = mconcat [p1, p2]++ in do+ allfiles <- getDirectoryContents path+ no_dots <- filterM (return . isDODD) (map (joinFN path) allfiles)+ dirs <- listDirs no_dots+ subdirfiles <- (mapM (listFilesR'{- . (<> "/")-}) dirs >>= return . concat)+ files <- listFiles no_dots+ return $ files ++ subdirfiles
src/Language/Modulo/Parse.hs view
@@ -17,10 +17,14 @@ module Language.Modulo.Parse ( parse, parseName,+ parsePrimType,+ parsePrimTypeMaybe, unsafeParseFile ) where import Control.Monad+import Control.Arrow+import Data.Monoid import Data.Maybe import Control.Applicative hiding ((<|>), optional, many) @@ -48,6 +52,20 @@ parseName = runParser nameParser () "" -- |+-- Parse a primitive type, returning an error if unsuccessful.+--+parsePrimType :: String -> Either ParseError PrimType+parsePrimType = fmap unPrimType . runParser primTypeParser () ""+ where+ unPrimType (PrimType x) = x++-- |+-- Parse a primitive type, returning an error if unsuccessful.+--+parsePrimTypeMaybe :: String -> Maybe PrimType+parsePrimTypeMaybe = eitherToMaybe . parsePrimType++-- | -- Parse a module description from the given file, or fail if unsuccessful. -- -- This unsafe function should not be used in production code.@@ -149,25 +167,30 @@ opaqueParser :: Parser () opaqueParser = reserved lexer "opaque" >> return () +-- To parse a type, we first parse all types whose syntax does not involve+-- post-qualifiers (i.e. pointer and function), then parse the modifiers to+-- generate a qualifier, and apply it to the prefix. I.e. in (a -> b) we first+-- parse a, then (-> b), and modify a by applying (-> b). typeParser :: Parser Type typeParser = do typs <- typeStartParser mods <- typeEndParser return $ mods typs -typeStartParser :: Parser [Type]+typeStartParser :: Parser [(Maybe Name,Type)] typeStartParser = mzero <|> parenTypeParser- <|> single <$> arrayTypeParser- <|> single <$> enumTypeParser- <|> single <$> unionTypeParser- <|> single <$> structTypeParser- <|> single <$> bitfieldTypeParser- <|> single <$> primTypeParser- <|> single <$> aliasTypeParser+ <|> (single.returnPair) <$> arrayTypeParser+ <|> (single.returnPair) <$> enumTypeParser+ <|> (single.returnPair) <$> unionTypeParser+ <|> (single.returnPair) <$> structTypeParser+ <|> (single.returnPair) <$> bitfieldTypeParser+ <|> (single.returnPair) <$> primTypeParser+ <|> (single.returnPair) <$> aliasTypeParser+returnPair x = (Nothing,x) -typeEndParser :: Parser ([Type] -> Type)-typeEndParser = foldr (flip c2) head <$> many (ptr <|> func)+typeEndParser :: Parser ([(Maybe Name, Type)] -> Type)+typeEndParser = foldr comp noTypeEnd <$> many (ptr <|> func) where ptr = do llex $ char '*'@@ -176,27 +199,33 @@ llex $ string "->" typ <- typeParser return $ mkFun typ- - mkPtr :: [Type] -> Type- mkPtr [x] = RefType . Pointer $ x- mkPtr _ = error "Can not make pointer of argument head"- -- TODO reflect up to parser hierarchy - mkFun :: Type -> [Type] -> Type- mkFun r as = FunType $ Function as r+ noTypeEnd :: [(Maybe Name, Type)] -> Type+ noTypeEnd [(_,x)] = x+ noTypeEnd _ = error "Unexpected argument head"+ + mkPtr :: [(Maybe Name, Type)] -> Type+ mkPtr [(_,x)] = RefType . Pointer $ x+ mkPtr _ = error "Unexpected argument head" - -- TODO is this (=<=) in Control.Comonad ?- c2 :: ([b] -> c) -> ([a] -> b) -> [a] -> c- c2 g f = g . single . f- + mkFun :: Type -> [(Maybe Name, Type)] -> Type+ mkFun r as = FunType $ Function as r + -- TODO is this (=>=) in Control.Comonad ?+ comp :: ([(Maybe x,a)] -> b) -> ([(Maybe x,b)] -> c) -> [(Maybe x,a)] -> c+ comp g f = f . single . returnPair . g++-- This is not really a type, but the product used to express the argument to an uncurried function.+-- However, if it is just a one-tuple without a name, it will be treated as an ordinary type.+-- That is (A) -> B is the same as A -> B.+ -- TODO support named arguments-parenTypeParser :: Parser [Type]+parenTypeParser :: Parser [(Maybe Name, Type)] parenTypeParser = do llex $ char '('- typ <- typeParser `sepBy` (llex $ char ',')+ types <- maybeNameTypeParser `sepBy` (llex $ char ',') llex $ char ')'- return typ+ return $ types arrayTypeParser :: Parser Type arrayTypeParser = do@@ -302,6 +331,8 @@ typ <- typeParser return $ (name, typ) +maybeNameTypeParser :: Parser (Maybe Name, Type)+maybeNameTypeParser = try (fmap (first Just) unameTypeParser) <|> fmap returnPair typeParser -- Extra combinators, not exported occs p = length <$> many p@@ -353,3 +384,5 @@ notSupported x = error $ "Not supported yet: " ++ x +eitherToMaybe (Right x) = Just x+eitherToMaybe (Left _) = Nothing
src/Language/Modulo/Rename.hs view
@@ -17,6 +17,7 @@ rename ) where +import Control.Arrow import Control.Exception import Data.List (isSuffixOf) import Data.Maybe (catMaybes)@@ -49,7 +50,7 @@ renameDecl (GlobalDecl n v t) = GlobalDecl (simplify $ qualify mod n) v (renameType t) renameType (PrimType t) = PrimType t- renameType (AliasType n) = AliasType $ simplify $ resolveName (mod : deps) n+ renameType (AliasType n) = AliasType $ simplify $ resolveName mod (mod : deps) n renameType (RefType t) = RefType $ renameRefType t renameType (FunType t) = FunType $ renameFunType t renameType (CompType t) = CompType $ renameCompType t@@ -59,7 +60,7 @@ renameRefType (Array t j) = Array (renameType t) j renameFunType :: FunType -> FunType- renameFunType (Function as r) = Function (fmap renameType as) (renameType r)+ renameFunType (Function as r) = Function (fmap (second renameType) as) (renameType r) renameCompType :: CompType -> CompType renameCompType (Enum ns) = Enum ns@@ -71,10 +72,10 @@ qualify m (Name n) = QName (modName m) n qualify _ (QName _ _) = error "Name already qualified" -resolveName :: [Module] -> Name -> Name-resolveName ms (QName m n) = QName m n-resolveName ms n@(Name n') = case findName ms n of- Nothing -> error $ "Could not find: " ++ show n'+resolveName :: Module -> [Module] -> Name -> Name+resolveName errorMsgMod deps (QName m n) = QName m n+resolveName errorMsgMod deps n@(Name n') = case findName deps n of+ Nothing -> error $ "Could not find '" ++ show n' ++ "' in module " ++ show (modName errorMsgMod) Just m -> QName m n' -- |
src/Main.hs view
@@ -4,8 +4,9 @@ module Main where -import Control.Monad (when)+import Control.Monad (when, join) import Data.List (find)+import Data.Default import Data.Maybe (fromMaybe, maybeToList) import System.IO import System.Exit@@ -40,9 +41,10 @@ data ModOpt = Help | Version- | Package { getPackage :: String } | Lang { getLang :: ModLang } | Path { getPath :: [ModulePath] }+ | LispPackage { getLispPackage :: Maybe String }+ | LispPrimBool { getLispPrimBool :: Maybe PrimType } deriving (Eq, Show) readModLang :: Maybe String -> ModOpt@@ -65,10 +67,13 @@ -- TODO accept more than one, separate by commas readPackage :: Maybe String -> ModOpt-readPackage = Package . maybe "user" id+readPackage = LispPackage +readPrimBool :: Maybe String -> ModOpt+readPrimBool = LispPrimBool . (=<<) parsePrimTypeMaybe -version = "modulo-1.5"++version = "modulo-1.7.2" header = "Usage: modulo [options]\n" ++ "Usage: modulo [options] files...\n" ++ "\n" ++@@ -81,7 +86,8 @@ (Option ['v'] ["version"] (NoArg Version) "Print version and exit"), (Option ['L'] ["language"] (OptArg readModLang "LANG") "Output language"), (Option ['M'] ["module-path"] (OptArg readModPath "PATH") "Module paths"),- (Option [] ["lisp-package"] (OptArg readPackage "STRING") "Lisp package")+ (Option [] ["lisp-package"] (OptArg readPackage "STRING") ("Lisp package (default: " ++ package def ++ ")")),+ (Option [] ["lisp-primitive-bool"] (OptArg readPrimBool "STRING") ("Optional primitive boolean type (Char|Int|UChar|UInt...)")) ] main = do@@ -104,10 +110,18 @@ where isPath (Path _) = True isPath _ = False-findPackage opts = fmap getPackage $ find isPackage opts++findLispPackage :: [ModOpt] -> Maybe String+findLispPackage opts = join $ fmap getLispPackage $ find isLispPackage opts where - isPackage (Package _) = True- isPackage _ = False+ isLispPackage (LispPackage _) = True+ isLispPackage _ = False++findLispPrimBool :: [ModOpt] -> Maybe PrimType+findLispPrimBool opts = join $ fmap getLispPrimBool $ find isLispPrimBool opts+ where + isLispPrimBool (LispPrimBool _) = True+ isLispPrimBool _ = False -- | -- Run as a filter from stdin to stdout.@@ -119,12 +133,13 @@ compileFile opts input output = do let lang = fromMaybe C (findLang opts) let paths = fromMaybe [] (findPath opts)- let package = fromMaybe "user" (findPackage opts)+ let lispPackage = findLispPackage opts+ let lispPrimBool = findLispPrimBool opts s <- hGetContents input let m = unsafeParse s mr <- unsafeRename paths m- let c = printMod lang mr+ let c = printMod lispPackage lispPrimBool lang mr hPutStr output c return ()@@ -139,8 +154,17 @@ Left e -> error $ "Parse error: " ++ show e Right m -> m - printMod :: ModLang -> Module -> String- printMod C = printModuleComm- printMod Lisp = printModuleLisp- printMod Haskell = printModuleHaskell+ printMod :: Maybe String -> Maybe PrimType -> ModLang -> Module -> String+ printMod lp lpm C = printModuleComm+ printMod lp lpm Lisp = printModuleLispStyle $ maybeDo setP lp $ setPM lpm $ def+ where+ setP p s = s { package = p }+ setPM pm s = s { primBoolType = pm }+ printMod lp lpm Haskell = printModuleHaskell+++maybeDo :: (a -> b -> b) -> Maybe a -> b -> b+maybeDo f Nothing = id+maybeDo f (Just x) = f x+