hexpr (empty) → 0.0.0.0
raw patch · 14 files changed
+2160/−0 lines, 14 filesdep +basedep +data-refdep +eithersetup-changed
Dependencies added: base, data-ref, either, mtl, parsec, transformers
Files
- Control/Monad/Environment.hs +311/−0
- Control/Monad/Errors.hs +137/−0
- Control/Monad/Gensym.hs +97/−0
- Control/Monad/Stack.hs +74/−0
- Data/FiniteType.hs +106/−0
- Data/Hexpr.hs +263/−0
- Data/Hierarchy.hs +144/−0
- Data/Sexpr.hs +47/−0
- LICENSE +30/−0
- Language/Desugar.hs +118/−0
- Language/Distfix.hs +437/−0
- Language/Parse.hs +319/−0
- Setup.hs +2/−0
- hexpr.cabal +75/−0
+ Control/Monad/Environment.hs view
@@ -0,0 +1,311 @@+{-| We provide an implementation of environments, as well as a monad+ for performing computations in mutable environments. See 'Env' for+ the definition of environments that we are using here. See+ 'EnvironmentT' for details on what is available withing a mutable+ environment computation.+-}+module Control.Monad.Environment (+ EnvironmentT+ , Env+ , MEnv+ , Bindings+ , EnvironmentIO+ , EnvironmentST++ --, runEnvironmentT+ , evalEnvironmentT+ --, execEnvironmentT++ , extractLocal+ , extractParent+ , copyEnv+ , copyLocalEnv++ , find+ , bind+ , findIn+ , bindIn++ , getEnv+ , getFindEnv+ , getBindEnv+ , withEnv+ , emptyEnv+ , freshEnv+ , localEnv+ , letInEnv+ ) where++import qualified Data.Ref as Ref++import Data.Monoid+import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Reader+import Control.Monad.State++import Control.Monad.ST (ST)+import Control.Monad.Identity (Identity)++--TODO implement with something faster than an AList++------ Types ------+{-| Environments, also called contexts, are a set of bindings along with an optional parent+ environment.+ + When an environment is searched for a key, it first looks in its own bindings map, then looks+ in its parent's. When a binding is added to an environment, the environments own bindings are+ updated; its ancestors remain unchanged.+-}+data Env k v = Env (Bindings k v) (Maybe (Env k v))+--FIXME I actually can merge Maps, so I may as well do it that way instead of using parents++{-| Where 'Env' represents immutable (mathematical) environments, 'MEnv' represent mutable+ environments. Mutable environments can be useful for accumulating recursive bindings,+ or for interpreting languages with mutable binding environments.+ + The implementation of mutable cells (allocation, reading, writing) is abstracted by @m@. See+ @Data.Ref@ for more information.+-}+data MEnv m k v = MEnv (Ref.T m (Bindings k v)) (Maybe (MEnv m k v))+{-| Synonym for some key-value mapping. -}+type Bindings k v = [(k, v)]++{-| Perform computations involving the manipulation of @MEnv m k v@ terms.+ + Within the monad, we track not only the active (current) environment, but we also+ provide a default environment. The default environment is intended as a \"top-level\"+ environment that is available when using 'freshEnv'. For environments that do not reference+ the default environment, use 'emptyEnv'. +-}+newtype EnvironmentT k v m a = E { unEnvT :: StateT (MEnv m k v, MEnv m k v) (ReaderT (Bindings k v) m) a }++{-| Run the Environment monad with 'IORef's. -}+type EnvironmentIO k v = EnvironmentT k v IO+{-| Run the Environment monad with 'STRef's. -}+type EnvironmentST s k v = EnvironmentT k v (ST s)++type DefaultEnv k v = Bindings k v+type ActiveEnv k v = Bindings k v+newtype EnvState k v = EnvState { unState :: (DefaultEnv k v, ActiveEnv k v) }+++------ Top-Level ------++--TODO we can acheive limited restarts by: run part one, flatten & return the current env, do whatever, then initialize with it again++--runEnvironment :: [(k, v)] -> EnvironmentT k v m a -> m (a, EnvState k v)+--runEnvironment env action = error "STUB"++--evalEnvironment :: (Ref.C m) => Bindings k v -> EnvironmentT k v m a -> m a+--evalEnvironment bindings = runIdentity . evalEnvironmentT bindings++{-| Provided a bindings for a default environment, run an environment computation. -}+evalEnvironmentT :: (Ref.C m) => Bindings k v -> EnvironmentT k v m a -> m a+evalEnvironmentT xs (E action) = do+ env0 <- flip MEnv Nothing `liftM` Ref.new xs+ runReaderT (evalStateT action (env0, env0)) xs++--execEnvironment :: [(k, v)] -> EnvironmentT k v m a -> m (EnvState k v)+--execEnvironment env action = liftM snd (runEnvironment env action)++--resumeEnvironment :: (Monad m) => EnvState k v -> EnvironmentT k v m ()+--resumeEnvironment = error "STUB"+++------ Environment Manipulators ------+{-| Retrieve an @MEnv@ in every way equal to the one passed, except that the result has no parent.++ The cell in the new environment continues to reference the old, so changes in the state of one+ are mirrored in the other.+-}+extractLocal :: MEnv m k v -> MEnv m k v+extractLocal (MEnv cell _) = MEnv cell Nothing++{-| Retrieve the parent of the passed @MEnv@. -}+extractParent :: MEnv m k v -> Maybe (MEnv m k v)+extractParent (MEnv _ parent) = parent++{-| Make a deep copy of the passed environment.++ That is, both the @MEnv@'s own bindings cell is copied, the parent (if any) is copied, and a new+ environment is constructed of the two, which shares no state with the original with respect to+ @find@ and @bind@. Bound values are not copied, however, so state may still be shared insofar+ as the bound values have state.+-}+copyEnv :: (Ref.C m) => MEnv m k v -> EnvironmentT k v m (MEnv m k v)+copyEnv (MEnv cell parent) = do+ xs' <- liftHeap $ Ref.read cell+ parent' <- case parent of+ Nothing -> return Nothing+ Just parent -> Just <$> copyEnv parent+ newEnv xs' parent'++{-| Make a shallow copy of the passed environment++ That is, only the @MEnv@'s own bindings cell is copied; the parent (if any) is not copied.+ A new environment is constructed of the two, which shares only enough state with the original+ so that writes to the new do not affect the original, and only writes to the parents of the+ original are available (modulo shadowing) in the new. Bound values are not copied, however,+ so state may also be shared insofar as the bound values have state.+-}+copyLocalEnv :: (Ref.C m) => MEnv m k v -> EnvironmentT k v m (MEnv m k v)+copyLocalEnv (MEnv cell parent) = do+ xs' <- liftHeap $ Ref.read cell+ newEnv xs' parent++{-| Create an immutable environment from a snapshot of the passed mutable environment. -}+closeEnv :: (Ref.C m) => MEnv m k v -> EnvironmentT k v m (Env k v)+closeEnv (MEnv cell parent) = do+ xs <- liftHeap $ Ref.read cell+ parent' <- case parent of + Just p -> Just <$> closeEnv p+ Nothing -> return Nothing+ return $ Env xs parent'+ ++------ Binding and Lookup ------+{-| Lookup the value associated with the passed key in the current environment.+ See 'Env', 'getFindEnv'.+-}+find :: (Ref.C m, Eq k) => k -> EnvironmentT k v m (Maybe v)+find k = getFindEnv >>= \env -> findIn env k++{-| Bind the key to the value in the current environment.+ See 'Env', 'getFindEnv'.+-}+bind :: (Ref.C m) => k -> v -> EnvironmentT k v m ()+bind k v = getBindEnv >>= \env -> bindIn env k v+-- This is why I want something more like Murex: bind ≡ (bindIn _ k v) =<< getFindEnv++{-| Lookup the value associated with the passed key in the passed 'MEnv'.+ See 'Env' for more detail on the search semantics.++ We have @'findIn' e k v === 'withEnv' e ('find' k v)@, but the implementation+ of 'findIn' does less bookkeeping internally.+-}+findIn :: (Ref.C m, Eq k) => MEnv m k v -> k -> EnvironmentT k v m (Maybe v)+findIn env@(MEnv cell Nothing) k = findInLocally env k+findIn env@(MEnv cell (Just parent)) k = do+ result <- findInLocally env k+ case result of+ Just _ -> return result+ Nothing -> findIn parent k++{-| Bind a key to a value in the passed 'MEnv'. See 'Env' for more detail on the search semantics.++ We have @'bindIn' e k v === 'withEnv' e ('bind' k v)@, but the implementation of + 'findIn' does less bookkeeping internally.+-}+bindIn :: (Ref.C m) => MEnv m k v -> k -> v -> EnvironmentT k v m ()+bindIn (MEnv cell _) k v = liftHeap $ Ref.modify cell ((k, v):)++{-| Equivalent to @'findIn' . 'extractLocal'@, but it's more direct+ to define 'findIn' in terms of this. -}+findInLocally :: (Ref.C m, Eq k) => MEnv m k v -> k -> EnvironmentT k v m (Maybe v)+findInLocally (MEnv cell _) k = lookup k <$> liftHeap (Ref.read cell)+++------ Current Environment Manipulation ------+{-| Synonym for 'getFindEnv'. -}+getEnv :: (Ref.C m) => EnvironmentT k v m (MEnv m k v)+getEnv = getFindEnv++{-| Obtain a handle to the environment in which searches begin. -}+getFindEnv :: (Ref.C m) => EnvironmentT k v m (MEnv m k v)+getFindEnv = fst <$> liftActiveEnv get++{-| Obtain a handle to the environment in which searches begin. -}+getBindEnv :: (Ref.C m) => EnvironmentT k v m (MEnv m k v)+getBindEnv = snd <$> liftActiveEnv get++{-| Perform an action in the given environment. -}+withEnv :: (Ref.C m) => MEnv m k v -> EnvironmentT k v m a -> EnvironmentT k v m a+withEnv env' action = do+ env <- liftActiveEnv get+ liftActiveEnv (put (env', env')) >> action << liftActiveEnv (put env)++--TODO withFindEnv, withBindEnv++{-| Perform an action in a new, empty, parentless environment. -}+emptyEnv :: (Ref.C m) => EnvironmentT k v m a -> EnvironmentT k v m a+emptyEnv action = do+ env' <- newEnv [] Nothing+ withEnv env' action++{-| Perform an action in a new, default, parentless environment. -}+freshEnv :: (Ref.C m) => EnvironmentT k v m a -> EnvironmentT k v m a+freshEnv action = do+ bindings <- liftDefaultEnv ask+ env' <- newEnv bindings Nothing+ withEnv env' action++{-| Perform an action in a new, initially empty environment, child to the current. -}+localEnv :: (Ref.C m) => EnvironmentT k v m a -> EnvironmentT k v m a+localEnv action = do+ env' <- newEnv [] =<< liftM Just getFindEnv+ withEnv env' action++{-| Perform the first action in a 'localEnv', then perform the second with the+ binding environment the same as the original finding environment.+-}+letInEnv ::(Ref.C m) => EnvironmentT k v m a -> EnvironmentT k v m b -> EnvironmentT k v m b+letInEnv letAction inAction = do+ env0 <- liftActiveEnv get+ env <- getFindEnv+ env' <- newEnv [] (Just env)+ liftActiveEnv $ put (env', env')+ letAction+ liftActiveEnv $ put (env', env)+ res <- inAction+ liftActiveEnv $ put env0+ return res+++------ Helpers ------+infixl 1 <<+a << b = do { r <- a; b; return r }++newEnv :: (Ref.C m) => Bindings k v -> Maybe (MEnv m k v) -> EnvironmentT k v m (MEnv m k v)+newEnv xs parent = do+ env <- liftHeap $ Ref.new xs+ return $ MEnv env parent++liftActiveEnv :: (Ref.C m) => StateT (MEnv m k v, MEnv m k v) (ReaderT (Bindings k v) m) a -> EnvironmentT k v m a+liftActiveEnv = E+liftDefaultEnv :: (Ref.C m) => ReaderT (Bindings k v) m a -> EnvironmentT k v m a+liftDefaultEnv = E . lift+liftHeap :: (Ref.C m) => m a -> EnvironmentT k v m a+liftHeap = E . lift . lift+++------ Instances ------+instance Monoid (Env k v) where+ mempty = Env [] Nothing+ mappend env (Env xs Nothing) | null xs = env+ | otherwise = Env xs (Just env)+ mappend env (Env xs (Just parent)) | null xs = env `mappend` parent+ | otherwise = Env xs (Just $ env `mappend` parent)+--TODO monoid for MEnv+++instance (Ref.C m) => Functor (EnvironmentT k v m) where+ fmap = liftM++instance (Ref.C m) => Applicative (EnvironmentT k v m) where+ pure = return+ (<*>) = ap++instance (Ref.C m) => Monad (EnvironmentT k v m) where+ return = E . return+ x >>= k = E (unEnvT . k =<< unEnvT x)++instance MonadTrans (EnvironmentT k v) where+ lift = E . lift . lift++instance (MonadIO m, Ref.C m) => MonadIO (EnvironmentT k v m) where+ liftIO = lift . liftIO++---- TODO any stdlib monads+
+ Control/Monad/Errors.hs view
@@ -0,0 +1,137 @@+{-| In many error-checking algorithms, it is desireable to report several+ errors rather than simply terminate on detecting the first error.++ Where 'Either' and 'Error' terminates on the first error, 'Errors' can+ recover at specified points and continue error-checking. Even after a+ recovery, the prior errors are logged. If any errors occured during+ error-checking, this si an error in the whole computation.+-}+module Control.Monad.Errors (+ -- * Errors Monad+ Errors+ , runErrors+ -- * Error Reporting Functions+ , err+ , err1+ , choice+ , recover+ , recover_+ , mapRecover+ , unrecover+ -- ** Hoisting Functions+ , hoistMaybe+ , hoistEither+ , hoistEither1+ -- * Errors Transformer+ , ErrorsT+ , runErrorsT+ ) where++import Data.Monoid+import Data.Either+import Control.Applicative+import Control.Monad+import Control.Monad.Identity+import Control.Monad.Writer+import Control.Monad.Trans+import Control.Monad.Trans.Either hiding (hoistEither)+++{-| Shortcut for 'ErrorsT' over the 'Identity' monad. -}+type Errors e = ErrorsT e Identity+{-| Computations that can collect multiple errors. -}+newtype ErrorsT e m a = ErrorsT { unErrors :: m (Maybe e -> (Maybe a, Maybe e)) }++{-| Perform an error-reporting computation. -}+runErrors :: (Monoid e) => Errors e a -> Either e a+runErrors = runIdentity . runErrorsT++{-| Perform the error reporting part of a computation. -}+runErrorsT :: (Monad m, Monoid e) => ErrorsT e m a -> m (Either e a)+runErrorsT action = do+ innerAction <- unErrors action+ let res = innerAction Nothing+ return $ case res of+ (Just val, Nothing) -> Right val+ (_, Just errs) -> Left errs+ (Nothing, Nothing) -> error "Control.Monad.Errors: internal error"+++{-| Report an error. -}+err :: (Monad m, Monoid e) => e -> ErrorsT e m a+err msg = ErrorsT . return $ \e -> (Nothing, e <> Just msg)++{-| Report one error accumulating in a list. -}+err1 :: (Monad m) => e -> ErrorsT [e] m a+err1 = err . (:[])++{-| Try several alternatives (in order), but if none succeed, raise the passed error. -}+choice :: (Monad m, Monoid e) => e -> [ErrorsT e m a] -> ErrorsT e m a+choice e0 [] = err e0+choice e0 (a:as) = do+ res <- lift $ runErrorsT a+ case res of+ Left e0 -> choice e0 as+ Right val -> return val++{-| If the action returns an error, relpace the result with a default.+ The error is still logged and reported at the end of the computation. -}+recover :: (Monad m, Monoid e) => a -> ErrorsT e m a -> ErrorsT e m a+recover replacement action = ErrorsT $ do+ res <- runErrorsT action+ return $ case res of+ Left err -> \e -> (Just replacement, e <> Just err)+ Right val -> \e -> (Just val, e)++{-| As 'recover', but any successful result value does not matter. -}+recover_ :: (Monad m, Monoid e) => ErrorsT e m a -> ErrorsT e m ()+recover_ action = recover () (const () <$> action)++{-| Perform many error checks, recovering between each. The value at each index of the output+ list corresponds to the index of the input computation list. Error values are 'Nothing'+ in the output, successful values are wrapped in 'Just'. -}+mapRecover :: (Monad m, Monoid e) => [ErrorsT e m a] -> ErrorsT e m [Maybe a]+mapRecover actions = mapM (recover Nothing . (Just <$>)) actions++{-| If any errors have been detected, cuase them to be loud again. -}+unrecover :: (Monad m, Monoid e) => ErrorsT e m ()+unrecover = ErrorsT . return $ \e -> case e of+ Nothing -> (Just (), e)+ Just _ -> (Nothing, e)+++{-| Turn a 'Maybe' computation into an 'ErrorsT' computation. -}+hoistMaybe :: (Monad m, Monoid e) => e -> Maybe a -> ErrorsT e m a+hoistMaybe e = maybe (err e) return++{-| Turn an 'Either' computation into an 'ErrorsT' computation. -}+hoistEither :: (Monad m, Monoid e) => Either e a -> ErrorsT e m a+hoistEither = either err return++{-| Turn an 'Either' computation into an 'ErrorsT' computation when accumulating a list. -}+hoistEither1 :: (Monad m) => Either e a -> ErrorsT [e] m a+hoistEither1 = either err1 return+++instance (Monad m, Monoid e) => Functor (ErrorsT e m) where+ fmap = liftM++instance (Monad m, Monoid e) => Applicative (ErrorsT e m) where+ pure = return+ (<*>) = ap++instance (Monad m, Monoid e) => Monad (ErrorsT e m) where+ return x = ErrorsT . return $ \e -> (Just x, e)+ x >>= k = ErrorsT $ do+ eRes <- runErrorsT x+ case eRes of+ Left err -> return $ \e -> (Nothing, e <> Just err)+ Right val -> unErrors $ k val++instance (Monoid e) => MonadTrans (ErrorsT e) where+ lift x = ErrorsT $ do+ x' <- x+ return $ \e -> (Just x', e)++instance (MonadIO m, Monoid e) => MonadIO (ErrorsT e m) where+ liftIO = lift . liftIO
+ Control/Monad/Gensym.hs view
@@ -0,0 +1,97 @@+{-| Computations involving the generation of fresh symbols.+ + The notion of what is a symbol is abstracted by the 'Gensym' class.+ Then, we provide the 'SymbolGen' monad and 'SymbolGenT' monad transformer,+ in which symbols may be generated.++ Symbols are generated deterministically, but also without reference to any+ other sources of symbols, such as the programmer's algorithms, user input or+ other SymbolGen monads. Therefore, make sure the symbols you generate are+ trivially distinct from all other sources of symbols.+-}+module Control.Monad.Gensym (+ -- * Generate Symbols+ Gensym(..)+ , gensym+ -- * Symbol Generator Monad+ , SymbolGen+ , runSymbolGen+ -- * Symbol Generator Monad Transformer+ , SymbolGenT+ , runSymbolGenT+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Identity+import Control.Monad.State.Strict+import Control.Monad.Trans+import Control.Monad.Trans.Either+import Data.Ref (new, newLifted)+import qualified Data.Ref as Ref+++------ Concepts ------+{-| Class for types that can provide an infinite supply of distinct values. -}+class Gensym s where+ {-| The initial symbol generated. -}+ genzero :: s+ {-| Given the last symbol generated, generate the next.+ Must be distinct from all other symbols generated.+ -}+ nextsym :: s -> s+++{-| Monad transformer adding the capability of generating fresh symbols. -}+newtype SymbolGenT s m a = SymbolGenT { unSymbolGenT :: StateT s m a }++{-| Perform a computation involving generating fresh symbols. -}+runSymbolGenT :: (Gensym s, Monad m) => SymbolGenT s m a -> m a+runSymbolGenT = flip evalStateT genzero . unSymbolGenT++{-| Synonym for SymbolGenT over Identity. -}+type SymbolGen s = SymbolGenT s Identity++{-| Synonym for @'runIdentity' . 'runSymbolGenT'@. -}+runSymbolGen :: (Gensym s) => SymbolGen s a -> a+runSymbolGen = runIdentity . runSymbolGenT++{-| Generate a fresh symbol. Of course, this monad does not know+ what other sources of symbols there are, so make sure your 'Gensym'+ instance generates symbols distinct from all others. -}+gensym :: (Gensym s, Monad m) => SymbolGenT s m s+gensym = SymbolGenT $ do+ sym <- get+ modify nextsym+ return sym+++------- Basic Instances ------+instance Gensym Integer where+ genzero = 0+ nextsym = (+1)++instance (Monad m) => Functor (SymbolGenT s m) where+ fmap = liftM++instance (Monad m) => Applicative (SymbolGenT s m) where+ pure = return+ (<*>) = ap++instance (Monad m) => Monad (SymbolGenT s m) where+ return = SymbolGenT . return+ x >>= k = SymbolGenT $ unSymbolGenT x >>= unSymbolGenT . k++instance MonadTrans (SymbolGenT s) where+ lift = SymbolGenT . lift++instance (MonadIO m) => MonadIO (SymbolGenT s m) where+ liftIO = lift . liftIO++instance (Ref.C m) => Ref.C (SymbolGenT s m) where new = newLifted++------ Transformer Instances ------+instance (Ref.C m) => Ref.C (EitherT e m) where new = newLifted+ +--TODO instances for other stdlib & spinelib monads+
+ Control/Monad/Stack.hs view
@@ -0,0 +1,74 @@+module Control.Monad.Stack (+ Stack+ , runStack+ , StackT+ , runStackT+ , peek+ , pop+ , push+ , peeks+ , testTop+ ) where++import Data.Maybe+import Control.Applicative+import Control.Monad+import Control.Monad.Identity+import Control.Monad.State.Strict+import Control.Monad.Trans+++type Stack s = StackT s Identity++newtype StackT s m a = StackT { unStack :: StateT [s] m a }++runStack :: Stack s a -> a+runStack = runIdentity . runStackT++runStackT :: (Monad m) => StackT s m a -> m a+runStackT = flip evalStateT [] . unStack+++peek :: (Monad m) => StackT s m (Maybe s)+peek = StackT $ do+ stack <- get+ return $ case stack of+ [] -> Nothing+ (x:_) -> Just x+pop :: (Monad m) => StackT s m (Maybe s)+pop = StackT $ do+ stack <- get+ case stack of+ [] -> return Nothing+ (x:xs) -> put xs >> return (Just x)+push :: (Monad m) => s -> StackT s m ()+push x = StackT $ modify (x:) >> return ()+++peeks :: (Monad m) => (s -> a) -> StackT s m (Maybe a)+peeks f = (fmap . fmap) f peek++testTop :: (Monad m) => (s -> Bool) -> StackT s m Bool+testTop = (fromMaybe False <$>) . peeks++++instance (Monad m) => Functor (StackT s m) where+ fmap = liftM+instance (Monad m) => Applicative (StackT s m) where+ pure = return+ (<*>) = ap++instance (Monad m) => Monad (StackT s m) where+ return = StackT . return+ x >>= k = StackT $ unStack x >>= unStack . k++instance MonadTrans (StackT s) where+ lift = StackT . lift++instance (MonadIO m) => MonadIO (StackT s m) where+ liftIO = lift . liftIO++++
+ Data/FiniteType.hs view
@@ -0,0 +1,106 @@+{-| Finite types are well-known in theory. For those who aren't theorists, there are two kinds of+ finite type: finite products and finite sums (also called finite coproducts). ++ Finite products are a generalization of tuples and records. Where tuples are indexed by+ integer and records ar eindexed by name, finite products can use any index set. Finite sums+ are a generalization of discriminated unions (also called variants) so that, again, they are+ indexed by any set.++ Finite products and sums are useful generally for organizing data, but can be particularly+ useful where functinos are curried. A finite product using @Either Int String@ (or similar)+ as an index set, we can easily simulate a mix of positional and keyword arguments to such+ functions. With finite sums, we can specify the type of a function which can take one of+ multiple valid sets of arguments.+-}+module Data.FiniteType (+ Product+ , mkProduct+ , getProd+ , setProd+ , hasProd+ , Sum+ , mkSum+ , getSum+ , setSum+ , hasSum+ , SumTemplate+ , mkSumTemplate+ ) where++import Data.List+import Data.Maybe+import Control.Applicative+++------ Types ------+{-| Types where every field in the index set is filled with a value. -}+data Product i a = Product [(i, a)]++{-| Types where exactly one feild in the index set is filled with a value. -}+data Sum i a = Sum i a (SumTemplate i)++{-| Template from which a finite sum may be created.+ + Generally, you would define a @'Product' MyIxSet MyType@ in your language's statics,+ then transform this into a @'SumTemplate' MyIxSet@ template with 'mkSumTemplate', and use+ that template with 'mkSum' to create actual @'Sum' MyIxSet MyValue@ values in your+ interpreter.+-}+data SumTemplate i = SumTemplate [i]+++------ Creation ------+{-| Form a 'Product' with all fields filled from an association list.+ Error if the keys are not distinct.+-}+mkProduct :: (Eq i) => [(i, a)] -> Product i a+mkProduct xs = let ixSet = fst <$> xs+ in if ixSet == nub ixSet+ then Product xs+ else error "Finite Product: index set not distinct"++{-| Form a 'Sum' filling the passed index with the passed value. -}+mkSum :: (Eq i) => SumTemplate i -> i -> a -> Sum i a+mkSum t i v = Sum i v t++++{-| Create a 'SumTemplate' with index set identical to the input. -}+mkSumTemplate :: Product i a -> SumTemplate i+mkSumTemplate (Product xs) = SumTemplate (fst <$> xs)+-- don't have to check for distinct, because that's guaranteed by Product invariant+++------ Access ------+{-| Look up a field of a finite product. Error if the field does not exist. -}+getProd :: (Eq i) => Product i a -> i -> a+getProd (Product xs) i = fromJust $ i `lookup` xs++{-| Extract the value of the unique filled field in a finite sum. -}+getSum :: Sum i a -> a+getSum (Sum i a t) = a++{-| Check for existence of a field in a finite product. -}+hasProd :: (Eq i) => Product i a -> i -> Bool+hasProd (Product xs) i = i `elem` (fst <$> xs)++{-| Determine which field is filled in a finite sum. -}+hasSum :: Sum i a -> i+hasSum (Sum i x t) = i+++------ Modification ------+{-| Modify a field of a finite product. Error if the field does not exist. -}+setProd :: (Eq i) => Product i a -> i -> a -> Product i a+setProd (Product xs) i v = Product (go xs [])+ where+ go [] xs' = error "Finite Product: field not in index set"+ go (x:xs) xs' | i == fst x = reverse xs' ++ (i, v):xs+ | otherwise = go xs (x:xs')++{-| Modify a field of a finite sum. Error if the field does not exist. -}+setSum :: (Eq i) => Sum i a -> i -> a -> Sum i a+setSum (Sum _ _ t@(SumTemplate is)) i v = if i `elem` is+ then Sum i v t+ else error "Finite Sum: field not in index set"+
+ Data/Hexpr.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+--TODO some sort of Homoiconic class, which can is required for Functor so that fmap can delve into code objects+-- well, required for functor might be too strong, instead provide a some sort of hmap that can delve, but requires Functor and Homoiconic+{-| Hexprs are a data structure for representing and storing first-class code objects in a+ strongly-, statically-typed language.++ In an untyped language, first-class code may be represented by simple lists, which may then+ hold both atomic values as well as other lists. As code objects will need to be manipulated+ regularly, untyped lists (or @[∀a.a]@, if you prefer) are insufficient in a statically typed+ language. We therefore introduce 'Hexpr's, which is the type of the extended context-free+ grammar family @S ::= @/atom/@ | (SS@/+/@)@.++ By contrast, the grammar of s-exprs is @S ::= @/atom/@ | (SS@/*/@)@, which also has an+ associated type. However, s-exprs are less suitable for mathematical reasoning. Note that+ s-exprs distinguish between @a@ and @(a)@, which is entirely contrary to mathematical notation,+ wherein superfluous parenthesis may be dropped, and often should be for social reasons. While+ I'm at it, I may as well say the grammar of roses is @S ::= @/atom/@ | @/atom/@(S@/*/@)@.++ Because languages with first-class code benefit greatly from quasiquotation, we also introduce+ the 'Quasihexpr', which is isomorphic to 'Hexpr'. We give algorithms for encoding quasihexprs+ into hexprs, see 'UnQuasihexpr' and 'SimplifyHexpr' for more detail. The other direction is+ considered only useful in theoretical work.++ Because we are programming in Haskell, and not Idris, I have decided to leave some invariants+ out of the type system. The documentation of 'Hexpr' and 'Quasihexpr' give these invariants.+ It would make pattern matching too cumbersome to encode these invariants, and some would even+ need extensions. If I were to instead hide the unsafety, it would make pattern matching+ impossible. +-}+module Data.Hexpr (+ -- * Primary Data Structures+ Hexpr(..)+ , Quasihexpr(..)+ -- * Translation+ , unQuasihexpr+ , UnQuasihexpr(..)+ ) where++import Data.List+import Control.Applicative++import Data.Hierarchy+++------ Types ------+{-| Whereas a rose contains an element at every level of organization, elements of a hexpr appear+ only in the leaves of the structure. That is, internal nodes (branches) are only responsible+ for grouping consecutive elements and other groups.++ Hexprs further disallow trivial branches, where trivial means containing zero of one children.+ Where there are zero children in a branch, the branch contains no information. Where a branch+ contains only one node, no extra grouping information is provided. As branches are responsible+ for grouping, and grouping alone, it does not make sense to allow branches that contain no+ grouping structure.+ These restrictions on the number of children in a branch are not currently enforced by the+ type system, so several functions on hexprs are properly partial.++ To aid in production-quality language implementation, we also attach a position to each node.+ If position is unneeded, simply specialize to @()@.+-}+data Hexpr p a = Leaf p a+ | Branch p [Hexpr p a]++{-| A Quasihexpr extends 'Hexpr' with quasiquotation.+ + In addition to the usual restrictions on hexprs, each 'Unquote' and 'Splice' element must be+ contained within a matching 'Quasiquote' ancestor. Each Quasiquote can match with multiple+ (or zero) Unquote and Splice nodes, just so long as there is no other Quasiquote between.+ Again, this restriction is not enforced by the type system.+-}+data Quasihexpr p a = QLeaf p a+ | QBranch p [Quasihexpr p a]+ | Quote p (Quasihexpr p a)+ | Quasiquote p (Quasihexpr p a)+ | Unquote p (Quasihexpr p a)+ | Splice p (Quasihexpr p a)+++------ Hexpr Transforms ------+class UnQuasihexpr a where+ {-| A node that, when evaluated, creates a single hexpr node from at least one code values.++ For example, create the node @('nodeForm' \<e_1\> ... \<e_n\>)@ with @n >= 1@, such that+ then if each @e_i@ reduces to a code value @v_i@, then the whole node evaluates to+ @('quoteForm' (\<v_1\> ... \<v_n\>))@.+ -}+ mkNode :: p -> [Quasihexpr p a] -> Quasihexpr p a+ {-| A vararg function that turns a number of values into a list during evaluation. -}+ mkList :: p -> [Quasihexpr p a] -> Quasihexpr p a+ {-| A vararg function that concatenates lists of values into a single node where the lists are+ obtained by evaluating sibling nodes.++ For example, create the node @('concatForm' \<e_1\> ... \<e_n\>)@ with @n >= 1@, such that+ if each @e_i@ reduces to a list of code values @vs_i@, then the whole form evaluates to+ @('quoteForm' (\<vs_1\> ++ ... ++ \<vs_n\>))@. + -}+ mkConcat :: p -> [Quasihexpr p a] -> Quasihexpr p a++ isList :: Quasihexpr p a -> Bool+ fromList :: Quasihexpr p a -> [Quasihexpr p a]++ removeQuotation :: Quasihexpr p a -> Hexpr p a++{-| FIXME stale documentation++ Transform a quasihexpr into a hexpr. When the input consists only of 'QLeaf' and 'QBranch'+ nodes, the transformation is trivial. However, 'Quote', 'Quasiquote', 'Unquote' and 'Splice'+ need to be specially encoded.++ Of course, appropriate recursion is also needed, but for that, see the source code. It's+ interesting, but not helpful for understanding the results if you already understand+ quasiquotation.++ The naive algorithm would usually produce hexprs that are more complex than is necessary.+ This function factors quotation and quote manipulation to eliminate redundancy.++ Assuming that 'fromQuote' does not fail in the transformations, the particular transforms made+ are as follows. Appropriate recursive searches are made so that no opportunity to simplify is+ lost.++ * @('mkNode' c1 ... cn)@ ---> @('mkQuote' (s1 ... sn))@+ where @si = 'fromQuote' ci@++ * @('mkConcat' c1 ... cn)@ ---> @('mkQuote' cs)@ + where @cs = conjoins ('fromQuote' \<$\> [c1, ..., cn])@++ TODO: The following are unimplemented, but shouldn't matter too much.+ However, ideally the set of Hexprs returned from this function should be+ a proper subset of Hexprs (i.e. a normal form) that is isomorphic to Quasihexpr.+ Probably, once the isomorphism is proven, I'll merge this in with unQuasihexpr++ * @('nodeForm' x1 ... xm) ('quoteForm' xn)@ ---> @('nodeForm' x1 ... xm xn)@++ * @('quoteForm' x0) ('nodeForm' x1 ... xn)@ ---> @('nodeForm' x0 x1 ... xn)@ ++ * Any immediate siblings of nodeForm-lead branches are pushed into the nodeForm just so long as+ the parent is not a concatForm-lead branch.+-}+unQuasihexpr :: (UnQuasihexpr a) => Quasihexpr p a -> Hexpr p a+unQuasihexpr = simplify . removeQuotation . go+ where+ go (QLeaf p x) = QLeaf p x+ go (QBranch p xs) = QBranch p (go <$> xs)+ go (Quote p x) = Quote p (go x)+ go (Quasiquote q (QLeaf p x)) = Quote q (QLeaf p x)+ go (Quasiquote q (QBranch p xs)) = unquasiquoteBranch q p xs+ go (Quasiquote q (Quote p x)) = Quote q (Quote p (go x))+ go (Quasiquote q (Quasiquote p x)) = pushQuote q . pushQuote p $ x+ go (Quasiquote q (Unquote p x)) = go x+ go (Quasiquote q (Splice p x)) = go x+ go (Unquote p x) = error "malformed quasiquotation"+ go (Splice p x) = error "malformed quasiquotation"+ unquasiquoteBranch q p xs = case groupBy splitSplices xs of+ -- if xss is a singleton, it contains no splices+ [xs] -> mkNode p (pushQuote q <$> xs)+ xss -> mkConcat p (createSpliceList <$> xss)+ where+ splitSplices x y = case (x, y) of + (Splice _ _, _) -> False+ (_, Splice _ _) -> False+ _ -> True+ createSpliceList xs = case xs of+ [Splice _ x] -> go x+ _ -> mkList q (pushQuote q <$> xs)+ pushQuote p = go . Quasiquote p+ simplify = id --STUB+--simplifyHexpr :: SimplifyHexpr a => Hexpr p a -> Hexpr p a+--simplifyHexpr x = error "TODO"+ --case x of+ -- Leaf p x -> Leaf p x+ -- Branch p (x:[]) -> simplifyHexpr x+ -- Branch p (q:[x]) | q == Leaf quoteForm -> toCode' $ simplifyHexpr x+ -- Branch p (n:xs) | n == Leaf nodeForm ->+ -- let xs' = simplifyHexpr <$> xs+ -- in if isCode' `all` xs'+ -- then toCode' . simplifyHexpr . Branch p $ fromCode' <$> xs'+ -- else conjoin p n (Branch xs')+ -- Branch p (c:xs) | c == Leaf concatForm ->+ -- let xs' = simplifyHexpr <$> xs+ -- in if isCode' `all` xs'+ -- then toCode' $ conjoins (fromCode' <$> xs')+ -- else conjoin p c (Branch xs')+ -- Branch p xs -> Branch p (simplifyHexpr <$> xs)+ --where+ --isCode' (Leaf p x) = isCode x+ --isCode' _ = False+ --toCode' = Leaf . toCode+ --fromCode' (Leaf p x) = fromCode x++------ Instances ------+instance Eq a => Eq (Hexpr p a) where+ (Leaf _ x) == (Leaf _ y) = x == y+ (Branch _ xs) == (Branch _ ys) = xs == ys+ _ == _ = False+instance Eq a => Eq (Quasihexpr p a) where+ (QLeaf _ x) == (QLeaf _ y) = x == y+ (QBranch _ xs) == (QBranch _ ys) = xs == ys+ (Quote _ x) == (Quote _ y) = x == y+ (Quasiquote _ x) == (Quasiquote _ y) = x == y+ (Unquote _ x) == (Unquote _ y) = x == y+ (Splice _ x) == (Splice _ y) = x == y+ _ == _ = False++--TODO this won't work if there's internal structure in the Leaves+--perhaps if I use `toCode :: Hexpr a -> Hexpr a`, then we needn't worry about internal structure so much`+instance Functor (Hexpr p) where+ fmap f (Leaf p x) = Leaf p (f x)+ fmap f (Branch p xs) = Branch p $ (map . fmap) f xs++instance Functor (Quasihexpr p) where+ fmap f (QLeaf p x) = QLeaf p (f x)+ fmap f (QBranch p xs) = QBranch p $ (map . fmap) f xs+ fmap f (Quote p x) = Quote p (fmap f x)+ fmap f (Quasiquote p x) = Quasiquote p (fmap f x)+ fmap f (Unquote p x) = Unquote p (fmap f x)+ fmap f (Splice p x) = Splice p (fmap f x)++instance Hierarchy Hexpr p where+ getPos (Leaf p _) = p+ getPos (Branch p _) = p++ individual = Leaf+ + conjoin p (Branch _ as) (Branch _ bs) = Branch p $ as ++ bs+ conjoin p (Branch _ as) b = Branch p $ as ++ [b]+ conjoin p a (Branch _ bs) = Branch p $ [a] ++ bs+ conjoin p a b = Branch p $ [a] ++ [b]++ adjoinsl p x [] = x+ adjoinsl p x xs = Branch p (x:xs)++instance Hierarchy Quasihexpr p where+ getPos (QLeaf p _) = p+ getPos (QBranch p _) = p+ getPos (Quote p _) = p+ getPos (Quasiquote p _) = p+ getPos (Unquote p _) = p+ getPos (Splice p _) = p++ individual = QLeaf+ + conjoin p (QBranch _ as) (QBranch _ bs) = QBranch p $ as ++ bs+ conjoin p (QBranch _ as) b = QBranch p $ as ++ [b]+ conjoin p a (QBranch _ bs) = QBranch p $ [a] ++ bs+ conjoin p a b = QBranch p $ [a] ++ [b]++ adjoinsl p x [] = x+ adjoinsl p x xs = QBranch p (x:xs)++instance Openable (Hexpr p) where+ openAp (f, _) (Leaf p x) = Leaf p (f x)+ openAp (_, f) (Branch p xs) = adjoins p (f xs)++instance Openable (Quasihexpr p) where+ openAp (f, _) (QLeaf p x) = QLeaf p (f x)+ openAp (_, f) (QBranch p xs) = adjoins p (f xs)+ openAp fs (Quasiquote p x) = Quasiquote p (openAp fs x)+ openAp fs (Unquote p x) = Unquote p (openAp fs x)+ openAp fs (Splice p x) = Splice p (openAp fs x)++++
+ Data/Hierarchy.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-| The intuition behind a hierarchy is that individuals may form groups, and groups may form groups,+ but no group can have zero individuals under its umbrella.++ There are two main ways hierarchies can form (beyond just being an individual).++ * Two or more groups can merge together (conjoin), forming one group where there + were many before.++ * Two or more groups can join up underneath a new group, forming /n+1/ groups where + there were /n/ before.++ These are the intuitions behind the two relations that hierarchies support.++-}+module Data.Hierarchy (+ Hierarchy(..)+ , Openable(..)+ , OpenAp+ , adjoinPos, adjoinslPos, adjoinsrPos, adjoinsPos + , conjoinPos, conjoinslPos, conjoinsrPos, conjoinsPos + ) where++{-| A hierarchy is a set, together with an associative operation and a non-associative operation,+ as well as a duality law, which we'll get to after introducing the notation.++ Although we also provide for source positions, we will omit them for simplicity in this+ description.++ Ideally, I'd call the associative operation @++@ or @\<\>@, but the cool infix operators are+ spoken for already, so I'll have to go with descriptive names.+ Raising items into the hierarchy is done with 'individual'.+ We call the associative operation 'conjoin'+ and the non-associative @adjoins@.+ + In fact, there are two adjoins, 'adjoinsl' and 'adjoinsr'. Offering only these means we can+ satisfy the invariant that groups recursively have at least one individual. In the discussions+ below, assume that @adjoins@ is of type @[f a] -> [f a] -> f a@, and that when called, at least+ one of the arguments is non-empty.+ + The names literally mean \"join together\" and \"join to\", which succinctly convey the+ associativity properties of each. Well, \"join to\" might seem non-specific, but consider+ building a house in the wrong order as opposed to joining several cups of water in the wrong+ order. \"Ad-\" and \"con-\" have these meanings, even if the prepositions I've used as+ translation aren't so fine-grained.++ The duality law is:++ @+ a `conjoin` (b `adjoin` c) === (a `adjoin` b) `conjoin` c+ @++ The minimal implementation is 'individual', 'conjoin', and 'adjoinsl'.++ Some hierarchies may be commutative in conjoin and/or adjoin. For example, file systems+ (ignoring links) are hierarchies: adjoin creates new directories (though it is not+ the only way), and 'conjoin' adds files/directories into an existing directory, or creates a+ new two-element directory. Clearly, conjoin is commutative here. For generality, we have+ given default implemetations assuming non-commutativity in both operations.+-}+class Hierarchy h p where+ getPos :: h p a -> p++ individual :: p -> a -> h p a+ + adjoin :: p -> h p a -> h p a -> h p a+ adjoin pos a b = adjoinsl pos a [b]++ adjoinsl :: p -> h p a -> [h p a] -> h p a++ adjoinsr :: p -> [h p a] -> h p a -> h p a+ adjoinsr pos [] a = a+ adjoinsr pos (a:as) b = adjoinsl pos a (as++[b])+ + adjoins :: p -> [h p a] -> h p a+ adjoins pos [] = error "Cannot construct hierarchy of zero elements."+ adjoins pos (x:xs) = adjoinsl pos x xs+ + conjoin :: p -> h p a -> h p a -> h p a+ + conjoinsl :: p -> h p a -> [h p a] -> h p a+ conjoinsl pos acc [] = acc+ conjoinsl pos acc (x:xs) = conjoinsl pos (conjoin pos acc x) xs+ + conjoinsr :: p -> [h p a] -> h p a -> h p a+ conjoinsr pos [] base = base+ conjoinsr pos (x:xs) base = conjoin pos (conjoinsl pos x xs) base++ conjoins :: p -> [h p a] -> h p a+ conjoins pos [] = error "Cannot construct hierarchy of zero elements."+ conjoins pos (x:xs) = conjoinsl pos x xs+++adjoinPos :: (Hierarchy h p) => h p a -> h p a -> h p a+adjoinPos x y = adjoin (getPos x) x y+adjoinslPos :: (Hierarchy h p) => h p a -> [h p a] -> h p a+adjoinslPos x [] = x+adjoinslPos x ys = adjoinsl (getPos x) x ys+adjoinsrPos :: (Hierarchy h p) => [h p a] -> h p a -> h p a+adjoinsrPos [] x = x+adjoinsrPos xs y = adjoinsr (getPos $ head xs) xs y+adjoinsPos :: (Hierarchy h p) => [h p a] -> h p a+adjoinsPos [] = error "Cannot construct hierarchy of zero elements."+adjoinsPos (x:xs) = adjoinslPos x xs+conjoinPos :: (Hierarchy h p) => h p a -> h p a -> h p a+conjoinPos x y = conjoin (getPos x) x y+conjoinslPos :: (Hierarchy h p) => h p a -> [h p a] -> h p a+conjoinslPos acc [] = acc+conjoinslPos acc (x:xs) = (acc `conjoinPos` x) `conjoinslPos` xs+conjoinsrPos :: (Hierarchy h p) => [h p a] -> h p a -> h p a+conjoinsrPos [] base = base+conjoinsrPos (x:xs) base = (x `conjoinslPos` xs) `conjoinPos` base+conjoinsPos :: (Hierarchy h p) => [h p a] -> h p a+conjoinsPos [] = error "Cannot construct hierarchy of zero elements."+conjoinsPos (x:xs) = conjoinslPos x xs+++{-| It is often useful to look at the elements of a node in a 'Hierarchy', perform+ some transformation, then package the result back up as it was originally. Openable+ provides exactly the required functionality. This may be useful more generally as+ well, so we provide it as an independent class that can operate on structures that+ have leaves and/or branches.++ The minimal complete implementation is 'openAp'.+-}+class Openable f where+ {-| Open a node, perform either the leaf or branch transform and close it back up. + + This algorithm should not recursively traverse the structure. Thus, even if the+ structure consists only of leaves, 'openAp' is /not/ a fancy way to say 'fmap'.+ -}+ openAp :: OpenAp f a -> f a -> f a++ {-| Perform a preorder traversal version of 'openAp'. -}+ preorder :: OpenAp f a -> f a -> f a+ preorder f x = (id, fmap $ preorder f) `openAp` (f `openAp` x)++ {-| Perform a postorder traversal version of 'openAp'. -}+ postorder :: OpenAp f a -> f a -> f a+ postorder f x = f `openAp` ((id, fmap $ postorder f) `openAp` x)++{-| Package a transformations for leaves and branches together. -}+type OpenAp f a = (a -> a, [f a] -> [f a])+
+ Data/Sexpr.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+module Data.Sexpr (+ Sexpr(..)+ , SexprToHexpr(..)+ , sexprToHexpr+ ) where++import Data.Hierarchy+import Data.Hexpr+++data Sexpr p a = Atom p a | Sexpr p [Sexpr p a]++instance Hierarchy Sexpr p where+ getPos (Atom p _) = p+ getPos (Sexpr p _) = p++ individual = Atom++ conjoin p (Sexpr _ as) (Sexpr _ bs) = Sexpr p (as++bs)+ conjoin p a (Sexpr _ bs) = Sexpr p (a:bs)+ conjoin p (Sexpr _ as) b = Sexpr p (as++[b])+ conjoin p a b = Sexpr p [a, b]++ adjoinsl p x xs = Sexpr p (x:xs)++ adjoins = Sexpr++instance Openable (Sexpr p) where+ openAp (f, _) (Atom p x) = Atom p (f x)+ openAp (_, f) (Sexpr p xs) = Sexpr p (f xs)+++class SexprToHexpr a where+ xformNull :: p -> Hexpr p a+ xformNull = error "Empty sexprs are disallowed"+ xformSingleton :: Sexpr p a -> Hexpr p a++ xformDeepAtom :: a -> a+ xformDeepAtom = id++sexprToHexpr :: (SexprToHexpr a) => Sexpr p a -> Hexpr p a+sexprToHexpr (Atom p x) = Leaf p (xformDeepAtom x)+sexprToHexpr (Sexpr p []) = xformNull p+sexprToHexpr (Sexpr p [x]) = xformSingleton x+sexprToHexpr (Sexpr p xs) = Branch p (map sexprToHexpr xs)+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Zankoku Okuno++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Zankoku Okuno nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Language/Desugar.hs view
@@ -0,0 +1,118 @@+module Language.Desugar (+ -- * List Splitting+ tripBy+ , revTripBy+ , SplitFunction+ -- * Implicit Parenthesis+ , addParens+ , addShortParens+ -- * Simple Infixes+ , forwardInfix+ , reverseInfix+ ) where++import Data.List+import Data.Hierarchy+import Data.Hexpr+++{-| Transform a list based on the presence and location of an element.++ The first function of the pair is applied when no element was found.+ Its parameter is the original list.++ The second of the pair is applied with an element is found.+ Its parameters are (in order) the preceding elements, the found element, and the+ following elements.+-}+type SplitFunction a b = ([a] -> b, [a] -> a -> [a] -> b)++{-| Split a list at the first element that matched the predicate.+ If the element was not found, apply the 'SplitFunction'.+-}+tripBy :: (a -> Bool) -> SplitFunction a b -> [a] -> b+tripBy p (onNo, onYes) xs = case break p xs of+ (before, []) -> onNo xs+ (before, x:after) -> onYes before x after++{-| As 'tripBy', but search from the end.+-}+revTripBy :: (a -> Bool) -> SplitFunction a b -> [a] -> b+revTripBy p (onNo, onYes) xs = case revBreak p xs of+ (before, []) -> onNo xs+ (before, after) -> onYes (init before) (last before) (after)++revBreak p xs = let (rAfter, rBefore) = break p (reverse xs)+ in if null rBefore+ then (reverse rAfter, [])+ else (reverse rBefore, reverse rAfter)++{-| Create a group around a found subnode and all following nodes.+ If no node was found, then there is no change.++ E.g+@+ (a b lambda x y z) ===> (a b (lambda x y z))+@+-}+addParens :: (Openable (h p), Hierarchy h p) => (h p a -> Bool) -> OpenAp (h p) a+addParens p = (id, tripBy p (id, onYes))+ where+ onYes before x after = before ++ [x `adjoinslPos` after]++{-| Add parenthesis around a found subnode and at most one following node.+ Associates to the right.+ If no node was found, then there is no change.++ E.g.+@+ (++ ++ x) ===> (++(++(x)))+@+-}+addShortParens :: (Openable (h p), Hierarchy h p) => (h p a -> Bool) -> h p a -> h p a+addShortParens p = openAp (id, tripBy p (id, onYes))+ where+ onYes before x [] = before++[x]+ onYes before x after' = case span p after' of+ ([], []) -> [x]+ (cont, []) -> before++[deepen (last cont) (reverse (x:init cont))]+ (cont, next:after) -> before ++ [deepen next (reverse (x:cont))] ++ after+ where+ deepen acc [] = acc+ deepen acc (x:xs) = deepen (x `adjoinPos` acc) xs+++{-| Given an infix-detecting predicate, find the first matching subnode in the given node.+ Move the matching node to the front and wrap either side in new subnodes. If there is+ no matching subnode or either side is missing, the node is returned unchanged.++ E.g.+@+ (a b + c d + e f) ===> (+ (a b) (c d + e f))+@+-}+forwardInfix :: (Openable (h p), Hierarchy h p) => (h p a -> Bool) -> OpenAp (h p) a+forwardInfix p = (id, tripBy p (id, onYes))+ where+ onYes [] x after = x:after+ onYes before x [] = before++[x]+ onYes before x after = [x, adjoinsPos before, adjoinsPos after]++{-| Given an infix-detecting predicate, find the last matching subnode in the given node.+ Move the matching node to the front and wrap either side in new subnodes. If there is+ no matching subnode or either side is missing, the node is returned unchanged.++@+ (a b ** c d ** e f) ===> (** (a b ** c d) (e f))+@+-}+reverseInfix :: (Openable (h p), Hierarchy h p, Show (h p a)) => (h p a -> Bool) -> OpenAp (h p) a+reverseInfix p = (id, revTripBy p (id, onYes))+ where+ onYes [] x after = x:after+ onYes before x [] = before++[x]+ onYes before x after = [x, adjoinsPos before, adjoinsPos after]++++
+ Language/Distfix.hs view
@@ -0,0 +1,437 @@+{-| We present an algorithm for de-sugaring distributed affixes (/distfixes/) in a rose-like data+ structure. Distfixes are also known as /mixfixes/, but I chose /dist-/ because the parts of+ the affix are distributed in-order through the root, rather than mixed in (out-of-order+ connotation) with the root. Now then, let's actually describe a distfix in detail:+ + By /rose-like/ data structure, we mean any type @t@ such that when an element of @t@ can be+ 'unwrap'ped into a @[t]@, we can perform rewrites according to our distfix algorithm+ and 'rewrap' the result. If a particular element cannot be 'unwrap'ped, then it will be+ left alone during rewriting. Of course, this library was meant to operate on 'Hexprs' and+ 'Quasihexprs', but it could just as well work on a plain list or rose, as well as anything else+ you're willing to mangle into shape.++ A distributed affix consists of a number of alternating /keywords/ and /slots/. While keywords+ should match exactly one leaf node, slots can consume multiple nodes (leaves or branches)+ during a detection. If we denote slots by underscores and keywords by some reasonable+ programming language identifier (w/o underscores), then some representative distfix examples+ might be @_+_@, @_?_:_@, @_!@, @if_then_else_@, and @while_do_end@.++ Using the algorithm requires categorizing the input distfixes in several dimensions:+ /topology/, /associativity/, /priority/, and /precedence/. Only precedence need by specified by+ the user (it is extrinsic to any distfix), the rest are either specified in or calculated from+ the distfix at hand. We discuss these properties below:++ Slots in a distfix are always separated by keywords, but they may also be a leading and/or+ trailing keyword in a distfix. The presence or absence of certain keywords is the+ /topology/ of a distfix, and this affects the possibilities of its /associativity/.+ There are four options:+ + * /Closed/: preceded and followed by keywords (e.g. @begin_end@)+ + * /Half-open Left/: only followed by a keyword (e.g. @_!@)+ + * /Half-open Right/: only preceded by a keyword (e.g. @if_then_else_@)+ + * /Open/: neither preceded nor followed by a keyword (e.g. @_+_@)++ As usual, there are three /associativities/: /left-/, /right-/, and /non-associative/. Open+ distfixes can take any of these three. Closed distfixes have no associativity. Half-open left+ distfixes are always left associative, and half-open right are always right associative.++ Operators are divided into /precedence/ levels as normal, but there are no limits on the number+ of precedence levels available for use. In the distfix table, groups of distfixes of the same+ precedence are sorted in descending order.++ When given a list of expressions (the contents of an 'unwrap'ped node) and a distfix, the+ distfix may be /detected/ within the list. When multiple distfixes in a single precedence+ level are detected at once, an attempt is made to /select/ exactly one of the detected+ distfixes using a /priority scheme/ calculated from the properties of the distfixes in+ question. Provided that one distfix has a higher priority than all the other detected+ distfixes, the highest priority distfix binds least tightly (and is therefore selected first).++ The rules for calculating priority are these:+ + * If both distfixes have the same associativity (left- or right-, but not non-associative),+ the one with the \"most significant\" keyword \"earliest\" has priority:+ for left-associative, most significant means first and earliest means leftmost;+ for right-associative, most significant means last, earliest means rightmost.+ If its a still a tie, then the one with the most keywords has priority.++ * If both distfixes are closed, then they must be non-overlapping, or one must contain the+ other.+ It doesn't really matter which has higher priority if they don't overlap+ (as it happens, we've chosen leftmost for now).+ If one nests within the other, the outer has priority.+ If they overlap exactly, then the one with the most keywords has priority.+ + * Other pairs of matches have no priority distinction.++ Given that a particular distfix is detected and selected for rewriting, we rewrite the list of+ terms by /extracting/ the distfix from its slots. Specifically, we take the detected elements+ and run them through the distfix's /rewriter/ to produce some single element. We then place the+ rewritten element at the front of the node, followed by each (filled) slot in order and+ 'rewrap'ped in its own node. The re-written list is finally 'rewrap'ped and placed back in+ its original context.++ Detections are made recursively. The details are unimportant except that this algorithm is+ applied at every branch in the structure /as made available/ by 'unwrap' and the recursion+ respects precedence and priority. Each branch is assumed to have been enclosed by parenthesis+ during parsing, and therefore 'unwrap'ping resets the precedence level. Note that rewriting+ only adds branches to the structure, never removes them, and so we can see distfixes as+ adding implicit parenthesis, which can be quite valuable as a conservative tool for+ increasing the signal-to-noise ratio in a programming language.++ Now for some technical notes:++ I'm not sure how detection and priority will work if the same keyword appears twice in the same+ distfix, so it's probably best to avoid that for now. Or work it out and tell me, whatever.+ Either someone will eventually need this, at which point we'll deal with it, or maybe I'll get+ bored, or maybe I just won't care enough relative to other problems.++ The two-typeclass system might seem a bit strange, but this is so I can avoid making the user+ involve ghc's @FlexibleInstances@ extension. So, give an instance for+ @'DistfixElement' SomeType@ and @'DistfixElement' a => 'DistfixStructure' ('Hexpr' a)@, with+ 'nodeMatch' simply unwrapping 'Leaf' and delegating to 'match'.+-}+module Language.Distfix (+ -- * Data Structures+ Distfix(..)+ , Shape(..)+ , DistfixTable+ -- * Classes+ , DistfixStructure(..)+ , DistfixElement(..)+ -- * User Space+ , runDistfix+ , DistfixError(..)+ ) where++import Data.Ord+import Data.List+import Data.Maybe+import Data.Either+import Control.Applicative+import Control.Monad+++------ Types ------+{-| These data structures can be de-structured in a rose-like fashion. See the module description+ for detail on the meaning of \"rose-like\".++ There is one law:++ [Inverse] @maybe node (\(xs, rewrap) -> rewrap xs) (unwrap node) === node@++ In other words, if you can unwrap a node, then rewrapping will perform the inverse.+-}+class DistfixStructure f where+ {-| Unpack a branch node into a list of that branch's children+ and a rewrapping function. -}+ unwrap :: f -> Maybe ([f], [f] -> f)++ {-| Workaround so I can give an instance of Show (DistfixError a).+ -}+ defaultRewrap :: [f] -> f+ + {-| Whereas 'match' operates on elements of the structure, 'nodeMatch' is really just+ boilerplate that extracts an element and calls 'match' on it.++ For example, we might write+ +@+ instance 'DistfixDetect' a => 'DistfixStructure' ('Hexpr' a)+ nodeMatch ('Leaf' x) ('Leaf' y) = match x y+ nodeMatch _ _ = False+@++ Very probably, it would not make sense to allow a non-leaf node to match anything (by+ implication, disallowing non-leaf keywords).+ -}+ nodeMatch :: f -> f -> Bool+{-| This class is used for matching instead of 'Eq' so that certain components of the data might be+ ignored. For example, if @a = (SourcePos, b)@ then the @SourcePos@ should clearly be ignored+ during matching.+-}+class DistfixElement a where+ {-| Whether the two elements are equal with respect to matching a keyword. -}+ match :: a -> a -> Bool++{-| A distfix consists of+ 1) a rewriter, the results of which precede the slots when extracting,+ 2) a topology and associativity, which is actually merged into a single datatype 'Shape'+ because the choice of associativity is not independent of topology, and+ 3) a non-empty list of keywords, each implicitly separated by a slot.++ In case a distfix has a closed topology, its list of keywords must actually be at least two+ elements long (one for the open keyword, and one for the close keyword).++ For more detail on these components, see the module documentation.+-}+data Distfix a = Distfix ([a] -> a) Shape [a]+{-| Information on both topology and associativity.++ The two properties are merged into one datatype because choice of one limits choice of the+ other. The constructors should make the possibilities clear enough, but the module+ documentation might better present the reasoning involved.+-}+data Shape = Closed | HalfOpenRight | HalfOpenLeft | OpenRight | OpenLeft | OpenNon+ deriving (Eq, Show)++{-| A list, in descending order of precedence (ascending of binding tightness) of groups of+ Distfixes.++ How tightly distfixes within a group bind relative to one another is determined by priority+ (see the module description). Although ambiguous grammars are accepted, it might be best to+ avoid forcing the user to make lots of priority calculations just to determine if they need to+ insert disambiguating parenthesis.+-}+type DistfixTable a = [[Distfix a]]++newtype Detection a = Detection { unMatch :: (Distfix a, [a], [a], [[a]], [a]) }+data MatchResult a = NoMatch+ | OneMatch (Detection a)+ | Ambiguous [Detection a]+type DistfixResult a = DistfixResult' a a+-- I only threw @DistfixResult'@ in here so I can make a monad. @DistfixResult@ is the more important one+newtype DistfixResult' e a = Result { unResult :: Either (DistfixError e) a }++{-| Report reasons for error in recognizing distfixes. There are two causes of error: ++ [Ambiguity] When there is no single detection that has higher precedence or priority within a+ set of detections made in a node, this is an ambiguous parse. Note that ambiguous grammars are+ allowed in this scheme, but should this ambiguity manifest itself in an input, that input is+ not recognized. Really, this is pretty spiffy: distfixes admit specification fairly near to an+ arbitrary context-free grammar, but the algorithm will excise ambiguity only where it needs to,+ completely side-stepping the problem of whether a given grammar is ambiguous.++ [Leftovers] Once we've detected all the keywords possible in a node, we need to ensure there+ are no leftover keywords. If there were, this would probably indicate a user forgetting a+ keyword. For example, suppose @[|_|]@ were a distfix then @[| a ]@ would obtain a LeftoverErr.++ There's some fuzziness between 'AmbiguousErr' and 'LeftoverErr'. To illustrate, suppose we have+ @_<_@ and @_<=_@ but not @_<=_<_@ as a distfix, then both @a < b < c@ and @a <= b < c@ will be+ errors. The first will result in leftovers, and the second in ambiguity. It would make sense if+ they were both 'AmbiguousErr', but doing so under the current structure would sacrifice some+ efficiency (and possibly complicate matters). Still, at least everything that /should/ be an+ error /is/ an error.+-}+data DistfixError a = AmbiguousErr [(Distfix a, [a], [a], [[a]], [a])]+ | LeftoverErr [a]+++------ Instances ------+instance (Show a, DistfixStructure a) => Show (DistfixError a) where+ show (AmbiguousErr matches) = headText ++ concatMap makeLine matches+ where+ headText = "Ambiguous distfix parse. Could have been one of:"+ makeLine = ("\n\t"++) . show . right . extract (return . defaultRewrap) defaultRewrap . Detection+ right (Result (Right x)) = x+ show (LeftoverErr [k]) = "Leftover keyword: " ++ show k+ show (LeftoverErr ks) = "Leftover keywords:" ++ concatMap ((' ':) . show) ks+++------ Main Algorithm ------+{-| Given a table of distfixes and some input structure, apply the distfix detection/extraction+ algorithm.++ The algorithm may fail with a 'DistfixError'. The module description explains successful+ results in more detail.+-}+runDistfix :: DistfixStructure a => DistfixTable a -> a -> Either (DistfixError a) a+runDistfix table x = case unwrap x of+ Nothing -> return x+ Just (xs, rewrap) -> mapM (runDistfix table) xs >>= unResult . (impl rewrap table)+ where+ impl rewrap [] xs = findLeftovers rewrap allKeywords xs+ impl rewrap table'@(row:rows) xs = case select row xs of+ NoMatch -> impl rewrap rows xs+ OneMatch op -> extract (impl rewrap table') rewrap op+ Ambiguous ops -> Result . Left . AmbiguousErr $ fmap unMatch ops+ allKeywords = nubBy nodeMatch . (concatMap . concatMap) (\(Distfix _ _ ks) -> ks) $ table++{-| It's a pretty weird mutual-recursion thing going on between runDistfix.impl and extract. + See, we obviously have to recurse on the inner nodes, but then we also need to recurse on the+ reconstructed node, in case of nodes like `a + if p then conseq else alt`++ I'm basically passing in `recurse` as a specialized delimited continuation. There's another+ function that uses extract, so I couldn't just put extract in the closure with impl.+ I'm pretty sure it's necessary to pass the recursion in anyway (but I can't remember why).+-}+extract :: DistfixStructure a => ([a] -> DistfixResult a) -> ([a] -> a) -> Detection a -> DistfixResult a+extract recurse rewrap (Detection (Distfix rewrite _ _, found, before, inside, after)) = do+ inside' <- rewrap . (rewrite found:) <$> mapM recurse inside+ recurse $ before ++ [inside'] ++ after+++------ Selection ------+{-| Given a bunch of distfixes (at the same precedence level), try to find an unambiguous distfix+ parse within a list.+-}+select :: DistfixStructure a => [Distfix a] -> [a] -> MatchResult a+select ops xs = impl detectAll []+ where+ detectAll = catMaybes $ map (detect xs) ops+ impl [] eqSet = case eqSet of+ [] -> NoMatch+ [x] -> OneMatch x+ xs -> Ambiguous xs+ impl (x:xs) eqSet = if is Lower then impl xs eqSet+ else if is Higher then impl xs [x]+ else impl xs (x:eqSet)+ where is = (`elem` map (decidePriority x) eqSet)++{-| Given two detections, give the relative priority of the first to the second. -}+decidePriority :: Detection a -> Detection a -> Priority+decidePriority a@(Detection (Distfix _ topA ksA, _, bA, iA, aA)) b@(Detection (Distfix _ topB ksB, _, bB, iB, aB)) = case (topA, topB) of+ (OpenLeft, OpenLeft) -> decideLeft+ (OpenLeft, HalfOpenLeft) -> decideLeft+ (HalfOpenLeft, OpenLeft) -> decideLeft+ (HalfOpenLeft, HalfOpenLeft) -> decideLeft+ (OpenRight, OpenRight) -> decideRight+ (OpenRight, HalfOpenRight) -> decideRight+ (HalfOpenRight, OpenRight) -> decideRight+ (HalfOpenRight, HalfOpenRight) -> decideRight+ (Closed, Closed) -> decideClosed+ (Closed, _) -> Higher+ (_, Closed) -> Lower+ _ -> Same+ where+ decideRight = leftmost `joinPriority` mostKeywords+ where leftmost = fromOrd . negOrd $ comparing leftmostKeyword a b+ decideLeft = rightmost `joinPriority` mostKeywords+ where rightmost = fromOrd $ comparing rightmostKeyword a b+ decideClosed = leftmostNoOverlap `joinPriority` outermost `joinPriority` (if exactOverlap then mostKeywords else Same)+ where+ leftmostNoOverlap = if aR < bL then Higher else if bR < aL then Lower else Same+ outermost = case (compare aL bL, compare aR bR) of+ (LT, GT) -> Higher -- `a b b a`+ (GT, LT) -> Lower -- `b a a b`+ (LT, EQ) -> Higher -- `a b ab`+ (GT, EQ) -> Lower -- `b a ab`+ (EQ, LT) -> Lower -- `ab a b`+ (EQ, GT) -> Higher -- `ab b a`+ _ -> Same+ exactOverlap = aL == bL && aR == bR+ aL = leftmostKeyword a+ aR = rightmostKeyword a+ bL = leftmostKeyword b+ bR = rightmostKeyword b+ mostKeywords = fromOrd $ comparing impl a b+ where impl (Detection (Distfix _ _ ks, _, _, _, _)) = length ks+ -- index of leftmost keyword in the original node+ leftmostKeyword (Detection (Distfix _ OpenRight _, _, _, inside, _)) = length (head inside)+ leftmostKeyword (Detection (Distfix _ HalfOpenRight _, _, before, _, _)) = length before+ leftmostKeyword (Detection (Distfix _ Closed _, _, before, _, _)) = length before+ -- index of rightmost keyword in the original node+ rightmostKeyword (Detection (Distfix _ OpenLeft _, _, _, inside, _)) = sum (map length $ init inside) + (length (init inside) - 1)+ rightmostKeyword (Detection (Distfix _ HalfOpenLeft _, _, _, inside, _)) = sum (map length inside) + (length inside - 1)+ rightmostKeyword (Detection (Distfix _ Closed _, _, before, inside, _)) = length before + sum (map length inside) + length inside+++------ Detection ------+{-| Once all possible detections have been found in a node, use this to repack. -}+findLeftovers :: DistfixStructure a => ([a] -> a) -> [a] -> [a] -> DistfixResult a+findLeftovers rewrap ks xs = case filter (\x -> nodeMatch x `any` ks) xs of+ [] -> Result . Right . rewrap $ xs+ errs -> Result . Left $ LeftoverErr errs++{-| FIXME MAYBE This guy ignores the possibility of several matches of the same keyword, which may+ lead to weird error messages? Not sure, but if weird error messages don't haunt us, this is+ more efficient by a fair margin.+-}+detect :: DistfixStructure a => [a] -> Distfix a -> Maybe (Detection a)+detect xs fix@(Distfix _ topology ks) = do+ when (length ks == 0) $ error "distfixes must have at least one keyword"+ (found, before, inside, after) <- case topology of+ Closed -> do+ when (length ks < 2) $ error "closed distfixes must have at least two keywords"+ (as, kw1, ds) <- findKey (head ks) xs+ (cs, kw, bs) <- revFindKey (last ks) ds+ (kws, res) <- detectBody (init . tail $ ks) cs+ Just ([kw1]++kws++[kw], as, res, bs)+ HalfOpenRight -> do+ (as, kw1, bs) <- findKey (head ks) xs+ (kws, res) <- detectBody (tail ks) bs+ Just ([kw1]++kws, as, res, [])+ HalfOpenLeft -> do+ (as, kw, bs) <- revFindKey (last ks) xs+ (kws, res) <- revDetectBody (init ks) as+ Just (kws++[kw], [], res, bs)+ OpenRight -> do+ (as, kw1, bs) <- findKey (head ks) xs -- find the first one, so the following ones get wrapped in implicit parens+ (kws, res) <- detectBody (tail ks) bs+ Just ([kw1]++kws, [], as:res, [])+ OpenLeft -> do+ (as, kw, bs) <- revFindKey (last ks) xs -- find the last one, so the preceding ones get wrapped in implicit parens+ (kws, res) <- revDetectBody (init ks) as+ Just (kws++[kw], [], res++[bs], [])+ OpenNon -> do+ (as, kw1, bs) <- findKey (head ks) xs+ (kws, res) <- detectBody (tail ks) bs+ if isJust $ detect (last res) fix+ then Nothing+ else Just ([kw1]++kws, [], as:res, [])+ if null `any` inside+ then Nothing+ else Just $ Detection (fix, found, before, inside, after)++{-| recognize keyword-slot pairs left-to-right, so use as a continuation after stripping away leading/trailing keywords -}+detectBody :: DistfixStructure a => [a] -> [a] -> Maybe ([a], [[a]])+detectBody ks xs = impl ks xs [] []+ where+ impl [] xs kws xss = Just (reverse kws, reverse (xs:xss))+ impl (k:ks) xs kws xss = do+ (as, kw, bs) <- findKey k xs+ impl ks bs (kw:kws) (as:xss)+{-| as detect body, but right-to-left, for left-associative things -}+revDetectBody :: DistfixStructure a => [a] -> [a] -> Maybe ([a], [[a]])+revDetectBody ks xs = do+ (kws, xss) <- impl (reverse ks) (reverse xs) [] []+ return (kws, map reverse xss)+ where+ impl [] xs kws xss = Just (reverse kws, reverse (xs:xss))+ impl (k:ks) xs kws xss = do+ (bs, kw, as) <- findKey k xs+ impl ks bs (kw:kws) (as:xss)++{-| Get the parts of a list (before, after) the given keyword. Start from the left. -}+findKey :: DistfixStructure a => a -> [a] -> Maybe ([a], a, [a])+findKey kw xs = case nodeMatch kw `break` xs of+ res@(_, []) -> Nothing+ (before, (k:after)) -> Just (before, k, after)+{-| As findKey, but start from right. -}+revFindKey :: DistfixStructure a => a -> [a] -> Maybe ([a], a, [a])+revFindKey kw xs = do+ (b,k,a) <- findKey kw (reverse xs)+ return (reverse a, k, reverse b)+++------ Helpers ------+{-| if the first way of determining priority works, take it, otherwise try the second way -}+joinPriority :: Priority -> Priority -> Priority+joinPriority Same y = y+joinPriority x _ = x++data Priority = Higher | Lower | Same deriving (Eq)+fromOrd LT = Lower+fromOrd EQ = Same+fromOrd GT = Higher++negOrd :: Ordering -> Ordering+negOrd LT = GT+negOrd EQ = EQ+negOrd GT = LT++instance Functor (DistfixResult' e) where+ fmap = liftM++instance Applicative (DistfixResult' e) where+ pure = return+ (<*>) = ap++instance Monad (DistfixResult' e) where+ return = Result . Right+ (Result x) >>= k = Result (x >>= unResult . k)++instance (Show a) => Show (Distfix a) where+ show (Distfix _ shape x) = "Distfix " ++ show shape ++ " " ++ show x
+ Language/Parse.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE FlexibleContexts #-}+{-| Utility library that provides parsers for commonly-occuring programming+ constructs such as identifiers, numbers and characters.+-}+module Language.Parse (+ -- * Combinators+ -- ** Composable+ string+ , lookAhead+ , manyTill+ , manyThru+ , (<|>)+ , choice+ -- ** Extra+ , many2+ , between2+ , isEof+ , spaces1+ , charICase+ , stringICase+ -- * Identifiers+ , blacklistChar+ -- * Numbers+ -- ** Prepackaged Parsers+ , anyNumber+ -- ** Number Parts+ , signLiteral+ , baseLiteral+ , naturalLiteral+ , mantissaLiteral+ , exponentLiteral+ , denominatorLiteral+ , xDigit+ -- ** Convert Strings to Numbers+ , stringToInteger+ , stringToMantissa+ -- * Characters+ , literalChar+ , maybeLiteralChar+ ) where++import Control.Monad+import Control.Applicative ((<$>), (<*>), (*>), (<*))++import Data.Maybe+import Data.Ratio+import Data.Char+import Text.Parsec ( ParsecT+ , satisfy, char, oneOf, eof+ , try, (<?>), parserZero)+import qualified Text.Parsec as P++++--FIXME put this in Parsec.Combinators.Composable+------ Composable Combinators ------+{-| Parse a string, but don't consume input on failure. -}+string :: (Monad m, P.Stream s m Char) => String -> ParsecT s u m String+string = try . P.string++{-| Lookahead without consuming any input. -}+lookAhead :: (Monad m, P.Stream s m t) => ParsecT s u m a -> ParsecT s u m a+lookAhead = try . P.lookAhead++{-| Use @manyTill p e@ to apply parser @p@ many times, stopping as soon as+ @e@ is next to parse. Note that @e@ is not consumed.+-}+manyTill :: (Monad m, P.Stream s m t) => ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m [a]+manyTill p e = P.manyTill p (lookAhead e)++{-| Use @manyThru p e@ to apply parser @p@ many times, stopping as soon as+ @e@ is consumed. Unlike Parsec's @manyTill@, if @e@ fails, it does not+ consume input.+-}+manyThru :: (Monad m, P.Stream s m t) => ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m [a]+manyThru p e = P.manyTill p (try e)++{-| Use @a <|> b@ to parse @a@ or @b@. If @a@ fails, no input is consumed. -}+(<|>) :: (Monad m, P.Stream s m t) => ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a+a <|> b = try a P.<|> b++{-| Parse the first of the passed combinators that succeeds. If any+ parser fails, it does not consume input.+-}+choice :: (Monad m, P.Stream s m t) => [ParsecT s u m a] -> ParsecT s u m a+choice = P.choice . map try++--TODO sepBy &co+++------ Useful Combinators ------+{-| Use @many2 a b@ to parse an @a@ followed by zero or more @b@s. -}+many2 :: (Monad m, P.Stream s m t) => ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m [a]+many2 p ps = do+ car <- p+ cdr <- P.many ps+ return (car:cdr)++{-| Use @between2 a p@ to parse an @a@, then a @p@, then an @a@. Return the+ results of the @p@ parser.+-}+between2 :: (Monad m, P.Stream s m t) => ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m b+between2 e p = P.between e e p++{-| Detect end of file as a boolean. -}+isEof :: (Show t, Monad m, P.Stream s m t) => ParsecT s u m Bool+isEof = (eof >> return True) P.<|> return False+++{-| One or more spaces. -}+spaces1 :: (Monad m, P.Stream s m Char) => ParsecT s u m ()+spaces1 = void $ P.many1 P.space++{-| Parse one character, case-insensitive. -}+charICase :: (Monad m, P.Stream s m Char) => Char -> ParsecT s u m Char+charICase c = satisfy $ (== toLower c) . toLower++{-| Parse a string, case-insensitive. If this parser fails, it consumes no input. -}+stringICase :: (Monad m, P.Stream s m Char) => String -> ParsecT s u m String+stringICase str = try $ mapM charICase str+++------ Parsing Identifiers ------+{-| Parses a wide variety of characters, excepting those which meet+ the passed predicate. Specifically, we accept all of Unicode except:+ + * Space+ + * LineSeparator+ + * ParagraphSeparator+ + * Control+ + * Format+ + * Surrogate+ + * PrivateUse++ * NotAssigned+-}+blacklistChar :: (Monad m, P.Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char+blacklistChar p = satisfy $ \c -> not (p c) && case generalCategory c of+ Space -> False+ LineSeparator -> False+ ParagraphSeparator -> False+ Control -> False+ Format -> False+ Surrogate -> False+ PrivateUse -> False+ NotAssigned -> False+ _ -> True --Letter, Mark, Number, Punctuation/Quote, Symbol++--TODO maybe normal c-like identifiers, maybe identifiers that could be word-based vs. symbol-based+++------ Parsing Numbers ------+--TODO common combinations of the number part parsers+{-| Optional sign, then an integer number in scientific notation+ or ratio, in base 2, 8, 10 or 16. If in scientific notation,+ the exponent may be in base 10 or 16+-}+anyNumber :: (Monad m, P.Stream s m Char) => ParsecT s u m Rational+anyNumber = (<?> "number") $ try $ do+ sign <- P.option 1 signLiteral+ base <- baseLiteral+ whole <- naturalLiteral base+ n <- choice [ scientificNotation whole base+ , fractionNotation whole base+ , return (whole % 1)+ ]+ return $ fromIntegral sign * n+ where+ scientificNotation whole base = do+ mantissa <- mantissaLiteral base+ (expbase, exponent) <- P.option (1,0) (decimalExp <|> hexExp)+ return $ ((whole % 1) + mantissa) * (fromIntegral expbase ^^ exponent)+ fractionNotation whole base = (whole %) . denominator <$> denominatorLiteral base+ decimalExp = (,) 10 <$> exponentLiteral 10+ hexExp = (,) 16 <$> exponentLiteral 16 +++{-| Parse a minus or plus sign and return the appropriate multiplier. -}+signLiteral :: (Monad m, P.Stream s m Char) => ParsecT s u m Integer+signLiteral = (<?> "sign") $ (char '-' >> return (-1)) P.<|> (char '+' >> return 1)++{-| Parse \"0x\", \"0o\", or \"0b\" case-insensitive and return the appropriate base.+ If none of these parse, return base 10.+-}+baseLiteral :: (Monad m, P.Stream s m Char) => ParsecT s u m Int+baseLiteral = choice [ (stringICase "0x") >> return 16+ , (stringICase "0o") >> return 8+ , (stringICase "0b") >> return 2+ , return 10+ ]++{-| Parse many digits in the passed base and return the corresponding integer. -}+naturalLiteral :: (Monad m, P.Stream s m Char) => Int -> ParsecT s u m Integer+naturalLiteral base = (<?> "natural number") $ stringToInteger base <$> P.many1 (xDigit base)++{-| Parse a dot followed by many digits in the passed base and return+ the corresponding ratio.+-}+mantissaLiteral :: (Monad m, P.Stream s m Char) => Int -> ParsecT s u m Rational+mantissaLiteral base = (<?> "mantissa") $ do+ char '.'+ stringToMantissa base <$> P.many1 (xDigit base)++{-| In base 10, parse an 'e' and a decimal integer.+ In base 16, parse an 'h' and a hexadecimal integer.+-}+exponentLiteral :: (Monad m, P.Stream s m Char) => Int -> ParsecT s u m Integer+exponentLiteral base = (<?> "exponent") (go base)+ where+ body = (*) <$> P.option 1 signLiteral <*> naturalLiteral base+ go 10 = charICase 'e' >> body+ go 16 = charICase 'h' >> body+ go _ = error "unrecognized base in Language.Parser.exponentLiteral (accepts only 10 or 16)"++{-| Parse a '/' and a natural in the passed base. Return the+ reciprocal of that number.+-}+denominatorLiteral :: (Monad m, P.Stream s m Char) => Int -> ParsecT s u m Rational+denominatorLiteral base = (<?> "denominator") $ do+ denom <- char '/' >> naturalLiteral base+ if denom == 0 then parserZero else return (1%denom)+++{-| Parse a digit in the passed base: 2, 8, 10 or 16. -}+xDigit :: (Monad m, P.Stream s m Char) => Int -> ParsecT s u m Char+xDigit base = case base of+ 2 -> oneOf "01"+ 8 -> P.octDigit+ 10 -> P.digit+ 16 -> P.hexDigit+ _ -> error "unrecognized base in Language.Parser.xDigit (accepts only 2, 8, 10, or 16)"++{-| Interpret a string as an integer in the passed base. -}+stringToInteger :: Int -> String -> Integer+stringToInteger base = foldl impl 0+ where impl acc x = acc * fromIntegral base + (fromIntegral . digitToInt) x++{-| Interpret a string as a mantissa in the passed base. -}+stringToMantissa :: Int -> String -> Ratio Integer+stringToMantissa base = (/ (fromIntegral base%1)) . foldr impl (0 % 1)+ where impl x acc = acc / (fromIntegral base%1) + (((%1) . fromIntegral . digitToInt) x)+++------ Parsing Character Literals ------+{-| Parse a single character as if in a string literal. This should be applicable+ to both character and string literals.++ Here's the list of what characters are accepted:++ * Any single unicode character that is not an ASCII control character, backslash, or double-quote.++ * Line continuation: backslash, then advance over whitespace+ (including newlines and comments) through the next backslash.++ * Octal or hexadecimal ASCII escapes: a sequence in @\/\\\\(x[0-9a-fA-F]{2}|o[0-7]{3})\/@.++ * Unicode escapes: a sequence in @\/\\\\(u|U0[0-9a-fA-F]|U10)[0-9a-fA-F]{4}\/@.++ * Special escape: a sequence in @\/\\\\[0abefnrtv\'\"]\/@.+ For reference, the meanings of special escapes are:+ +@+\\0: nul (ASCII 0, 0x00)+\\a: bell (ASCII 7, 0x07)+\\b: backspace (ASCII 8, 0x08)+\\e: escape (ASCII 27, 0x1B)+\\f: form feed (ASCII 12, 0x0C)+\\n: line feed (ASCII 10, 0x0A)+\\r: carriage return (ASCII 13, 0x0D)+\\t: horizontal tab (ASCII 9, 0x09)+\\v: vertical tab (ASCII 11, 0x0B)+\\\': single quote (ASCII 39, 0x27)+\\\": double quote (ASCII 34, 0x22)+@+-}+literalChar :: (Monad m, P.Stream s m Char) => ParsecT s u m Char+literalChar = (satisfy isNormalChar <?> "printing character") P.<|> (escape <?> "escape sequence")+ where+ isNormalChar c = c >= ' ' && c `notElem` "\DEL\'\"\\" --FIXME limit this slightly more+ escape = char '\\' >> P.choice [specialEscape, numericalEscape]+ specialEscape = fromJust . flip lookup table <$> oneOf (map fst table)+ where table = [ ('0' , '\0')+ , ('a' , '\a')+ , ('b' , '\b')+ , ('e' , '\27')+ , ('f' , '\f')+ , ('n' , '\n')+ , ('r' , '\r')+ , ('t' , '\t')+ , ('\'', '\'')+ , ('\"', '\"')+ , ('\\', '\\')+ ]+ numericalEscape = chr . fromInteger <$> P.choice [ascii16, uni4, ascii8, uni6]+ ascii8 = stringToInteger 8 <$> (oneOf "oO" >> P.count 3 P.octDigit)+ ascii16 = stringToInteger 16 <$> (oneOf "xX" >> P.count 2 P.hexDigit)+ uni4 = stringToInteger 16 <$> (char 'u' >> P.count 4 P.hexDigit)+ uni6 = char 'U' >> (high P.<|> low)+ where+ low = stringToInteger 16 <$> (char '0' >> P.count 5 P.hexDigit)+ high = (+ 0x100000) . stringToInteger 16 <$> (string "10" >> P.count 4 P.hexDigit)++{-| Parse any character accepted by 'literalChar', but also accept two empty characters:+ + * @\\&@ The eplicit empty character.+ + * Backslash-whitespace-backslash.+-}+maybeLiteralChar :: (Monad m, P.Stream s m Char) => ParsecT s u m (Maybe Char)+maybeLiteralChar = (Just <$> literalChar) P.<|> (const Nothing <$> (string "\\&" P.<|> lineContinue)) + where+ lineContinue = between2 (char '\\') (P.many $ oneOf " \t\n\r") --FIXME more types of whitespace could be allowed+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hexpr.cabal view
@@ -0,0 +1,75 @@+-- Initial spine.cabal generated by cabal init. For further documentation,+-- see http://haskell.org/cabal/users-guide/++-- The name of the package.+name: hexpr++-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.0.0.0+++synopsis: A framework for symbolic, homoiconic languages.++description: H-expressions are a variant of S-expressions. Where s-expressions are atoms or nodes grouped into lists of length at least one, h-expressions, or hexprs, are grouped into lists of length two. This may seem very trivial, but this restriction makes it possible to treat parenthesis in the concrete syntax of hexprs merely as a manual override to the basic precedence rules, just as in mathematics. In particular, a suitable hexpr interpreter is capable of understanding eta-converted terms, which is quite unrealistic, if not impossible in an sexpr-based syntax. Thankfully, hexprs retain all the advantages of sexprs with respect to homoiconic syntax.+ + Hexprs on their own are fairly unhelpful, so we also have also included a configurable hexpr parser based on parsec. I wasn't long before mission creep set in, and a series of tools were produced to aid in creating a frontend for hexpr-based languages. See the package 'hexpr-examples' for some examples of the framework in action.++ I think H could stand for many things: the greek letter eta, hierarchical, happy, next in the alphabet after f, or perhaps hexpr == hexpr-expression. Where it comes from is unimportant, what is important is that we can easily the next generation of homoiconic languages.++-- URL for the project homepage or repository.+homepage: https://github.com/Zankoku-Okuno/hexpr/++-- The license under which the package is released.+license: BSD3++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Zankoku Okuno++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer: zankoku.okuno@gmail.com++-- A copyright notice.+-- copyright: ++category: Language++build-type: Simple++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.8+++library+ -- Modules exported by the library.+ exposed-modules: Data.Hierarchy,+ Data.Sexpr,+ Data.Hexpr,+ Language.Parse,+ Language.Desugar,+ Language.Distfix,+ Control.Monad.Stack,+ Control.Monad.Errors,+ Control.Monad.Gensym,+ Control.Monad.Environment,+ Data.FiniteType+ + -- Modules included in this library but not exported.+ -- other-modules: + + -- Other library packages from which modules are imported.+ build-depends: base ==4.6.*,+ transformers ==0.3.*,+ mtl ==2.1.*,+ either ==4.1.*,+ parsec ==3.1.*,+ data-ref+