diff --git a/DDC/Base/Parser.hs b/DDC/Base/Parser.hs --- a/DDC/Base/Parser.hs +++ b/DDC/Base/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} -- | Parser utilities. module DDC.Base.Parser @@ -107,12 +108,16 @@ ------------------------------------------------------------------------------- instance Pretty P.ParseError where + data PrettyMode P.ParseError = PrettyParseError + pprDefaultMode = PrettyParseError ppr err = vcat $ [ text "Parse error in" <+> text (show (P.errorPos err)) ] ++ (map ppr $ packMessages $ P.errorMessages err) instance Pretty P.Message where + data PrettyMode P.Message = PrettyMessage + pprDefaultMode = PrettyMessage ppr msg = case msg of SysUnExpect str -> text "Unexpected" <+> text str <> text "." diff --git a/DDC/Base/Pretty.hs b/DDC/Base/Pretty.hs --- a/DDC/Base/Pretty.hs +++ b/DDC/Base/Pretty.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} -- | Pretty printer utilities. -- @@ -29,28 +30,36 @@ = if b then parens c else c + -- Pretty Class -------------------------------------------------------------- class Pretty a where - ppr :: a -> Doc - ppr = pprPrec 0 + data PrettyMode a + pprDefaultMode :: PrettyMode a + + ppr :: a -> Doc + ppr = pprPrec 0 - pprPrec :: Int -> a -> Doc - pprPrec _ = ppr + pprPrec :: Int -> a -> Doc + pprPrec p = pprModePrec pprDefaultMode p + pprModePrec :: PrettyMode a -> Int -> a -> Doc + pprModePrec _ _ x = ppr x + + instance Pretty () where - ppr = text . show + ppr = text . show instance Pretty Bool where - ppr = text . show + ppr = text . show instance Pretty Int where - ppr = text . show + ppr = text . show instance Pretty Integer where - ppr = text . show + ppr = text . show instance Pretty Char where - ppr = text . show + ppr = text . show instance Pretty a => Pretty [a] where ppr xs = encloseSep lbracket rbracket comma diff --git a/DDC/Control/Monad/Check.hs b/DDC/Control/Monad/Check.hs --- a/DDC/Control/Monad/Check.hs +++ b/DDC/Control/Monad/Check.hs @@ -3,32 +3,72 @@ module DDC.Control.Monad.Check ( CheckM (..) , throw - , result) + , runCheck + , evalCheck + , get + , put) where +import Control.Applicative +import Control.Monad -data CheckM err a - = CheckM (Either err a) +-- | Checker monad maintains some state and manages errors during type checking. +data CheckM s err a + = CheckM (s -> (s, Either err a)) -instance Monad (CheckM err) where +instance Functor (CheckM s err) where + fmap = liftM + + +instance Applicative (CheckM s err) where + (<*>) = ap + pure = return + + +instance Monad (CheckM s err) where return !x - = CheckM (Right x) + = CheckM (\s -> (s, Right x)) {-# INLINE return #-} - (>>=) !m !f - = case m of - CheckM (Left err) -> CheckM (Left err) - CheckM (Right x) -> x `seq` f x + (>>=) !(CheckM f) !g + = CheckM $ \s + -> case f s of + (s', Left err) -> (s', Left err) + (s', Right x) -> s `seq` x `seq` runCheck s' (g x) {-# INLINE (>>=) #-} +-- | Run a checker computation, +-- returning the result and new state. +runCheck :: s -> CheckM s err a -> (s, Either err a) +runCheck s (CheckM f) = f s +{-# INLINE runCheck #-} + + +-- | Run a checker computation, +-- ignoreing the final state. +evalCheck :: s -> CheckM s err a -> Either err a +evalCheck s m = snd $ runCheck s m +{-# INLINE evalCheck #-} + + -- | Throw a type error in the monad. -throw :: err -> CheckM err a -throw !e = CheckM $ Left e +throw :: err -> CheckM s err a +throw !e = CheckM $ \s -> (s, Left e) +{-# INLINE throw #-} --- | Take the result from a check monad. -result :: CheckM err a -> Either err a -result (CheckM r) = r +-- | Get the state from the monad. +get :: CheckM s err s +get = CheckM $ \s -> (s, Right s) +{-# INLINE get #-} + + +-- | Put a new state into the monad. +put :: s -> CheckM s err () +put s + = CheckM $ \_ -> (s, Right ()) +{-# INLINE put #-} + diff --git a/DDC/Data/ListUtils.hs b/DDC/Data/ListUtils.hs --- a/DDC/Data/ListUtils.hs +++ b/DDC/Data/ListUtils.hs @@ -6,8 +6,11 @@ ( takeHead , takeTail , takeInit - , index) + , takeMaximum + , index + , findDuplicates) where +import qualified Data.Set as Set -- | Take the head of a list, or `Nothing` if it's empty. @@ -34,9 +37,28 @@ _ -> Just (init xs) +-- | Take the maximum of a list, or `Nothing` if it's empty. +takeMaximum :: Ord a => [a] -> Maybe a +takeMaximum xs + = case xs of + [] -> Nothing + _ -> Just (maximum 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) + + + +-- | Fine the duplicate values in a list. +findDuplicates :: Ord n => [n] -> [n] +findDuplicates xx + = go (Set.fromList xx) xx + where go _ [] = [] + go ss (x : xs) + | Set.member x ss = go (Set.delete x ss) xs + | otherwise = x : go ss xs diff --git a/DDC/Data/SourcePos.hs b/DDC/Data/SourcePos.hs --- a/DDC/Data/SourcePos.hs +++ b/DDC/Data/SourcePos.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE TypeFamilies #-} module DDC.Data.SourcePos (SourcePos (..)) where @@ -27,8 +27,8 @@ -- 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 + = text $ source ppr (SourcePos source l c) - = ppr $ source ++ ":" ++ show l ++ ":" ++ show c + = text $ source ++ ":" ++ show l ++ ":" ++ show c diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy @@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -------------------------------------------------------------------------------- -Under Australian law copyright is free and automatic. -By contributing to DDC authors grant all rights they have regarding their -contributions to the other members of the Disciplined Disciple Compiler Strike -Force, past, present and future, as well as placing their contributions under -the above license. - -Use "darcs show authors" to get a list of Strike Force members. - -------------------------------------------------------------------------------- -Redistributions of libraries in ./external are governed by their own licenses: - - - TinyPTC GNU Lesser General Public License - 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.3.2.1 +Version: 0.4.1.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -17,13 +17,13 @@ Library Build-Depends: - base == 4.6.*, + base >= 4.6 && < 4.8, + deepseq == 1.3.*, transformers == 0.3.*, containers == 0.5.*, wl-pprint == 1.1.*, - parsec == 3.1.*, - deepseq == 1.3.* - + parsec == 3.1.* + Exposed-modules: DDC.Base.Parser DDC.Base.Pretty @@ -38,6 +38,8 @@ GHC-options: -Wall -fno-warn-orphans + -fno-warn-type-defaults + -fno-warn-missing-methods Extensions: ParallelListComp