diff --git a/DDC/Base/Lexer.hs b/DDC/Base/Lexer.hs deleted file mode 100644 --- a/DDC/Base/Lexer.hs +++ /dev/null @@ -1,49 +0,0 @@ - --- | Lexer utilities. -module DDC.Base.Lexer - ( SourcePos (..) - - -- * Tokens - , Token (..) - , takeParsecSourcePos) -where -import DDC.Base.Pretty -import qualified Text.Parsec.Pos as P - - --- SourcePos ------------------------------------------------------------------ --- | A position in the source file. --- --- If there is no file path then we assume that the input has been read --- from an interactive session and display '''' when pretty printing. -data SourcePos - = SourcePos - { sourcePosFile :: Maybe FilePath - , sourcePosLine :: Int - , sourcePosColumn :: Int } - deriving (Eq, Show) - - -instance Pretty SourcePos where - ppr (SourcePos (Just f) l c) - = ppr $ f ++ ":" ++ show l ++ ":" ++ show c - - ppr (SourcePos Nothing l c) - = ppr $ ":" ++ show l ++ ":" ++ show c - - --- Token----------------------------------------------------------------------- --- | Wrapper for primitive token type that gives it a source position. -data Token t - = Token - { tokenTok :: t - , tokenSourcePos :: SourcePos } - deriving (Eq, Show) - - --- | Take the parsec style source position from a token. -takeParsecSourcePos :: Token k -> P.SourcePos -takeParsecSourcePos (Token _ sp) - = case sp of - SourcePos Nothing l c -> P.newPos "" l c - SourcePos (Just f) l c -> P.newPos f l c diff --git a/DDC/Base/Parser.hs b/DDC/Base/Parser.hs --- a/DDC/Base/Parser.hs +++ b/DDC/Base/Parser.hs @@ -9,8 +9,8 @@ , pTokAs , pTok) where -import DDC.Base.Lexer import DDC.Base.Pretty +import DDC.Data.Token import Data.Functor.Identity import Text.Parsec import Text.Parsec as P diff --git a/DDC/Base/Pretty.hs b/DDC/Base/Pretty.hs --- a/DDC/Base/Pretty.hs +++ b/DDC/Base/Pretty.hs @@ -37,11 +37,16 @@ pprPrec :: Int -> a -> Doc pprPrec _ = ppr +instance Pretty () where + ppr = text . show instance Pretty Bool where ppr = text . show instance Pretty Int where + ppr = text . show + +instance Pretty Integer where ppr = text . show instance Pretty Char where diff --git a/DDC/Control/Monad/Check.hs b/DDC/Control/Monad/Check.hs new file mode 100644 --- /dev/null +++ b/DDC/Control/Monad/Check.hs @@ -0,0 +1,34 @@ + +-- | A simple exception monad. +module DDC.Control.Monad.Check + ( CheckM (..) + , throw + , result) +where + + +data CheckM err a + = CheckM (Either err a) + + +instance Monad (CheckM err) where + return !x + = CheckM (Right x) + {-# INLINE return #-} + + (>>=) !m !f + = case m of + CheckM (Left err) -> CheckM (Left err) + CheckM (Right x) -> x `seq` f x + {-# INLINE (>>=) #-} + + +-- | Throw a type error in the monad. +throw :: err -> CheckM err a +throw !e = CheckM $ Left e + + +-- | Take the result from a check monad. +result :: CheckM err a -> Either err a +result (CheckM r) = r + diff --git a/DDC/Data/Canned.hs b/DDC/Data/Canned.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/Canned.hs @@ -0,0 +1,13 @@ + +module DDC.Data.Canned + (Canned(..)) +where + +-- | This function has a show instance that prints \"CANNED\" for any contained +-- type. We use it to wrap functional fields in data types that we still want +-- to derive Show instances for. +data Canned a + = Canned a + +instance Show (Canned a) where + show _ = "CANNED" diff --git a/DDC/Data/ListUtils.hs b/DDC/Data/ListUtils.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/ListUtils.hs @@ -0,0 +1,42 @@ + +-- | Replacements for unhelpful Haskell list functions. +-- If the standard versions are passed an empty list then we don't +-- get a proper source location. +module DDC.Data.ListUtils + ( takeHead + , takeTail + , takeInit + , index) +where + + +-- | Take the head of a list, or `Nothing` if it's empty. +takeHead :: [a] -> Maybe a +takeHead xs + = case xs of + [] -> Nothing + _ -> Just (head xs) + + +-- | Take the tail of a list, or `Nothing` if it's empty. +takeTail :: [a] -> Maybe [a] +takeTail xs + = case xs of + [] -> Nothing + _ -> Just (tail xs) + + +-- | Take the init of a list, or `Nothing` if it's empty. +takeInit :: [a] -> Maybe [a] +takeInit xs + = case xs of + [] -> Nothing + _ -> Just (init xs) + + +-- | Retrieve the element at the given index, +-- or `Nothing if it's not there. +index :: [a] -> Int -> Maybe a +index [] _ = Nothing +index (x : _) 0 = Just x +index (_ : xs) i = index xs (i - 1) diff --git a/DDC/Data/SourcePos.hs b/DDC/Data/SourcePos.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/SourcePos.hs @@ -0,0 +1,29 @@ + +module DDC.Data.SourcePos + (SourcePos (..)) +where +import DDC.Base.Pretty + + +-- | A position in a source file. +-- +-- If there is no file path then we assume that the input has been read +-- from an interactive session and display '''' when pretty printing. +data SourcePos + = SourcePos + { sourcePosSource :: String + , sourcePosLine :: Int + , sourcePosColumn :: Int } + deriving (Eq, Show) + + +instance Pretty SourcePos where + -- Suppress printing of line and column number when they are both zero. + -- File line numbers officially start from 1, so having 0 0 probably + -- means this isn't real information. + ppr (SourcePos source 0 0) + = ppr $ source + + ppr (SourcePos source l c) + = ppr $ source ++ ":" ++ show l ++ ":" ++ show c + diff --git a/DDC/Data/Token.hs b/DDC/Data/Token.hs new file mode 100644 --- /dev/null +++ b/DDC/Data/Token.hs @@ -0,0 +1,36 @@ + +module DDC.Data.Token + ( Token(..) + , takeParsecSourcePos + , tokenLine + , tokenColumn) +where +import DDC.Data.SourcePos +import qualified Text.Parsec.Pos as P + + +-- | Wrapper for primitive token type that gives it a source position. +data Token t + = Token + { tokenTok :: t + , tokenSourcePos :: SourcePos } + deriving (Eq, Show) + + +-- | Take the parsec style source position from a token. +takeParsecSourcePos :: Token k -> P.SourcePos +takeParsecSourcePos (Token _ sp) + = case sp of + SourcePos source l c + -> P.newPos source l c + + +-- | Take the line number of a token. +tokenLine :: Token t -> Int +tokenLine (Token _ (SourcePos _ l _)) = l + + +-- | Take the column number of a token. +tokenColumn :: Token t -> Int +tokenColumn (Token _ (SourcePos _ _ c)) = c + diff --git a/ddc-base.cabal b/ddc-base.cabal --- a/ddc-base.cabal +++ b/ddc-base.cabal @@ -1,5 +1,5 @@ Name: ddc-base -Version: 0.2.1.2 +Version: 0.3.1.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -10,10 +10,11 @@ Category: Compilers/Interpreters Homepage: http://disciple.ouroborus.net Bug-reports: disciple@ouroborus.net -Synopsis: Disciple Core language common utilities. +Synopsis: Disciplined Disciple Compiler common utilities. Description: This package re-exports the main external dependencies of - the Disciplined Disciple Compiler project. + the Disciplined Disciple Compiler project, and provides some + common utilities. Library Build-Depends: @@ -24,9 +25,15 @@ parsec == 3.1.* Exposed-modules: - DDC.Base.Lexer DDC.Base.Parser DDC.Base.Pretty + + DDC.Control.Monad.Check + + DDC.Data.Canned + DDC.Data.SourcePos + DDC.Data.Token + DDC.Data.ListUtils GHC-options: -Wall @@ -38,3 +45,4 @@ RankNTypes FlexibleContexts KindSignatures + BangPatterns