diff --git a/DDC/Base/Env.hs b/DDC/Base/Env.hs new file mode 100644 --- /dev/null +++ b/DDC/Base/Env.hs @@ -0,0 +1,174 @@ + +-- | Generic environment that handles both named and anonymous +-- de-bruijn binders. +module DDC.Base.Env + ( -- * Types + Bind (..) + , Bound (..) + , Env (..) + + -- * Conversion + , fromList + , fromNameList + , fromNameMap + + -- * Constructors + , empty + , singleton + , extend, extends + , union, unions + + -- * Lookup + , member + , lookup + , lookupName, lookupIx + , depth) +where +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import qualified Prelude as P +import Prelude hiding (lookup) + + +------------------------------------------------------------------------------- +-- | A binding occurrence of a variable. +data Bind n + -- | No binding, or alternatively, bind a fresh name that has + -- no bound uses. + = BNone + + -- | Anonymous binder. + | BAnon + + -- | Named binder. + | BName !n + deriving (Eq, Ord, Show) + + +-- | A bound occurrence of a variable. +data Bound n + -- | Index an anonymous binder. + = UIx !Int + + -- | Named variable. + | UName !n + deriving (Eq, Ord, Show) + + +-- | Generic environment that maps a variable to a thing of type @a@. +data Env n a + = Env + { -- | Named things. + envMap :: !(Map n a) + + -- | Anonymous things. + , envStack :: ![a] + + -- | Length of the stack. + , envStackLength :: !Int } + + +------------------------------------------------------------------------------- +-- | Convert a list of `Bind`s to an environment. +fromList :: Ord n => [(Bind n, a)] -> Env n a +fromList bs + = foldr (uncurry extend) empty bs + + +-- | Convert a list of `Bind`s to an environment. +fromNameList :: Ord n => [(n, a)] -> Env n a +fromNameList bs + = foldr (uncurry extend) empty + $ [(BName n, x) | (n, x) <- bs ] + + +-- | Convert a map of things to an environment. +fromNameMap :: Map n a -> Env n a +fromNameMap m + = empty { envMap = m } + + +--------------------------------------------------------------------------------- +-- | An empty environment, with nothing in it. +empty :: Env n a +empty = Env + { envMap = Map.empty + , envStack = [] + , envStackLength = 0 } + + +-- | Construct a singleton environment. +singleton :: Ord n => Bind n -> a -> Env n a +singleton b x + = extend b x empty + + +-- | Extend an environment with a new binding. +-- Replaces bindings with the same name already in the environment. +extend :: Ord n => Bind n -> a -> Env n a -> Env n a +extend bb x env + = case bb of + BNone{} -> env + + BAnon -> env { envStack = x : envStack env + , envStackLength = envStackLength env + 1 } + + BName n -> env { envMap = Map.insert n x (envMap env) } + + +-- | Extend an environment with a list of new bindings. +-- Replaces bindings with the same name already in the environment. +extends :: Ord n => [(Bind n, a)] -> Env n a -> Env n a +extends bs env + = foldl (flip (uncurry extend)) env bs + + +-- | Combine two environments. +-- If both environments have a binding with the same name, +-- then the one in the second environment takes preference. +union :: Ord n => Env n a -> Env n a -> Env n a +union env1 env2 + = Env + { envMap = envMap env1 `Map.union` envMap env2 + , envStack = envStack env2 ++ envStack env1 + , envStackLength = envStackLength env2 + envStackLength env1 } + + +-- | Combine multiple environments, +-- with the latter ones taking preference. +unions :: Ord n => [Env n a] -> Env n a +unions envs + = foldr union empty envs + + +-- | Check whether a bound variable is present in an environment. +member :: Ord n => Bound n -> Env n a -> Bool +member uu env + = isJust $ lookup uu env + + +-- | Lookup a bound variable from an environment. +lookup :: Ord n => Bound n -> Env n a -> Maybe a +lookup uu env + = case uu of + UIx i -> P.lookup i (zip [0..] (envStack env)) + UName n -> Map.lookup n (envMap env) + + +-- | Lookup a value from the environment based on its name. +lookupName :: Ord n => n -> Env n a -> Maybe a +lookupName n env + = Map.lookup n (envMap env) + + +-- | Lookup a value from the environment based on its index. +lookupIx :: Ord n => Int -> Env n a -> Maybe a +lookupIx ix env + = P.lookup ix (zip [0..] (envStack env)) + + +-- | Yield the total depth of the anonymous stack. +depth :: Env n a -> Int +depth env = envStackLength env + 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/Name.hs b/DDC/Base/Name.hs new file mode 100644 --- /dev/null +++ b/DDC/Base/Name.hs @@ -0,0 +1,22 @@ + +module DDC.Base.Name + ( StringName (..) + , CompoundName (..)) +where + +class StringName n where + -- | Produce a flat string from a name. + -- The resulting string should be re-lexable as a bindable name. + stringName :: n -> String + + +-- | Compound names can be extended to create new names. +-- This is useful when generating fresh names during program transformation. +class CompoundName n where + -- | Build a new name based on the given one. + extendName :: n -> String -> n + + -- | Split the extension string from a name. + splitName :: n -> Maybe (n, String) + + diff --git a/DDC/Base/Panic.hs b/DDC/Base/Panic.hs new file mode 100644 --- /dev/null +++ b/DDC/Base/Panic.hs @@ -0,0 +1,23 @@ + +module DDC.Base.Panic + (panic) +where +import DDC.Base.Pretty + + +-- | Print an error message and exit the compiler, ungracefully. +-- +-- This function should be called when we end up in a state that is definately +-- due to a bug in the compiler. +-- +panic :: String -- ^ Package name, + -> String -- ^ Function name. + -> Doc -- ^ Error message that makes some suggestion of what + -- caused the error. + -> a + +panic pkg fun msg + = error $ renderIndent $ vcat + [ text "PANIC in" <+> text pkg <> text "." <> text fun + , indent 2 msg + , empty] diff --git a/DDC/Base/Parser.hs b/DDC/Base/Parser.hs --- a/DDC/Base/Parser.hs +++ b/DDC/Base/Parser.hs @@ -1,19 +1,22 @@ +{-# LANGUAGE TypeFamilies #-} -- | Parser utilities. module DDC.Base.Parser ( module Text.Parsec , Parser , ParserState (..) + , D.SourcePos (..) , runTokenParser - , pTokMaybe - , pTokAs - , pTok) + , pTokMaybe, pTokMaybeSP + , pTokAs, pTokAsSP + , pTok, pTokSP) where -import DDC.Base.Lexer import DDC.Base.Pretty +import DDC.Data.Token +import DDC.Data.SourcePos as D import Data.Functor.Identity -import Text.Parsec -import Text.Parsec as P +import Text.Parsec hiding (SourcePos) +import Text.Parsec as P import Text.Parsec.Error as P @@ -31,7 +34,7 @@ , stateFileName :: String } --- | Run a generic parser. +-- | Run a generic parser, making sure all input is consumed. runTokenParser :: Eq k => (k -> String) -- ^ Show a token. @@ -41,41 +44,88 @@ -> Either P.ParseError a runTokenParser tokenShow fileName parser - = P.runParser parser + = P.runParser eofParser ParseState { stateTokenShow = tokenShow , stateFileName = fileName } fileName + where + eofParser + = do r <- parser + -- We can't use primitive Text.Parsec.eof because it requires + -- @Show (Token k)@ + (do + c <- pTokMaybe Just + unexpected (tokenShow c)) <|> return r ------------------------------------------------------------------------------- -- | Accept the given token. -pTok :: Eq k => k -> Parser k () +pTok :: Eq k => k -> Parser k () pTok k = pTokMaybe $ \k' -> if k == k' then Just () else Nothing +-- | Accept the given token, returning its source position. +pTokSP :: Eq k => k -> Parser k D.SourcePos +pTokSP k + = do (_, sp) <- pTokMaybeSP + $ \k' -> if k == k' then Just () else Nothing + return sp + + -- | Accept a token and return the given value. pTokAs :: Eq k => k -> t -> Parser k t -pTokAs k t = pTok k >> return t +pTokAs k t + = do pTok k + return t +-- | Accept a token and return the given value, +-- along with the source position of the token. +pTokAsSP :: Eq k => k -> t -> Parser k (t, D.SourcePos) +pTokAsSP k t + = do sp <- pTokSP k + return (t, sp) + + -- | Accept a token if the function returns `Just`. -pTokMaybe :: (k -> Maybe a) -> Parser k a -pTokMaybe f +pTokMaybe :: (k -> Maybe a) -> Parser k a +pTokMaybe f = do state <- P.getState + P.token (stateTokenShow state . tokenTok) (takeParsecSourcePos) (f . tokenTok) +-- | Accept a token if the function return `Just`, +-- also returning the source position of that token. +pTokMaybeSP :: (k -> Maybe a) -> Parser k (a, D.SourcePos) +pTokMaybeSP f + = do state <- P.getState + + let f' token' + = case f (tokenTok token') of + Nothing -> Nothing + Just x -> Just (x, tokenSourcePos token') + + P.token (stateTokenShow state . tokenTok) + (takeParsecSourcePos) + f' + + ------------------------------------------------------------------------------- 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. -- @@ -7,6 +8,7 @@ ( module Text.PrettyPrint.Leijen , Pretty(..) , pprParen + , padL -- * Rendering , RenderMode (..) @@ -29,23 +31,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 + 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 + instance Pretty Char where - ppr = text . show + ppr = text . show instance Pretty a => Pretty [a] where ppr xs = encloseSep lbracket rbracket comma @@ -57,6 +72,15 @@ instance (Pretty a, Pretty b) => Pretty (a, b) where ppr (a, b) = parens $ ppr a <> comma <> ppr b + + +padL :: Int -> Doc -> Doc +padL n d + = let len = length $ renderPlain d + pad = n - len + in if pad > 0 + then d <> text (replicate pad ' ') + else d -- Rendering ------------------------------------------------------------------ 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,73 @@ + +-- | A simple exception monad. +module DDC.Control.Monad.Check + ( CheckM (..) + , throw + , runCheck + , evalCheck + , get + , put) +where +import Control.Monad + + +-- | Checker monad maintains some state and manages errors during type checking. +data CheckM s err a + = CheckM (s -> (s, Either err a)) + + +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 (\s -> (s, Right x)) + {-# INLINE return #-} + + (>>=) !(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 s err a +throw !e = CheckM $ \s -> (s, Left e) +{-# INLINE throw #-} + + +-- | 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/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,75 @@ + +-- | 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 + , takeMaximum + , index + , findDuplicates + , stripSuffix) +where +import Data.List +import qualified Data.Set as Set + + +-- | 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) + + +-- | 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) + + + +-- | Find 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 + + +-- | Drops the given suffix from a list. +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix suff xx + = case stripPrefix (reverse suff) (reverse xx) of + Nothing -> Nothing + Just xs -> Just $ reverse xs + 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,34 @@ +{-# LANGUAGE TypeFamilies #-} +module DDC.Data.SourcePos + (SourcePos (..)) +where +import DDC.Base.Pretty +import Control.DeepSeq + +-- | 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 NFData SourcePos where + rnf (SourcePos str l c) + = rnf str `seq` rnf l `seq` rnf c + + +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) + = text $ source + + ppr (SourcePos source l c) + = text $ 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/Version.hs b/DDC/Version.hs new file mode 100644 --- /dev/null +++ b/DDC/Version.hs @@ -0,0 +1,8 @@ + +module DDC.Version where + +splash :: String +splash = "The Disciplined Disciple Compiler, version " ++ version + +version :: String +version = "0.4.2" diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2012 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.2.1.2 +Version: 0.4.2.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -9,28 +9,42 @@ Stability: experimental 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: - base == 4.6.*, - transformers == 0.3.*, - containers == 0.5.*, - wl-pprint == 1.1.*, - parsec == 3.1.* - + base >= 4.8 && < 4.9, + deepseq >= 1.4 && < 1.5, + transformers >= 0.4 && < 0.5, + containers >= 0.5.6 && < 0.6, + wl-pprint >= 1.1 && < 1.3, + parsec >= 3.1 && < 3.2 + Exposed-modules: - DDC.Base.Lexer + DDC.Base.Env + DDC.Base.Name + DDC.Base.Panic DDC.Base.Parser DDC.Base.Pretty + + DDC.Control.Monad.Check + + DDC.Data.Canned + DDC.Data.ListUtils + DDC.Data.SourcePos + DDC.Data.Token + + DDC.Version GHC-options: -Wall -fno-warn-orphans + -fno-warn-type-defaults + -fno-warn-missing-methods Extensions: ParallelListComp @@ -38,3 +52,4 @@ RankNTypes FlexibleContexts KindSignatures + BangPatterns