diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dao.cabal b/dao.cabal new file mode 100644 --- /dev/null +++ b/dao.cabal @@ -0,0 +1,98 @@ +-- "dao.cabal" The metafile for building the Dao System using Cabal. +-- +-- Copyright (C) 2008-2012 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + + +Name: dao +Version: 0.1.0.1 +Cabal-Version: >= 1.10 +License: GPL-3 +Copyright: (C) 2008-2014 Ramin Honary, all rights reserved. +Author: Ramin Honary +Maintainer: ramin.honary@gmail.com +Build-Type: Simple +Synopsis: Dao is meta programming language with its own built-in + interpreted language, designed with artificial + intelligence applications in mind. +Description: + The Dao modules and interactive program is a meta programming language + intended for artificial intelligence uses. It is very much like the + classic UNIX "AWK" scripting language, but instead of using POSIX-style + regular epxressions, the patterns used in Dao are designed to more easily + match natural language input. +Library + HS-source-dirs: src + Default-Language: Haskell2010 + GHC-options: -threaded -Wall + -fno-warn-name-shadowing + -fno-warn-unused-do-bind + Build-Depends: + base == 4.*, mtl >= 2.0.1.0, random >= 1.0.0.1, + time >= 1.4.2 , directory >= 1.1.0.0, filepath >= 1.2.0.0, + process >= 1.0.1.2, array >= 0.3.0.2, bytestring >= 0.9.1.2, + utf8-string >= 0.3.2 , binary >= 0.5.0.2, Crypto >= 4.0.0.0, + transformers >= 0.2.2.0, containers >= 0.4.0.0, deepseq >= 1.0.0.0, + data-binary-ieee754 >= 0.4.4 + Default-Extensions: + TemplateHaskell ScopedTypeVariables RankNTypes + MultiParamTypeClasses FunctionalDependencies FlexibleInstances + FlexibleContexts DeriveFunctor DeriveDataTypeable + GeneralizedNewtypeDeriving + Exposed-Modules: + Dao.Interval, Dao.Tree , Dao.RefTable , Dao.Random , + Dao.StepList, Dao.Predicate, Dao.Binary , Dao.HashMap , + Dao.String , Dao.Stack , Dao.PPrint , Dao.Parser , + Dao.Token , Dao.Glob , Dao.Interpreter, Dao.Lib.File, + Dao.Lib.ListEditor, Dao.Lib.Array, + Dao.Interpreter.Tokenizer, Dao.Interpreter.AST, Dao.Interpreter.Parser + +Executable dao + HS-source-dirs: src + Main-is: dao-main.hs + Default-language: Haskell2010 + Build-Depends: + base >= 4.3.1.0, mtl >= 2.0.1.0, random >= 1.0.0.1, + time >= 1.4.2 , directory >= 1.1.0.0, filepath >= 1.2.0.0, + process >= 1.0.1.2, array >= 0.3.0.2, bytestring >= 0.9.1.2, + utf8-string >= 0.3.2 , binary >= 0.5.0.2, Crypto >= 4.0.0.0, + transformers >= 0.2.2.0, containers >= 0.4.0.0, deepseq >= 1.0.0.0, + data-binary-ieee754 >= 0.4.4 + Default-Extensions: + TemplateHaskell ScopedTypeVariables RankNTypes + MultiParamTypeClasses FunctionalDependencies FlexibleInstances + FlexibleContexts DeriveFunctor DeriveDataTypeable + GeneralizedNewtypeDeriving + +Test-suite main + HS-source-dirs: tests + Main-is: main.hs + Default-language: Haskell2010 + Type: exitcode-stdio-1.0 + Build-Depends: + base >= 4.3.1.0, mtl >= 2.0.1.0, random >= 1.0.0.1, + time >= 1.4.2 , directory >= 1.1.0.0, filepath >= 1.2.0.0, + process >= 1.0.1.2, array >= 0.3.0.2, bytestring >= 0.9.1.2, + utf8-string >= 0.3.2 , binary >= 0.5.0.2, Crypto >= 4.0.0.0, + transformers >= 0.2.2.0, containers >= 0.4.0.0, deepseq >= 1.0.0.0, + data-binary-ieee754 >= 0.4.4 + Extensions: + TemplateHaskell ScopedTypeVariables RankNTypes + MultiParamTypeClasses FunctionalDependencies FlexibleInstances + FlexibleContexts DeriveFunctor DeriveDataTypeable + GeneralizedNewtypeDeriving + diff --git a/src/Dao/Binary.hs b/src/Dao/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Binary.hs @@ -0,0 +1,640 @@ +-- "src/Dao/Binary.hs" declares the binary serializing monad. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module provides an essential wrapper around the 'Data.Binary.Binary' monad which allows a +-- binary serializer to read data type tags in the byte stream and select the next parser to be used +-- by looking up the parser with data type tag. +-- +-- Dao's binary protocol is compact and efficient, with every fundamental data type prefixed with a +-- single byte of information. Integers of arbitrary length are stored using Variable Length Integer +-- (VLI) encoding. However the byte stream is not compressed, and there are no functions in this +-- module which facilitate this, it is up to you to do compression. Using algorithms like GZip or +-- BZip2 will almost certainly decrese the size of the byte stream as Dao's binary protocol makes +-- no attempt to reduce data entropy. +-- +-- Arbitrary data types can be encoded as long as they instantiate 'Data.Typeable.Typeable' and +-- 'Dao.Interpreter.ObjectInterface' and have been made available to the 'Dao.Interpreter.Runtime' during +-- initialization of the Dao program. Each new type placed in the stream creates an integer tag in +-- an index with the 'Data.Typeable.TypeRep', and every item of the type that is placed after that +-- tag is prefixed with the integer index value. When decoding, the index of tags is constructed on +-- the fly as they are read from arbitrary points in the stream, and the index is used to select the +-- correct binary decoder from the 'Dao.Interpreter.ObjectInterface' stored in the 'Dao.Interpreter.Runtime'. +-- +-- Of course, this module is not a full re-writing of "Data.Binary", it relies heavily on the +-- "Data.Binary" module, and provides a Dao-friendly wrapper around it. +module Dao.Binary where + +import Dao.String +import qualified Dao.Tree as T +import Dao.Token +import Dao.Predicate + +import Control.Applicative +import Control.Monad +import Control.Monad.Error +import qualified Control.Monad.State as S + +import Data.Monoid +import Data.Dynamic +import Data.Char +import Data.Int +import Data.Ratio +import Data.Complex +import Data.Word +import Data.Bits +import Data.Time +import Data.Array.IArray +import qualified Data.Map as M +import qualified Data.IntMap as Im +import qualified Data.Set as S +import qualified Data.IntSet as Is +import qualified Data.ByteString.Lazy as Z + +import Data.Digest.SHA1 as SHA1 +import qualified Data.Binary.IEEE754 as B +import qualified Data.ByteString as B +import qualified Data.Binary as B +import qualified Data.Binary.Get as B +import qualified Data.Binary.Put as B + +---------------------------------------------------------------------------------------------------- + +type Byte = Word8 +type InStreamID = Word32 +type ByteOffset = B.ByteOffset + +-- | A data type used to help instantiate the 'Dao.Binary.Binary' class. Refer to the +-- 'fromDataBinary' function for more details. +data Serializer mtab a = Serializer{ serializeGet :: GGet mtab a, serializePut :: a -> GPutM mtab () } + +-- | Minimal complete definition is to either instantiate both 'get' and 'put', or to instnatiate +-- just 'serializer'. You can instantiate all three if you want but that may cause a lot of +-- confusion. Apart from 'serializer', it is identical to the 'Data.Binary.Binary' class, so please +-- refer to that module for more background information on how to use this one. +class Binary a mtab where + get :: GGet mtab a + get = serializeGet serializer + put :: a -> GPutM mtab () + put = serializePut serializer + serializer :: Serializer mtab a + serializer = Serializer{serializeGet=Dao.Binary.get,serializePut=Dao.Binary.put} + +class HasCoderTable mtab where + getEncoderForType :: Name -> mtab -> Maybe (Dynamic -> GPut mtab) + getDecoderForType :: Name -> mtab -> Maybe (GGet mtab Dynamic) + +-- | To evaluate a 'GPut' or 'GGet' function without providing any coder table, simply pass @()@. +instance HasCoderTable () where + getEncoderForType _ _ = Nothing + getDecoderForType _ _ = Nothing + +data EncodeIndex mtab + = EncodeIndex + { indexCounter :: InStreamID + , encodeIndex :: M.Map Name InStreamID + , encMTabRef :: mtab + } + +data DecodeIndex mtab + = DecodeIndex + { decodeIndex :: M.Map InStreamID Name + , decMTabRef :: mtab + } + +newtype GPutM mtab a = PutM{ encoderToStateT :: S.StateT (EncodeIndex mtab) B.PutM a } +type GPut mtab = GPutM mtab () + +data GGetErr = GetErr { gGetErrOffset :: ByteOffset, gGetErrMsg :: UStr } +instance Show GGetErr where { show (GetErr ofst msg) = "(offset="++show ofst++") "++uchars msg } + +newtype GGet mtab a = Get{ decoderToStateT :: PredicateT GGetErr (S.StateT (DecodeIndex mtab) B.Get) a } + +instance Functor (GPutM mtab) where { fmap f (PutM a) = PutM (fmap f a) } +instance Monad (GPutM mtab) where + return = PutM . return + (PutM a) >>= fn = PutM (a >>= encoderToStateT . fn) + fail = PutM . fail +instance Applicative (GPutM mtab) where { pure=return; (<*>)=ap; } +instance Monoid a => Monoid (GPutM mtab a) where + mempty=return mempty + mappend a b = a >>= \a -> b >>= \b -> return (mappend a b) +instance HasCoderTable mtab => S.MonadState (EncodeIndex mtab) (GPutM mtab) where + state fn = PutM (S.state fn) + +instance Functor (GGet mtab) where { fmap f (Get a) = Get (fmap f a) } +instance Monad (GGet mtab) where + return = Get . return + (Get a) >>= fn = Get (a >>= decoderToStateT . fn) + Get a >> Get b = Get (a >> b) + fail msg = bytesRead >>= \ofst -> Get (throwError (GetErr ofst (toUStr msg))) +instance MonadPlus (GGet mtab) where { mzero = Get mzero; mplus (Get a) (Get b) = Get (mplus a b); } +instance Applicative (GGet mtab) where { pure=return; (<*>)=ap; } +instance Alternative (GGet mtab) where { empty=mzero; (<|>)=mplus; } +instance Monoid a => Monoid (GGet mtab a) where + mempty=return mempty + mappend a b = a >>= \a -> b >>= \b -> return (mappend a b) +instance S.MonadState (DecodeIndex mtab) (GGet mtab) where + state = Get . lift . S.state +instance MonadError GGetErr (GGet mtab) where + throwError = Get . throwError + catchError (Get fn) catch = Get (catchError fn (decoderToStateT . catch)) + +-- | This class only exists to provide the the function 'getCoderTable' with the exact same function +-- in both the 'GPutM' and 'GGet' monads, rather than having a separate function for each monad. +class HasCoderTable mtab => ProvidesCoderTable m mtab where { getCoderTable :: m mtab } +instance HasCoderTable mtab => ProvidesCoderTable (GPutM mtab) mtab where { getCoderTable = S.gets encMTabRef } +instance HasCoderTable mtab => ProvidesCoderTable (GGet mtab) mtab where { getCoderTable = S.gets decMTabRef } + +data InStreamIndex = InStreamIndex{ inStreamIndexID :: InStreamID, inStreamIndexLabel :: Name } + deriving (Eq, Ord, Show) +instance HasCoderTable mtab => Binary InStreamIndex mtab where + put (InStreamIndex a b) = prefixByte 0x01 $ put a >> put b + get = tryWord8 0x01 $ pure InStreamIndex <*> get <*> get + +-- | Find the 'Dao.String.UStr' that was associated with this 'InStreamID' when the byte stream was +-- constructed when 'newInStreamID' was called. +decodeIndexLookup :: HasCoderTable mtab => InStreamID -> GGet mtab (Maybe Name) +decodeIndexLookup tid = M.lookup tid <$> S.gets decodeIndex + +-- | Given an 'Data.Int.Int64' length value, compute how many VLI bytes of hash code should be +-- necessary to for a byte stream of that length, and return an 'Data.Word.Word64' value trimmed to +-- that byte length. +trimIntegerHash :: Int64 -> Integer -> (Int, Integer) +trimIntegerHash i h = snd $ head $ dropWhile ((i<) . fst) $ + map (\x -> (2^(8+4*(fromIntegral x :: Int)), (x, h .&. (2^(7*x)-1)))) [0..14::Int] + +-- | A trimmed hash is an hash produced by SHA1 along with the length of the original data. However +-- it instantiates 'Prelude.Eq', and 'Binary' in such a way that only a maximum of 5 bytes of the +-- hash value are ever stored and used for verification. This is to conserve space in a byte stream +-- when writing smaller chunks of data. For example, it is not necessary to store all 20 bytes of +-- the hash code when the data you are storing or reading is itself 20 bytes long. +data TrimmedHash = TrimmedHash Int64 Integer deriving (Eq, Ord) +instance Binary TrimmedHash mtab where + put (TrimmedHash i h0) = + let (len, h) = trimIntegerHash i h0 + in if len>0 then putPosIntegral h else return () + get = TrimmedHash (error "TrimmedHash length not set") <$> getPosIntegral + +-- | Create a 'TrimmedHash' a list of bytes as the second parameter and the maximum length of the +-- list as the first parameter. +trimmedHash :: Z.ByteString -> TrimmedHash +trimmedHash blk = mkTrimmedHash blk where + len = Z.length blk + mkTrimmedHash = TrimmedHash len . snd . trimIntegerHash len . SHA1.toInteger . hash . + map snd . takeWhile ((>0) . fst) . zip (iterate (\x->x-1) len) . Z.unpack + +-- not for export +setTrimmedHashLength :: Int64 -> TrimmedHash -> TrimmedHash +setTrimmedHashLength i (TrimmedHash _ h) = TrimmedHash i h + +trimmedHashVerify :: Z.ByteString -> TrimmedHash -> Bool +trimmedHashVerify b = (trimmedHash b ==) + +-- | A lazy block stream that wraps up a 'Data.ByteString.Lazy.ByteString' in a data type that +-- instantiates 'Binary' in such a way that the bytes are written lazily in chunks of 1 megabyte +-- blocks with checksums, providing a protocol that can encode and decode arbitrarily large data +-- without interfearing with the protocol used by this module. +newtype BlockStream1M = BlockStream1M { block1MStreamToByteString :: Z.ByteString } +instance Binary BlockStream1M mtab where + put = + mapM_ (\ blk -> put blk >> put (trimmedHash blk) + ) . fix (\ loop blk -> + let (a,b) = Z.splitAt (2^(20::Int)) blk in a : if Z.null b then [] else loop b + ) . block1MStreamToByteString + get = (BlockStream1M . Z.concat) <$> loop [] where + loop bx = get >>= \b -> get >>= \cksum -> + if trimmedHashVerify b (setTrimmedHashLength (Z.length b) cksum) + then loop (bx++[b]) + else fail "bad checksum" + +-- | If the type signature in the given 'Dao.String.UStr' already has an associated type ID in the +-- encoder table, the existing ID is returned rather than creating a new one, and nothing changes. +-- If a new ID is created, the 'Dao.String.UStr' is paired with the new ID and written to the byte +-- stream. +newInStreamID :: HasCoderTable mtab => Name -> GPutM mtab InStreamID +newInStreamID typ = S.get >>= \st -> let idx = encodeIndex st in case M.lookup typ idx of + Nothing -> do + let nextID = indexCounter st + 1 + S.put $ st{indexCounter=nextID, encodeIndex=M.insert typ nextID idx} + put $ InStreamIndex{inStreamIndexID=nextID, inStreamIndexLabel=typ} + return nextID + Just tid -> return tid + +-- | When decoding a byte stream, it is up to you to check for the 'InStreamIndex'ies that are +-- scattered throughout. To do this, 'newInStreamID' is only called after a special escape byte +-- prefix is seen, for example, the byte prefix used when the 'Dao.Interpreter.OHaskell' constructor is +-- to be encoded. Once this prefix is decoded you should call 'newInStreamID'. That way, when you +-- are decoding the byte stream, you will know that 'updateTypes' must be called whenever you decode +-- the byte prefix for 'Dao.Interpreter.OHaskell'. +-- +-- This function simply checks if a 'InStreamIndex' exists at the current location in the byte +-- stream. If it does not exist, this function simply returns and does nothing. If it does exist, +-- the data is pulled out of the stream and the index is updated. +updateTypes :: HasCoderTable mtab => GGet mtab () +updateTypes = tryWord8 0x01 $ do + (InStreamIndex tid label) <- get + S.modify $ \st -> st{decodeIndex = M.insert tid label (decodeIndex st)} + +runPut :: HasCoderTable mtab => mtab -> GPut mtab -> Z.ByteString +runPut mtab fn = B.runPut $ S.evalStateT (encoderToStateT fn) $ + EncodeIndex{indexCounter=1, encodeIndex=mempty, encMTabRef=mtab} + +runGet :: HasCoderTable mtab => mtab -> GGet mtab a -> Z.ByteString -> Predicate GGetErr a +runGet mtab fn = B.runGet $ S.evalStateT (runPredicateT $ decoderToStateT fn) $ + DecodeIndex{decodeIndex=mempty, decMTabRef=mtab} + +encode :: (HasCoderTable mtab, Binary a mtab) => mtab -> a -> Z.ByteString +encode mtab = runPut mtab . put + +decode :: (HasCoderTable mtab, Binary a mtab) => mtab -> Z.ByteString -> Predicate GGetErr a +decode mtab = runGet mtab get + +encodeFile :: (HasCoderTable mtab, Binary a mtab) => mtab -> FilePath -> a -> IO () +encodeFile mtab path = Z.writeFile path . encode mtab + +decodeFile :: (HasCoderTable mtab, Binary a mtab) => mtab -> FilePath -> IO (Predicate GGetErr a) +decodeFile mtab path = decode mtab <$> Z.readFile path + +putWithBlockStream1M :: HasCoderTable mtab => GPut mtab -> GPut mtab +putWithBlockStream1M fn = getCoderTable >>= \mtab -> put $ BlockStream1M $ runPut mtab fn + +getWithBlockStream1M :: HasCoderTable mtab => GGet mtab a -> GGet mtab a +getWithBlockStream1M fn = do + mtab <- getCoderTable + (BlockStream1M bs1m) <- get + Get (predicate (runGet mtab fn bs1m)) + +---------------------------------------------------------------------------------------------------- + +class (Ix i, Binary i mtab, Binary a mtab) => HasPrefixTable a i mtab where { prefixTable :: PrefixTable mtab i a } + +-- | For data types with many constructors, especially enumerated types, it is effiecient if your +-- decoder performs a single look-ahead to retrieve an index, then use the index to lookup the next +-- parser in a table. This is a lookup table using 'Data.Array.IArray.Array' as the table which does +-- exactly that. +data PrefixTable mtab i a = PrefixTable String (Maybe (GGet mtab i)) (Maybe (Array i (GGet mtab a))) + +instance Ix i => Functor (PrefixTable mtab i) where + fmap f (PrefixTable msg getIdx t) = PrefixTable msg getIdx (fmap (amap (fmap f)) t) +instance (Integral i, Show i, Ix i, Binary a mtab) => Monoid (PrefixTable mtab i a) where + mempty = PrefixTable "" Nothing Nothing + mappend (PrefixTable msgA getIdxA a) (PrefixTable msgB getIdxB b) = + PrefixTable (msgA<>"<>"<>msgB) (msum [getIdxA >> getIdxB, getIdxB, getIdxA]) $ msum $ + [ a >>= \a -> b >>= \b -> do + let ((loA, hiA), (loB, hiB)) = (bounds a, bounds b) + let ( lo , hi ) = (min loA loB, max hiA hiB) + Just $ accumArray (flip mplus) mzero (lo, hi) (assocs a ++ assocs b) + , a, b + ] + +-- | For each 'GGet' function stored in the 'PrefixTable', bind it to the function provided here and +-- store the bound functions back into the table. It works similar to the 'Control.Monad.>>=' +-- function. +bindPrefixTable :: Ix i => PrefixTable mtab i a -> (a -> GGet mtab b) -> PrefixTable mtab i b +bindPrefixTable (PrefixTable msg getIdx arr) fn = PrefixTable msg getIdx (fmap (amap (>>=fn)) arr) + +-- | Construct a 'Serializer' from a list of serializers, and each list item will be prefixed with a +-- byte in the range given. It is necesary for the data type to instantiate 'Data.Typeable.Typeable' +-- in order to +mkPrefixTable + :: (Integral i, Show i, Ix i, Num i) + => String -> GGet mtab i -> i -> i -> [GGet mtab a] -> PrefixTable mtab i a +mkPrefixTable msg getIdx lo' hi' ser = + let len = fromIntegral (length ser) + lo = min lo' hi' + hi = max lo' hi' + idxs = takeWhile (<=hi) (iterate (+1) lo) + table = PrefixTable msg (Just getIdx) $ Just $ + accumArray (flip const) (fail ("in "++msg++" table")) (lo, hi) (zip idxs ser) + in if null ser + then PrefixTable msg (Just getIdx) Nothing + else + if 0 Byte -> Byte -> [GGet mtab a] -> PrefixTable mtab Byte a +mkPrefixTableWord8 msg = mkPrefixTable msg getWord8 + +runPrefixTable :: (Integral i, Show i, Ix i, Binary i mtab) => PrefixTable mtab i a -> GGet mtab a +runPrefixTable (PrefixTable _msg getIdx t) = flip (maybe mzero) t $ \decoderArray -> do + prefix <- lookAhead (maybe get id getIdx) + guard $ inRange (bounds decoderArray) prefix + prefix <- maybe get id getIdx + decoderArray!prefix + +word8PrefixTable :: HasPrefixTable a Byte mtab => GGet mtab a +word8PrefixTable = runPrefixTable (prefixTable :: HasPrefixTable a Byte mtab => PrefixTable mtab Byte a) + +prefixByte :: Byte -> GPut mtab -> GPut mtab +prefixByte w fn = putWord8 w >> fn + +-- | This is a polymorphic object that has been constructed using the instances of the canonical +-- 'Data.Binary.Binary'. This makes it possible to write your binary instances like so: +-- > import Data.Binary +-- > import Dao.Binary +-- > import MyObject -- exports data type MyObject which instantiates the canonical 'Data.Binary.Binary'. +-- > instance Dao.Binary.Binary MyObject where { serializer = fromDataBinary } +-- +-- I cannot just use GHC's @UndecidableInstances@ feature to declare all type which instantiate the +-- canonical 'Data.Binary.Binary' to also instantiate my own 'Dao.Binary.Binary' because +-- I need my own versions of 'Data.Binary.get' and 'Data.Binary.put' for certain types like +-- 'Data.Maybe' and list types. So unfortunately, we are stuck declaring a new instance for every +-- data type that needs serialization. +fromDataBinary :: B.Binary a => Serializer mtab a +fromDataBinary = + Serializer + { serializeGet = dataBinaryGet B.get + , serializePut = dataBinaryPut . B.put + } + +dataBinaryPut :: B.PutM a -> GPutM mtab a +dataBinaryPut = PutM . lift + +dataBinaryGet :: B.Get a -> GGet mtab a +dataBinaryGet = Get . lift . lift + +lookAhead :: GGet mtab a -> GGet mtab a +lookAhead (Get fn) = S.get >>= Get . lift . lift . B.lookAhead . S.evalStateT (runPredicateT fn) >>= Get . predicate + +bytesRead :: GGet mtab ByteOffset +bytesRead = Get $ lift $ lift B.bytesRead + +isEmpty :: GGet mtab Bool +isEmpty = dataBinaryGet B.isEmpty + +putWord8 :: Word8 -> GPut mtab +putWord8 = PutM . lift . B.putWord8 + +putWord16be :: Word16 -> GPut mtab +putWord16be = PutM . lift . B.putWord16be + +putWord16le :: Word16 -> GPut mtab +putWord16le = PutM . lift . B.putWord16le + +putWord32be :: Word32 -> GPut mtab +putWord32be = PutM . lift . B.putWord32be + +putWord32le :: Word32 -> GPut mtab +putWord32le = PutM . lift . B.putWord32le + +putWord64be :: Word64 -> GPut mtab +putWord64be = PutM . lift . B.putWord64be + +putWord64le :: Word64 -> GPut mtab +putWord64le = PutM . lift . B.putWord64le + +getWord8 :: GGet mtab Word8 +getWord8 = Get $ lift $ lift $ B.getWord8 + +getWord16be :: GGet mtab Word16 +getWord16be = Get $ lift $ lift $ B.getWord16be + +getWord16le :: GGet mtab Word16 +getWord16le = Get $ lift $ lift $ B.getWord16le + +getWord32be :: GGet mtab Word32 +getWord32be = Get $ lift $ lift $ B.getWord32be + +getWord32le :: GGet mtab Word32 +getWord32le = Get $ lift $ lift $ B.getWord32le + +getWord64be :: GGet mtab Word64 +getWord64be = Get $ lift $ lift $ B.getWord64be + +getWord64le :: GGet mtab Word64 +getWord64le = Get $ lift $ lift $ B.getWord64le + +putIntegral :: (Integral a, Bits a) => a -> GPut mtab +putIntegral = putInteger . fromIntegral + +getIntegral :: (Integral a, Bits a) => GGet mtab a +getIntegral = fromIntegral <$> getInteger + +putPosIntegral :: (Integral a, Bits a) => a -> GPut mtab +putPosIntegral = putPosInteger . fromIntegral + +getPosIntegral :: (Integral a, Bits a) => GGet mtab a +getPosIntegral = fromIntegral <$> getPosInteger + +putInteger :: Integer -> GPut mtab +putInteger = dataBinaryPut . vlPutInteger + +getInteger :: GGet mtab Integer +getInteger = fmap fromIntegral $ dataBinaryGet vlGetInteger + +putPosInteger :: Integer -> GPut mtab +putPosInteger = dataBinaryPut . vlPutPosInteger + +getPosInteger :: GGet mtab Integer +getPosInteger = dataBinaryGet vlGetPosInteger + +putByteString :: B.ByteString -> GPut mtab +putByteString = dataBinaryPut . B.putByteString + +getByteString :: Int -> GGet mtab B.ByteString +getByteString = dataBinaryGet . B.getByteString + +putLazyByteString :: Z.ByteString -> GPut mtab +putLazyByteString = dataBinaryPut . B.putLazyByteString + +getLazyByteString :: Int64 -> GGet mtab Z.ByteString +getLazyByteString = dataBinaryGet . B.getLazyByteString + +-- | Look ahead one byte, if the byte is the number you are expecting drop the byte and evaluate the +-- given 'GGet' function, otherwise backtrack. +tryWord8 :: Word8 -> GGet mtab a -> GGet mtab a +tryWord8 w fn = lookAhead getWord8 >>= guard . (w==) >> getWord8 >> fn + +instance Binary Int8 mtab where + put = putWord8 . fromIntegral + get = fmap fromIntegral getWord8 +instance Binary Int16 mtab where { put = putIntegral; get = Dao.Binary.getIntegral } +instance Binary Int32 mtab where { put = putIntegral; get = Dao.Binary.getIntegral } +instance Binary Int64 mtab where { put = putIntegral; get = Dao.Binary.getIntegral } +instance Binary Int mtab where { put = putIntegral; get = Dao.Binary.getIntegral } +instance Binary Word8 mtab where { put = putPosIntegral; get = Dao.Binary.getPosIntegral } +instance Binary Word16 mtab where { put = putPosIntegral; get = Dao.Binary.getPosIntegral } +instance Binary Word32 mtab where { put = putPosIntegral; get = Dao.Binary.getPosIntegral } +instance Binary Word64 mtab where { put = putPosIntegral; get = Dao.Binary.getPosIntegral } +instance Binary Word mtab where { put = putPosIntegral; get = Dao.Binary.getPosIntegral } +instance Binary Float mtab where + put = dataBinaryPut . B.putFloat32be + get = dataBinaryGet B.getFloat32be +instance Binary Double mtab where + put = dataBinaryPut . B.putFloat64be + get = dataBinaryGet B.getFloat64be +instance (RealFloat a, Binary a mtab) => Binary (Complex a) mtab where + put (a :+ b) = put a >> put b + get = pure (:+) <*> get <*> get + +instance (Num a, Bits a, Integral a, Binary a mtab) => Binary (Ratio a) mtab where + put o = putIntegral (numerator o) >> putPosIntegral (denominator o) + get = pure (%) <*> getIntegral <*> getPosIntegral + +instance Binary Integer mtab where { put = putInteger; get = getInteger; } +instance Binary Char mtab where { put = putPosIntegral . ord; get = chr <$> getPosIntegral; } + +instance Binary UTCTime mtab where + put t = do + put (toModifiedJulianDay (utctDay t)) + put (toRational (utctDayTime t)) + get = do + d <- fmap ModifiedJulianDay get + t <- fmap fromRational get + return (UTCTime{ utctDay=d, utctDayTime=t }) + +instance Binary NominalDiffTime mtab where + put t = put (toRational t) + get = fmap fromRational get + +instance Binary B.ByteString mtab where + put o = putPosIntegral (B.length o) >> Dao.Binary.putByteString o + get = getPosIntegral >>= Dao.Binary.getByteString + +instance Binary Z.ByteString mtab where + put o = putPosIntegral (Z.length o) >> Dao.Binary.putLazyByteString o + get = getPosIntegral >>= Dao.Binary.getLazyByteString + +instance (Binary a t, Binary b t) => Binary (a, b) t where + put (a, b) = put a >> put b + get = pure (,) <*> get <*> get +instance (Binary a t, Binary b t, Binary c t) => Binary (a, b, c) t where + put (a, b, c) = put a >> put b >> put c + get = pure (,,) <*> get <*> get <*> get +instance (Binary a t, Binary b t, Binary c t, Binary d t) => Binary (a, b, c, d) t where + put (a, b, c, d) = put a >> put b >> put c >> put d + get = pure (,,,) <*> get <*> get <*> get <*> get +instance (Binary a t, Binary b t, Binary c t, Binary d t, Binary e t) => Binary (a, b, c, d, e) t where + put (a, b, c, d, e) = put a >> put b >> put c >> put d >> put e + get = pure (,,,,) <*> get <*> get <*> get <*> get <*> get +instance (Binary a t, Binary b t, Binary c t, Binary d t, Binary e t, Binary f t) => Binary (a, b, c, d, e, f) t where + put (a, b, c, d, e, f) = put a >> put b >> put c >> put d >> put e >> put f + get = pure (,,,,,) <*> get <*> get <*> get <*> get <*> get <*> get +instance (Binary a t, Binary b t, Binary c t, Binary d t, Binary e t, Binary f t, Binary g t) => Binary (a, b, c, d, e, f, g) t where + put (a, b, c, d, e, f, g) = put a >> put b >> put c >> put d >> put e >> put f >> put g + get = pure (,,,,,,) <*> get <*> get <*> get <*> get <*> get <*> get <*> get +instance (Binary a t, Binary b t, Binary c t, Binary d t, Binary e t, Binary f t, Binary g t, Binary h t) => Binary (a, b, c, d, e, f, g, h) t where + put (a, b, c, d, e, f, g, h) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h + get = pure (,,,,,,,) <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get + +instance (Ord i, Binary i mtab, Binary a mtab) => Binary (M.Map i a) mtab where { put = put . M.assocs ; get = M.fromList <$> get; } +instance ( Binary a mtab) => Binary (Im.IntMap a) mtab where { put = put . Im.assocs; get = Im.fromList <$> get; } +instance (Ord a, Binary a mtab) => Binary (S.Set a) mtab where { put = put . S.elems ; get = S.fromList <$> get; } +instance Binary (Is.IntSet ) mtab where { put = put . Is.elems ; get = Is.fromList <$> get; } + +instance (Eq p, Ord p, Binary p mtab, Binary a mtab) => Binary (T.Tree p a) mtab where + put t = case t of + T.Void -> prefixByte 0x00 $ return () + T.Leaf a -> prefixByte 0x01 $ put a + T.Branch t -> prefixByte 0x02 $ put t + T.LeafBranch a t -> prefixByte 0x03 $ put a >> put t where + get = word8PrefixTable + +instance (Eq p, Ord p, Binary p mtab, Binary a mtab) => HasPrefixTable (T.Tree p a) Byte mtab where + prefixTable = mkPrefixTableWord8 "Tree" 0x00 0x03 $ + [ return T.Void + , T.Leaf <$> get + , T.Branch <$> get + , pure T.LeafBranch <*> get <*> get + ] + +instance Binary () mtab where { get = return (); put () = return (); } + +putNullTerm :: GPut mtab +putNullTerm = putWord8 0x00 + +getNullTerm :: GGet mtab () +getNullTerm = tryWord8 0x00 $ return () + +instance Binary Bool mtab where + put o = putWord8 (if o then 0x04 else 0x05) + get = word8PrefixTable +instance HasPrefixTable Bool Byte mtab where + prefixTable = mkPrefixTableWord8 "Bool" 0x04 0x05 [return False, return True] + +instance Binary a mtab => Binary (Maybe a) mtab where + put = maybe (putWord8 0x00) (\o -> putWord8 0x01 >> put o) + get = word8PrefixTable <|> fail "expecting Data.Maybe.Maybe" +instance Binary a mtab => HasPrefixTable (Maybe a) Byte mtab where + prefixTable = mkPrefixTableWord8 "Maybe" 0x00 0x01 [return Nothing, Just <$> get] + +instance Binary a mtab => Binary [a] mtab where + put o = mapM_ (put . Just) o >> putNullTerm + get = concatMap (maybe [] return) <$> loop [] where + loop ox = msum $ + [ getNullTerm >> return ox + -- It is important to check for the null terminator first, then try to parse, that way the + -- parser dose not backtrack (which may cause it to fail) if we are at a null terminator. + , optional get >>= maybe (fail "expecting list element") (loop . (ox++) . (:[])) + ] + +-- | Like 'putUnwrapped' but takes an arbitrary binary encoder for encoding individual list +-- parameters. +putUnwrappedWith :: (a -> GPut mtab) -> [a] -> GPut mtab +putUnwrappedWith put list = mapM_ put list >> putNullTerm + +-- | The inverse of 'getUnwrapped', this function is simply defined as: +-- > \list -> 'Control.Monad.mapM_' 'put' list >> 'putNullterm' +-- This is useful when you want to place a list of items, but you dont want to waste space on a +-- prefix byte for each list element. In lists of millions of elements, this can save you megabytes +-- of space, but placing any elements which are prefixed with a null byte will result in undefined +-- behavior when decoding. +putUnwrapped :: Binary a mtab => [a] -> GPut mtab +putUnwrapped = putUnwrappedWith put + +-- | Like 'getUnwrapped' but takes an arbitrary binary decoder for encoding individual list +-- parameters. +getUnwrappedWith :: GGet mtab a -> GGet mtab [a] +getUnwrappedWith get = fix (\loop ox -> (getNullTerm >> return ox) <|> (get >>= \o -> loop (ox++[o]))) [] + +-- | The inverse of 'putUnwrapped', this function is simply defined as: 'Control.Applicative.many' +-- 'get' >>= \list -> 'getNullTerm' >> 'Control.Monad.return' list This assumes that +-- every element placed by 'get' has a non-null prefixed encoding. If any elements in the list might +-- be encoded such that they start with a 0x00 byte, the @'Control.Applicative.many'@ 'get' +-- expression will parse the null terminator of the list as though it were an element and continue +-- looping which results in undefined behavior. Examples of elements that may start with null @0x00@ +-- bytes are 'Dao.String.UStr', 'Dao.String.Name', 'Prelude.Integer', or any 'Prelude.Integral' type. +getUnwrapped :: Binary a mtab => GGet mtab [a] +getUnwrapped = getUnwrappedWith get + +instance Binary UStr mtab where + put o = dataBinaryPut (B.put o) + get = dataBinaryGet B.get + +instance Binary Name mtab where + put o = dataBinaryPut (B.put o) + get = dataBinaryGet B.get + +instance Binary Location mtab where + put o = case o of + LocationUnknown -> return () + Location a b c d -> prefixByte 0x7F $ put a >> put b >> put c >> put d + get = msum $ + [ isEmpty >>= guard >> return LocationUnknown + , tryWord8 0x7F $ pure Location <*> get <*> get <*> get <*> get + , return LocationUnknown + ] + diff --git a/src/Dao/Glob.hs b/src/Dao/Glob.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Glob.hs @@ -0,0 +1,439 @@ +-- "src/Dao/Glob.hs" functions and data types related to the Glob +-- data type, for matching unix-like glob patterns to strings. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + + +{-# LANGUAGE DeriveDataTypeable #-} + +-- | The 'Glob' expression data type is constructed by parsing a string containing a 'Glob' +-- expression. Reminscent of old-fashioned POSIX glob expressions that you would use in UNIX or +-- Linux systems on the command line (@ls *.hs@). +-- +-- Also of use is the 'PatternTree' type. This 'Dao.Tree.Tree' data type allows you to associate +-- arbitrary object values with 'Glob' expressions. You can insert 'Glob' expressions into a +-- 'PatternTree' with 'insertMultiPattern' and then use 'matchTree' to match a string expression. +-- Every pattern that matches will return the object value associated with it along with a +-- @'Dao.Tree.Tree' 'Dao.String.Name'@ mapping which substrings matched which wildcards. +-- +-- The syntax for a glob expression is just an arbitrary string with @'$'@ characters indicating +-- variables. A @'$'@ must be followed by at least one alphabetic or underscore character, and then +-- zero or more alphanumeric characters or underschore characters. These characters may then be +-- followed by a @'?'@. For example: +-- > "some text $wildcard more text" +-- > "some text $wildcard* more text" +-- > "some text $anyone? more text" +-- The first and second forms are identical, you may choose to follow a wildcard with a @'*'@ if you +-- want the 'Wildcard' variable to be followed by text with no space or punctuation in between. +-- 'Wildcard's match arbitrary-length sequences of string constants. For example, the above 'Glob' +-- containing the variable called @wildcard@ will match the following strings: +-- > "some text more text" -> a variable called "wildcard" is assigned an empty list +-- > "some text a more text" -> a variable called "wildcard" is assigned the list [a] +-- > "some text a b more text" -> a variable called "wildcard" is assigned the list [a b] +-- > "some text a b c more text" -> a variable called "wildcard" is assigned the list [a b c] +-- An 'AnyOne' variable matches any string constant, but one and only one. The following strings +-- will match the above example: +-- > "some text then more text" -> a variable called "anyone" is assigned the list [then] +-- > "some text with more text" -> a variable called "anyone" is assigned the list [with] +-- But the above exaple will not match: +-- > "some text more text" +-- > "some text then with more text" +-- Variable matched are stored in @('Dao.Tree.Tree' 'Dao.String.Name')@ structures. +-- +-- Glob expressions are wrappers around lists of 'GlobUnit's. Each 'GlobUnit' is a 'Wildcard', +-- 'AnyOne' variable, or a string constant called a 'Single'. It is called 'Single' rather than +-- 'Control.Applicative.Const' to avoid conflicting with the data type defined in the +-- "Control.Applicative" module. +-- +-- The data type used to store 'Single' string constants is polymorphic. So you can construct a +-- 'Glob' containing 'Prelude.String's, 'Dao.String.UStr's, or anything that can be constructed from +-- a 'Prelude.String'. +-- +-- /NOTE:/ that when a 'Glob' is parsed using 'Prelude.read', the string constant is the substring +-- of all characters between the variables. If there are no variables, the whole string will be +-- stored into a list of just one 'Single' string constant. However this behavior may not be useful. +-- It may be useful to break down string constants into smaller 'Single' string constants. To do +-- this, use the 'parseOverSingles' function. +-- +-- The following is a simple program you can use from the command line in GHCi to observe how to +-- construct 'Glob' expressions and try matching strings to these 'Glob's to see the result. +-- > import System.IO.Unsafe +-- > import Data.IORef +-- > +-- > -- Establish a global variable for GHCi. +-- > testref :: IORef (PatternTree String String) +-- > testref = unsafePerformIO (newIORef T.Void) +-- > +-- > -- A function to break-up a string into clusters of spaces, numbers, or letters. +-- > breakstr :: String -> [String] +-- > breakstr cx = loop cx where +-- > check cx func = case cx of +-- > c:cx | func c -> Just $ span func (c:cx) +-- > _ -> Nothing +-- > loop cx = +-- > if null cx +-- > then [] +-- > else maybe ([head cx] : loop (tail cx)) (\ (cx, rem) -> cx : loop rem) $ +-- > foldl (\a -> mplus a . check cx) Nothing [isSpace, isAlpha, isDigit] +-- > +-- > -- Use 'Prelude.read' to parse a 'Glob' expression with 'Prelude.String's as the constant +-- values. Also, use 'parseOverSignles' to break-down the string constants using breakstr above. +-- > parsepat :: String -> Glob String +-- > parsepat = flip parseOverSingles breakstr . read +-- > +-- > newpat :: String -> String -> IO () +-- > newpat pat act = do +-- > let glob = parsepat pat +-- > modifyIORef testref (insertMultiPattern (flip const) [glob] act) +-- > putStrLn $ "added pattern: "++show glob +-- > +-- > delpat :: String -> IO () +-- > delpat str = modifyIORef testref (T.delete (getPatUnits $ parsepat str)) +-- > +-- > ls :: IO () +-- > ls = readIORef testref >>= putStrLn . disp "" where +-- > disp ind t = case t of +-- > T.Void -> "()" +-- > T.Leaf o -> show o +-- > T.Branch m -> dispMap ind m +-- > T.LeafBranch o m -> " = " ++ show o ++ " ..." ++ dispMap ind m +-- > dispMap ind m = (++(ind++"}")) $ ("{\n"++) $ +-- > if M.null m +-- > then "(empty map)" +-- > else unlines $ do +-- > (g, tree) <- M.assocs m +-- > ['\t':ind ++ unwords ['"':show g++"\"", "=", disp ('\t':ind) tree]] +-- > +-- > trypat :: String -> IO () +-- > trypat instr = do +-- > tree <- readIORef testref +-- > forM_ (matchTree True tree (breakstr instr)) $ \ (glob, vars, o) -> do +-- > putStrLn $ "pattern: "++show glob +-- > putStrLn $ "action: "++show o +-- > putStrLn $ ("vars assigned:\n"++) $ unlines $ flip map (T.assocs vars) $ \ (nm, o) -> unwords $ +-- > ['\t':show nm, "=", show (unwords o)] +module Dao.Glob where + +import Dao.String +import qualified Dao.Tree as T +import Dao.PPrint +import Dao.Random + +import Control.Applicative +import Control.Monad.Identity +import Control.DeepSeq + +import Data.Typeable +import Data.Monoid +import Data.List +import Data.Char +import qualified Data.Map as M + +---------------------------------------------------------------------------------------------------- + +-- | Tokenize a 'Prelude.String' grouping together whitespace, numbers, letters, and punctuation +-- makrs, except for brackets and quote markers which will all be tokenized as single character +-- strings. +simpleTokenize :: String -> [UStr] +simpleTokenize ax = map ustr (loop ax) where + loop ax = case ax of + [] -> [] + a:ax | elem a "([{}])\"'`" -> [a] : loop ax + a:ax -> case msum (map (check a ax) kinds) of + Nothing -> [a] : loop ax + Just (got, ax) -> got : loop ax + check a ax fn = if fn a then let (got, ax') = span fn ax in Just (a:got, ax') else Nothing + kinds = [isSpace, isAlpha, isNumber, isPunctuation, isAscii, not . isAscii] + +---------------------------------------------------------------------------------------------------- + +-- | A 'GlobUnit' is a single unit of a 'Glob' pattern, which is either a constant token value (a +-- 'Single'), a wildcard matching a single token (an 'AnyOne') or a 'Wildcard' matching zero or more +-- tokens. This is a very glob data type, remeniscent of the good old-fashioned Unix glob expression +-- but not restricted to single-character tokens. The unit token type need not be a string, but most the +-- instances of 'GlobUnit' into 'Prelude.Show' and 'Prelude.Read' are only defined for 'GlobUnit's +-- of 'Dao.String.UStr's. +data GlobUnit tok + = Wildcard Name (Maybe Name) + | AnyOne Name (Maybe Name) + | Single tok + deriving (Eq, Typeable) + +-- Order such that sorting will group 'Wildcards' first, 'AnyOne's second, and 'Single's third. +instance Ord tok => Ord (GlobUnit tok) where + compare a b = case a of + Wildcard a a1 -> case b of + Wildcard b b1 -> compare a b <> compare a1 b1 + _ -> LT + AnyOne a a1 -> case b of + Wildcard{} -> GT + AnyOne b b1 -> compare a b <> compare a1 b1 + Single{} -> LT + Single a -> case b of + Single b -> compare a b + _ -> GT + +instance Functor GlobUnit where + fmap f o = case o of + Single o -> Single (f o) + Wildcard n t -> Wildcard n t + AnyOne n t -> AnyOne n t + +isSingle :: GlobUnit o -> Bool +isSingle o = case o of { Single _ -> True; _ -> False } + +isVariable :: GlobUnit o -> Bool +isVariable = not . isSingle + +-- not for export -- strips the leadnig and trailing quote @'"'@ characters. +toStringWithoutQuotes :: String -> String +toStringWithoutQuotes cx = loop $ case cx of { '"':cx -> cx ; cx -> cx ; } where + loop cx = case cx of { '"':"" -> ""; "" -> ""; c:cx -> c : loop cx; } + +-- | Use this function to instantiate your version of 'GlobUnit' into the 'Prelude.Show' class. This +-- function assumes your data type is a string-like type where evaluating 'Prelude.show' on your +-- type produces a string of characters with a leading and trailing quote @'"'@ character. +showGlobUnitOfStrings :: (tok -> String) -> GlobUnit tok -> String +showGlobUnitOfStrings gshow tok = let printyp = maybe "" (\n -> "::"++uchars n) in case tok of + Wildcard nm t -> '$':uchars (toUStr nm)++printyp t + AnyOne nm t -> '$':uchars (toUStr nm)++printyp t++"?" + Single tok -> toStringWithoutQuotes (gshow tok) + +instance Show (GlobUnit UStr) where { show = showGlobUnitOfStrings uchars } +instance Show (GlobUnit String) where { show = showGlobUnitOfStrings id } + +-- | Use this function to instantiate your version of 'Glob' into the 'Prelude.Show' class. The +-- function you pass to convert the 'Single' type to a string is passed to 'showGlobUnitOfStrings'. +showGlobUnitList :: (tok -> String) -> [GlobUnit tok] -> String +showGlobUnitList gshow gx = show $ concatMap (showGlobUnitOfStrings gshow) gx + +instance Read (GlobUnit String) where + readsPrec _prec str = let init c = c=='_' || isAlpha c in case str of + '$':c:str | init c -> do + (cx, str) <- [span isAlphaNum str] + (typfunc, str) <- case str of + ':':':':str -> return $ head $ concat $ + [ case str of + c:str | init c -> do + (cx, str) <- [span isAlphaNum str] + [(Just $ ustr $ c:cx, str)] + _ -> [] + , [(Nothing, str)] + ] + str -> [(Nothing, str)] + case str of + '?':str -> [(AnyOne (ustr $ c:cx) typfunc, str)] + _ -> [(Wildcard (ustr $ c:cx) typfunc, str)] + '$':str -> [span (/='$') str] >>= \ (cx, str) -> [(Single ('$':cx), str)] + _ -> [] + +instance Read (GlobUnit UStr) where + readsPrec prec str = readsPrec prec str >>= \ (tok, str) -> return (fmap ustr tok, str) + +instance UStrType (GlobUnit UStr) where + maybeFromUStr str = case readsPrec 0 (uchars str) of { [(o, "")] -> Just o; _ -> Nothing; } + toUStr = ustr . show + +instance NFData o => NFData (GlobUnit o) where + rnf (Wildcard a b) = deepseq a $! deepseq b () + rnf (AnyOne a b) = deepseq a $! deepseq b () + rnf (Single a ) = deepseq a () + +instance HasRandGen o => HasRandGen (GlobUnit o) where + randO = countNode $ runRandChoice + randChoice = randChoiceList $ + [ Single <$> randO + , return Wildcard <*> randO <*> randO + , return AnyOne <*> randO <*> randO + ] + +---------------------------------------------------------------------------------------------------- + +-- | A 'Glob' is a kind of pattern that can be matched against tokens. A 'Glob' pattern contains a +-- list of 'GlobUnit's, and a 'GlobUnit' is either a constant (a 'Single') token, or variable (a +-- 'Wildcard' or 'AnyOne') that can be matched against a list constant tokens using 'matchPattern'. +-- When you have a large number of 'Glob' patterns and you would like to match any of them to a list +-- of tokens, merge the 'Glob' patterns together into a 'PatternTree' using the 'globTree' function, +-- and match them all at once using the 'matchTree' function. +data Glob tok = Glob { getPatUnits :: [GlobUnit tok], getGlobLength :: Int } + deriving (Eq, Ord, Typeable) + +makeGlob :: [GlobUnit tok] -> Glob tok +makeGlob ox = Glob{ getPatUnits=ox, getGlobLength=length ox } + +instance Functor Glob where + fmap f g = g{ getPatUnits = fmap (fmap f) (getPatUnits g) } + +instance Show (Glob UStr) where { show = showGlobUnitList uchars . getPatUnits } +instance Show (Glob String) where { show = showGlobUnitList id . getPatUnits } + +instance Read (Glob String) where + readsPrec prec str = if null str then return mempty else do + (units, str) <- loop [] str + return (Glob{ getPatUnits=units, getGlobLength=length units }, str) + where + loop units str = case break (=='$') str of + ("", "" ) -> return (units, "") + ("", str) -> readsPrec prec str >>= \ (unit, str) -> loop (units++[unit]) str + (cx, str) -> loop (units++[Single cx]) str + +instance Read (Glob UStr) where + readsPrec prec str = readsPrec prec str >>= \ (g, str) -> return (fmap ustr g, str) + +instance Monoid (Glob o) where + mempty = nullValue + mappend (Glob{ getPatUnits=a, getGlobLength=lenA }) (Glob{ getPatUnits=b, getGlobLength=lenB }) = + Glob{ getPatUnits=a++b, getGlobLength=lenA+lenB } + +instance NFData o => NFData (Glob o) where { rnf (Glob a b) = deepseq a $! deepseq b () } + +instance HasNullValue (Glob o) where + nullValue = Glob{ getPatUnits=[], getGlobLength=0 } + testNull (Glob{ getPatUnits=ax }) = null ax + +instance UStrType (Glob UStr) where + maybeFromUStr str = case readsPrec 0 (uchars str) of { [(o, "")] -> Just o; _ -> Nothing; } + toUStr = ustr . show + +instance PPrintable (Glob UStr) where { pPrint = pShow } + +instance HasRandGen o => HasRandGen (Glob o) where + randO = randList 1 6 >>= \o -> return $ Glob{ getPatUnits=o, getGlobLength=length o } + +---------------------------------------------------------------------------------------------------- + +-- | A pattern is a list of tokens/variables that can be compared to a token list using +-- 'matchPattern' or 'matchTree'. A 'PatternTree' contains many patterns which have been merged into +-- a tree structure, which can match N patterns of maximum length M to a token list of L tokens in +-- O(L*log(M*N)) time, making it a much more efficient data structure for matching against a large +-- database of patterns. Every 'Glob' pattern in the tree is mapped to result value called an +-- "action", which is the polymorphic type @act@. Every pattern in the tree that matches a list of +-- tokens produces an "action" and also contains a list of associations of which labeled wildcards +-- matched which substring of tokens. +type PatternTree tok act = T.Tree (GlobUnit tok) act + +-- | When a 'Glob' is constructed with a function of the 'Prelude.Read' class, the 'Single' items +-- produced are all contiguous characters in between 'Wildcard' and 'AnyOne' markers. For example +-- the string: +-- > read "$X will do $Y? too" :: 'Glob' 'Prelude.String' +-- will parse to a 'Glob' where the 'getPatUnits' is the following list of items: +-- > ['Wildcard' "X", 'Single' " will do ", 'AnyOne' "Y", 'Single' " too"] +-- Notice how the 'Single' items contain spaces. This may or may not be desirable. +-- +-- In the case that you would like to further parse the 'Single' strings, you can use the +-- 'parseOverSingles' function, breaking a 'Single' down into a list of 'Single's. +parseOverSinglesM :: Monad m => Glob tokA -> (tokA -> m [tokB]) -> m (Glob tokB) +parseOverSinglesM g convert = + forM (getPatUnits g) + (\u -> case u of + Single u -> convert u >>= mapM (return . Single) + AnyOne nm t -> return [AnyOne nm t] + Wildcard nm t -> return [Wildcard nm t] + ) >>= return . makeGlob . concat + +-- | Like 'parseOverSinglesM' but is a pure function. +parseOverSingles :: Glob tokA -> (tokA -> [tokB]) -> Glob tokB +parseOverSingles g = runIdentity . parseOverSinglesM g . (return.) + +-- | Insert an item at multiple points in the 'PatternTree' +insertMultiPattern :: (Eq tok, Ord tok) => (act -> act -> act) -> [Glob tok] -> act -> PatternTree tok act -> PatternTree tok act +insertMultiPattern plus pats act tree = + foldl (\tree pat -> T.update (getPatUnits pat) (maybe (Just act) (Just . flip plus act)) tree) tree pats + +-- | By converting an ordinary 'Glob' to a pattern tree, you are able to use all of the methods +-- in the "Dao.Tree" module to modify the patterns in it. +globTree :: (Eq tok, Ord tok) => Glob tok -> act -> PatternTree tok act +globTree pat a = T.insert (getPatUnits pat) a T.Void + +-- | Calls 'matchTree' with the 'PatternTree' stored within the given 'Glob' object, and returns +-- only the matching results. +matchPattern :: (Eq tok, Ord tok) => Bool -> Glob tok -> [tok] -> [M.Map Name (Maybe Name, [tok])] +matchPattern greedy pat tokx = matchTree greedy (globTree pat ()) tokx >>= \ (_, m, ()) -> [m] + +-- | Match a list of token items to a set of 'Glob' expressions that have been combined into a +-- single 'PatternTree', matching every possible pattern in the 'PatternTree' to the list of token +-- items in depth-first order. The first boolean parameter indicates whether 'Wildcard's should be +-- matched greedily (pass 'Prelude.False' for non-greedy matching). Be aware that greedy matching is +-- /not lazy/ which could cause freezes if you are working with infinitely recursive data types. +-- Non-greedy matching is lazy and works fine with everything. +-- +-- Each match is returned as a triple indicating 1. the 'Glob' that matched the token list, 2. the +-- token list items that were bound to the 'Dao.String.Name's in the 'Wildcard' and 'AnyOne' +-- 'GlobUnit's, and 3. the item associated with the 'Glob' expression that matched. +-- +-- The 'Data.Map.Map' objects returned map which variable names matched to pairs containing in the +-- 'Prelude.fst' slot the type of the token that the variable expects (the type is the part of the +-- pattern variable after the "::" symbol), and in the 'Prelude.snd' slot contains the tokens that +-- matched in that variable position. +matchTree + :: (Eq tok, Ord tok) + => Bool -> PatternTree tok act -> [tok] -> [(Glob tok, M.Map Name (Maybe Name, [tok]), act)] +matchTree greedy tree tokx = loop M.empty 0 [] tree tokx where + loop vars p path tree tokx = case tree of + T.Void -> [] + T.Leaf a -> guard (null tokx) >> done vars p path a + T.Branch b -> branch vars p path [] b tokx + T.LeafBranch a b -> branch vars p path [a] b tokx + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + partStep bind tokx = (if greedy then reverse else id) $ (bind, tokx) : + fix (\loop bind tokx -> if null tokx then [] else do + bind <- [bind++[head tokx]] + tokx <- [tail tokx] + ((bind, tokx) : loop bind tokx) + ) bind tokx + -- partStep takes a list of tokens, like [a,b,c] and returns a list for every possible + -- 2-way partition: [([],[a,b,c]), ([a],[b,c]), ([a,b],[c]), ([a,b,c],[])] + -- This forms a list of (bind, tokx) pairs where 'bind' will be assigned to a variable and 'tokx' + -- is the remaining tokens to be matched. So when a 'Wildcard' variable is matched, it tries every + -- possible ('bind', 'tokx') pair, binding the 'bind' to a variable and looping on 'tokx'. + done vars p path a = [(Glob{ getPatUnits=path, getGlobLength=p }, vars, a)] + branch vars p path a b tokx = case tokx of + [] -> msum $ + [a >>= \a -> done vars p path a + ,do (pat, tree) <- M.assocs b + a <- case tree of + T.Void -> [] + T.Branch _ -> [] + T.Leaf a -> [a] + T.LeafBranch a _ -> [a] + case pat of + Wildcard nm t -> case M.lookup nm vars of + Nothing -> done (M.insert nm (t, []) vars) p path a + Just (_, pfx) -> guard (null pfx) >> done vars p path a + AnyOne{} -> [] + Single{} -> [] + ] + tok:tokx -> let next pat vars tree = loop vars (p+1) (path++[pat]) tree in msum $ + [do tree <- maybe [] (:[]) $ M.lookup (Single tok) b + next (Single tok) vars tree tokx + ,do -- Next we use 'takeWhile' because of how the 'Ord' instance of 'GlobUnit' is defined, + -- 'Wildcard's and 'AnyOne's are always first in the list of 'assocs'. + (pat, tree) <- takeWhile (isVariable . fst) (M.assocs b) + let defVar nm t mkAssoc = case M.lookup nm vars of + Just (_, pfx) -> maybe [] (:[]) (stripPrefix pfx (tok:tokx)) >>= next pat vars tree + Nothing -> do + (bind, tokx) <- mkAssoc + next pat (M.insert nm (t, bind) vars) tree tokx + case pat of + Wildcard nm t -> defVar nm t (partStep [] (tok:tokx)) + AnyOne nm t -> defVar nm t [([tok], tokx)] + Single{} -> error "undefined behavior in Dao.Glob.matchTree:branch: case Single" + -- 'Single' cases must not occur, they should have been filtered out by the code: + -- > takeWhile (isVariable . fst) + ] + diff --git a/src/Dao/HashMap.hs b/src/Dao/HashMap.hs new file mode 100644 --- /dev/null +++ b/src/Dao/HashMap.hs @@ -0,0 +1,256 @@ +-- "src/Dao/HashMap.hs" a simple hash map using Data.IntMap +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +module Dao.HashMap + ( Hash128, Int128Hashable(hash128), + hash128_md5, deriveHash128_Show, deriveHash128_UStr, + deriveHash128_DataBinary, deriveHash128_DaoBinary, + Index, indexToPair, hashNewIndex, newIndex, indexHash, indexKey, + HashMap, hashLookup, hashAlter, hashInsert, hashDelete, hashAdjust, hashModify, + Dao.HashMap.lookup, alter, Dao.HashMap.insert, Dao.HashMap.delete, adjust, modify, + unionWith, unionsWith, Dao.HashMap.union, unions, differenceWith, difference, intersectionWith, intersection, + assocs, elems, keys, fromListWith, fromList, size, empty + ) where + +import Dao.String +import Dao.PPrint +import Dao.Binary + +import Control.Applicative hiding (empty) +import Control.Monad + +import Data.Typeable +import Data.Monoid +import Data.List +import Data.Char +import Data.Word +import qualified Data.Binary as B +import qualified Data.Binary.Get as B +import qualified Data.Binary.Put as B +import qualified Data.ByteString.Lazy as B +import qualified Data.Map as M +import qualified Data.IntMap as I +import qualified Data.Digest.MD5 as MD5 + +---------------------------------------------------------------------------------------------------- + +type Hash128 = (Word64, Word64) +type Int128Map a = I.IntMap (I.IntMap a) + +_lookup :: Hash128 -> Int128Map a -> Maybe a +_lookup (h1, h2) = I.lookup (fromIntegral h1) >=> I.lookup (fromIntegral h2) + +_alter :: (Maybe a -> Maybe a) -> Hash128 -> Int128Map a -> Int128Map a +_alter alt (h1, h2) = + I.alter + ((\m -> if I.null m then Nothing else Just m) . I.alter alt (fromIntegral h2) . maybe mempty id) + (fromIntegral h1) + +_unionWith :: (a -> a -> a) -> Int128Map a -> Int128Map a -> Int128Map a +_unionWith f = I.unionWith (I.unionWith f) + +_differenceWith :: (a -> b -> Maybe a) -> Int128Map a -> Int128Map b -> Int128Map a +_differenceWith f = I.differenceWith (\a b -> let m = I.differenceWith f a b in guard (not $ I.null m) >> return m) + +_intersectionWith :: (a -> b -> c) -> Int128Map a -> Int128Map b -> Int128Map c +_intersectionWith f = I.intersectionWith (I.intersectionWith f) + +_assocs :: Int128Map a -> [(Hash128, a)] +_assocs m = I.assocs m >>= \ (h1, m) -> I.assocs m >>= \ (h2, a) -> [((fromIntegral h1, fromIntegral h2), a)] + +_fromListWith :: (a -> a -> a) -> [(Hash128, a)] -> Int128Map a +_fromListWith f = fmap (I.fromListWith f) . I.fromListWith (++) . fmap (\ ((h1, h2), a) -> (fromIntegral h1, [(fromIntegral h2, a)])) + +---------------------------------------------------------------------------------------------------- + +class Ord key => Int128Hashable key where { hash128 :: key -> Hash128 } + +hash128_md5 :: [Word8] -> Hash128 +hash128_md5 = B.runGet (pure (,) <*> B.getWord64be <*> B.getWord64be) . B.pack . MD5.hash + +deriveHash128_Show :: Show a => a -> Hash128 +deriveHash128_Show = deriveHash128_UStr . show + +deriveHash128_UStr :: UStrType a => a -> Hash128 +deriveHash128_UStr = hash128_md5 . utf8bytes + +deriveHash128_DataBinary :: B.Binary a => a -> Hash128 +deriveHash128_DataBinary = hash128_md5 . B.unpack . B.encode + +deriveHash128_DaoBinary :: (HasCoderTable mtab, Binary a mtab) => mtab -> a -> Hash128 +deriveHash128_DaoBinary mtab = hash128_md5 . B.unpack . encode mtab + +---------------------------------------------------------------------------------------------------- + +data Index key = Index { indexHash :: Hash128, indexKey :: key } deriving (Eq, Ord, Typeable) + +indexToPair :: Index key -> (B.ByteString, key) +indexToPair (Index{ indexHash=(h1, h2), indexKey=key }) = + (B.runPut (B.putWord64be h1 >> B.putWord64be h2), key) + +instance Show key => Show (Index key) where + show (Index{ indexKey=key }) = concat ["Index (", show key, ")"] + +instance (Read key, Int128Hashable key) => Read (Index key) where + readsPrec p s = do + s <- maybe [] return $ stripPrefix "Index" $ dropWhile isSpace s + (key, s) <- case dropWhile isSpace s of { '(':s -> readsPrec p s; _ -> [] } + case dropWhile isSpace s of + ')':s -> [(Index{ indexHash=hash128 key, indexKey=key }, s)] + _ -> [] + +instance Binary key mtab => Binary (Index key) mtab where + put (Index{ indexHash=(h1, h2), indexKey=key }) = putWord64be h1 >> putWord64be h2 >> put key + get = do + h1 <- getWord64be + h2 <- getWord64be + key <- get + return $ Index{ indexHash=(h1, h2), indexKey=key } + +instance PPrintable key => PPrintable (Index key) where { pPrint i = pPrint (indexKey i) } + +hashNewIndex :: (key -> Hash128) -> key -> Index key +hashNewIndex hash key = Index{ indexHash = hash key, indexKey = key } + +newIndex :: Int128Hashable key => key -> Index key +newIndex = hashNewIndex hash128 + +---------------------------------------------------------------------------------------------------- + +newtype HashMap key a = HashMap (Int128Map (M.Map key a)) deriving (Eq, Ord, Typeable) + +instance (Show key, Show a) => Show (HashMap key a) where + show = ("fromList "++) . show . assocs + +instance (Read key, Int128Hashable key, Read a) => Read (HashMap key a) where + readsPrec p s = maybe [] return (stripPrefix "fromList" $ dropWhile isSpace s) >>= + readsPrec p . dropWhile isSpace >>= \ (hmap, s) -> return (fromList hmap, s) + +instance Functor (HashMap key) where + fmap f (HashMap m) = HashMap $ fmap (fmap (fmap f)) m + +instance (Ord key, Monoid a) => Monoid (HashMap key a) where + mempty = HashMap mempty + mappend a b = unionWith mappend a b + +instance HasNullValue (HashMap key a) where + nullValue = HashMap mempty + testNull = Dao.HashMap.null + +instance (Ord key, Binary key mtab, Binary a mtab) => Binary (HashMap key a) mtab where + put = put . assocs + get = fromList <$> get + +instance (PPrintable key, PPrintable a) => PPrintable (HashMap key a) where + pPrint = pList (pString "HashMap") "{" ", " "}" . + map (\ (a, b) -> pInline [pPrint a, pString " = ", pPrint b]) . assocs + +null :: HashMap key a -> Bool +null (HashMap a) = I.null a + +hashLookup :: Ord key => Index key -> HashMap key a -> Maybe a +hashLookup key (HashMap intmap) = _lookup (indexHash key) intmap >>= M.lookup (indexKey key) + +lookup :: Int128Hashable key => key -> HashMap key a -> (Index key, Maybe a) +lookup key hmap = let i = Index{ indexHash=hash128 key, indexKey=key } in (i, hashLookup i hmap) + +hashAlter :: Ord key => (Maybe a -> Maybe a) -> Index key -> HashMap key a -> HashMap key a +hashAlter alt key (HashMap intmap) = HashMap $ + _alter + ((\m -> guard (not $ M.null m) >> Just m) . M.alter alt (indexKey key) . maybe mempty id) + (indexHash key) + intmap + +alter :: Int128Hashable key => (Maybe a -> Maybe a) -> key -> HashMap key a -> HashMap key a +alter f key = hashAlter f (Index{ indexHash=hash128 key, indexKey=key }) + +hashInsert :: Ord key => Index key -> a -> HashMap key a -> HashMap key a +hashInsert key a = hashAlter (const $ Just a) key + +insert :: Int128Hashable key => key -> a -> HashMap key a -> HashMap key a +insert key = hashInsert (Index{ indexHash=hash128 key, indexKey=key}) + +hashDelete :: Ord key => Index key -> HashMap key a -> HashMap key a +hashDelete = hashAlter (const Nothing) + +delete :: Int128Hashable key => key -> HashMap key a -> HashMap key a +delete key = hashDelete (Index{ indexHash=hash128 key, indexKey=key }) + +hashAdjust :: Ord key => (a -> a) -> Index key -> HashMap key a -> HashMap key a +hashAdjust f = hashAlter (fmap f) + +adjust :: Int128Hashable key => (a -> a) -> key -> HashMap key a -> HashMap key a +adjust f key = hashAdjust f (Index{ indexHash=hash128 key, indexKey=key }) + +hashModify :: Ord key => (a -> Maybe a) -> Index key -> HashMap key a -> HashMap key a +hashModify f = hashAlter (>>=f) + +modify :: Int128Hashable key => (a -> Maybe a) -> key -> HashMap key a -> HashMap key a +modify f key = hashModify f (Index{ indexHash=hash128 key, indexKey=key }) + +unionWith :: Ord key => (a -> a -> a) -> HashMap key a -> HashMap key a -> HashMap key a +unionWith f (HashMap a) (HashMap b) = HashMap $ _unionWith (M.unionWith f) a b + +union :: Ord key => HashMap key a -> HashMap key a -> HashMap key a +union = unionWith const + +unionsWith :: Ord key => (a -> a -> a) -> [HashMap key a] -> HashMap key a +unionsWith f = foldl (unionWith f) empty + +unions :: Ord key => [HashMap key a] -> HashMap key a +unions = unionsWith const + +differenceWith :: Ord key => (a -> b -> Maybe a) -> HashMap key a -> HashMap key b -> HashMap key a +differenceWith f (HashMap a) (HashMap b) = HashMap $ + _differenceWith (\a b -> let m = M.differenceWith f a b in guard (not $ M.null m) >> return m) a b + +difference :: Ord key => HashMap key a -> HashMap key b -> HashMap key a +difference = differenceWith (\ _ _ -> Nothing) + +intersectionWith :: Ord key => (a -> b -> c) -> HashMap key a -> HashMap key b -> HashMap key c +intersectionWith f (HashMap a) (HashMap b) = HashMap $ _intersectionWith (M.intersectionWith f) a b + +intersection :: Ord key => HashMap key a -> HashMap key a -> HashMap key a +intersection = intersectionWith const + +assocs :: HashMap key a -> [(Index key, a)] +assocs (HashMap m) = do + (hash, m) <- _assocs m + (key , a) <- M.assocs m + [(Index{ indexHash=hash, indexKey=key }, a)] + +elems :: HashMap key a -> [a] +elems = fmap snd . assocs + +keys :: HashMap key a -> [Index key] +keys = fmap fst . assocs + +fromListWith :: Ord key => (a -> a -> a) -> [(Index key, a)] -> HashMap key a +fromListWith f = HashMap . fmap (fmap $ M.fromListWith f) . _fromListWith (++) . + fmap (\ (Index{ indexHash=hash, indexKey=key }, a) -> (hash, [(key, a)])) + +fromList :: Ord key => [(Index key, a)] -> HashMap key a +fromList = fromListWith (flip const) + +size :: HashMap key a -> Integer +size (HashMap m) = I.foldl (I.foldl (\i -> (i+) . toInteger . M.size)) 0 m + +empty :: HashMap key a +empty = HashMap I.empty + diff --git a/src/Dao/Interpreter.hs b/src/Dao/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Interpreter.hs @@ -0,0 +1,8391 @@ +-- "src/Dao/Interpreter.hs" defines the Dao programming language semantics. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +{-# LANGUAGE CPP #-} + +module Dao.Interpreter( + Action(Action), actionTokens, actionPattern, actionMatch, actionCodeBlock, + makeActionsForQuery, betweenBeginAndEnd, daoShutdown, getLocalRuleSet, + getGlobalRuleSet, defaultTokenizer, constructPatternWith, constructPattern, + DaoSetupM(), DaoSetup, haskellType, daoProvides, daoClass, daoConstant, daoFunction, + daoFunction0, daoInitialize, setupDao, evalDao, DaoFunc, daoFunc, funcAutoDerefParams, + daoForeignFunc, executeDaoFunc, + Sizeable(getSizeOf), + ObjectClass(obj, fromObj, castToCoreType), + execCastToCoreType, listToObj, listFromObj, new, opaque, objFromHata, + Struct(Nullary, Struct), structLookup, + ToDaoStructClass(toDaoStruct), toDaoStructExec, pPrintStructForm, + FromDaoStructClass(fromDaoStruct), withFromDaoStructExec, fromDaoStructExec, + StructError(StructError), + structErrName, structErrField, structErrValue, structErrExtras, + mkLabel, mkStructName, mkFieldName, + ToDaoStruct(), + fromData, innerToStruct, innerToStructWith, renameConstructor, makeNullary, putNullaryUsingShow, + define, optionalField, setField, defObjField, (.=), putObjField, (.=@), defMaybeObjField, (.=?), + FromDaoStruct(), + toData, constructor, innerFromStruct, nullary, getNullaryWithRead, structCurrentField, + tryCopyField, tryField, copyField, field, + convertFieldData, req, opt, reqList, optList, + ObjectUpdate, ObjectTraverse, + ObjectLens(updateIndex), ObjectFunctor(objectFMap), + ObjectFocus, ObjFocusState(), getFocalReference, + execToFocusUpdater, withInnerLens, runObjectFocus, focusObjectClass, focusStructAsDict, + focusLiftExec, focalPathSuffix, focusGuardStructName, updateHataAsStruct, callMethod, + innerDataUpdateIndex, referenceUpdateName, referenceLookupName, + Object( + ONull, OTrue, OType, OInt, OWord, OLong, + OFloat, ORatio, OComplex, OAbsTime, ORelTime, + OChar, OString, ORef, OList, ODict, OTree, OBytes, OHaskell + ), + T_type, T_int, T_word, T_long, T_ratio, T_complex, T_float, T_time, T_diffTime, + T_char, T_string, T_ref, T_bytes, T_list, T_dict, T_struct, + isNumeric, typeMismatchError, + initializeGlobalKey, destroyGlobalKey, evalTopLevelAST, + Reference(Reference, RefObject), reference, refObject, referenceHead, refUnwrap, + refNames, referenceFromUStr, fmapReference, setQualifier, modRefObject, + refAppendSuffix, referenceLookup, referenceUpdate, + CoreType( + NullType, TrueType, TypeType, IntType, WordType, DiffTimeType, FloatType, + LongType, RatioType, ComplexType, TimeType, CharType, StringType, RefType, + ListType, DictType, TreeType, BytesType, HaskellType + ), + typeOfObj, coreType, hataType, objTypeFromCoreType, objTypeFromName, + TypeSym(CoreType, TypeSym, TypeVar), TypeStruct(TypeStruct), ObjType(ObjType), typeChoices, + RefSuffix(NullRef, DotRef, Subscript, FuncCall), + refSuffixHead, refSuffixHasFuncCall, refSuffixToList, dotRef, subscript, funcCall, + Complex(Complex), + realPart, imagPart, mkPolar, cis, polar, magnitude, phase, conjugate, complex, + minAccumArray, minArray, + FuzzyStr(FuzzyStr), + ExecUnit(), ExecTokenizer(ExecTokenizer), runExecTokenizer, + globalMethodTable, defaultTimeout, importGraph, currentWithRef, taskForExecUnits, + currentQuery, currentPattern, currentBranch, providedAttributes, programModuleName, + preExec, postExec, quittingTime, programTokenizer, currentCodeBlock, ruleSet, + newExecUnit, inModule, + Task(), initTask, throwToTask, killTask, taskLoop, taskLoop_, + Executable(execute), DerefAssignExpr, + ExecRef(execReadRef, execTakeRef, execPutRef, execSwapRef, execModifyRef, execModifyRef_), + ExecControl(ExecReturn, ExecError), execReturnValue, + execErrorMessage, execErrorInModule, execErrorLocation, execErrorSubtype, execErrorInfo, + ExecErrorSubtype( + ExecErrorUntyped, ExecThrow, ExecStructError, ExecUndefinedRef, ExecTypeError, + ExecUpdateOpError, ExecInfixOpError, ExecIOException, ExecHaskellError + ), + errInFunc, errInConstr, errInInitzr, errOfReference, argNum, numArgsPassed, + expectNumArgs, exectDimension, expectType, actualType, leftSideType, rightSideType, + modifiedConst, assertFailed, returnedVoid, errorDict, + newError, throwArityError, throwParseError, throwBadTypeError, errLocation, errModule, + errCurrentModule, errInfo, updateExecErrorInfo, logUncaughtErrors, clearUncaughtErrorLog, + execForM, execForM_, + Exec(Exec), execToPredicate, XPure(XPure), xpureToState, runXPure, evalXPure, xpure, xobj, + xnote, xonUTF8, xmaybe, + ExecThrowable(toExecErrorInfo, execThrow), ioExec, + ExecHandler(ExecHandler), execHandler, + newExecIOHandler, execCatchIO, execHandleIO, execIOHandler, + execErrorHandler, catchReturn, execNested, execNested_, execFuncPushStack, + execFuncPushStack_, execWithStaticStore, execWithWithRefStore, withExecTokenizer, + Subroutine(Subroutine), setupCodeBlock, + origSourceCode, staticVars, staticRules, staticLambdas, executable, runCodeBlock, runCodeBlock_, + RuleSet(), CallableCode(CallableCode), argsPattern, returnType, codeSubroutine, + PatternRule(PatternRule), rulePatterns, ruleAction, + asReference, asInteger, asRational, asPositive, asComplex, objConcat, + objToBool, extractStringElems, requireAllStringArgs, + shiftLeft, shiftRight, + evalArithPrefixOp, evalInfixOp, evalUpdateOp, runTokenizerWith, runTokenizer, makePrintFunc, + paramsToGlobExpr, matchFuncParams, execGuardBlock, objToCallable, callCallables, + callObject, checkPredicate, checkVoid, + evalConditional, + localVarDefine, localVarUpdate, localVarLookup, maybeDerefObject, derefObjectGetReference, derefObject, + updateExecError, + assignUnqualifiedOnly, + LimitedObject(LimitedObject, unlimitObject), + MethodTable(), execGetObjTable, lookupMethodTable, + ReadIterable(readForLoop), UpdateIterable(updateForLoop), + HataClass(haskellDataInterface), toHata, fromHata, + InitItem(InitSingle, InitAssign), + Interface(), + objCastFrom, objEquality, objOrdering, objBinaryFormat, objNullTest, objPPrinter, + objSizer, objIndexer, objIndexUpdater, objToStruct, objFromStruct, objInitializer, objTraverse, + objInfixOpTable, objArithPfxOpTable, objCallable, objDereferencer, + interfaceAdapter, interfaceToDynamic, + DaoClassDefM(), interface, DaoClassDef, + defCastFrom, autoDefEquality, defEquality, autoDefOrdering, defOrdering, autoDefBinaryFmt, + defBinaryFmt, autoDefNullTest, defNullTest, defPPrinter, autoDefPPrinter, defReadIterable, + autoDefReadIterable, defUpdateIterable, autoDefUpdateIterable, defIndexer, defIndexUpdater, + defSizer, autoDefSizeable, autoDefToStruct, defToStruct, autoDefFromStruct, defFromStruct, + defInitializer, defTraverse, autoDefTraverse, defInfixOp, defPrefixOp, defCallable, defDeref, + defMethod, defMethod0, defLeppard + ) + where + +import Dao.Glob +import Dao.PPrint +import Dao.Predicate +import Dao.Random +import Dao.Stack +import Dao.String +import Dao.Token +import Dao.RefTable +import qualified Dao.HashMap as H +import qualified Dao.Binary as B +import qualified Dao.Interval as Iv +import qualified Dao.Tree as T +import Dao.Interpreter.Tokenizer +import Dao.Interpreter.AST + +import Data.Array.IArray +import Data.Binary (encode) +import Data.Bits +import Data.Char +import Data.Dynamic +import Data.IORef +import Data.List +import Data.Monoid +import Data.Ratio +import Data.Time.Clock +import Data.Word +import qualified Data.ByteString.Lazy.UTF8 as U +import qualified Data.ByteString.Lazy as B +import qualified Data.Binary as D +import qualified Data.Binary.Put as D +import qualified Data.Binary.Get as D +import qualified Data.Complex as C +import qualified Data.Map as M +import qualified Data.Set as S + +import Control.Applicative +import Control.Concurrent +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Control.Monad.Error +import Control.Monad.Reader +import Control.Monad.State + +#if 0 +import Debug.Trace +import System.IO +strace :: PPrintable s => String -> s -> s +strace msg s = trace (msg++": "++prettyShow s) s +dbg :: MonadIO m => String -> m () +dbg = liftIO . hPutStrLn stderr . ("(DEBUG) "++) . (>>=(\c -> if c=='\n' then "\n(DEBUG) " else [c])) +dbg' :: MonadIO m => String -> m a -> m a +dbg' msg f = f >>= \a -> dbg msg >> return a +dbg0 :: (MonadPlus m, MonadIO m, MonadError e m, Show e) => String -> m a -> m a +dbg0 msg f = do + dbg (msg++" (BEGIN)") + catchError + (mplus (f >>= \a -> dbg (msg++" (DONE)") >> return a) (dbg (msg++" (BACKTRACKED)") >> mzero)) + (\e -> dbg (msg++" (ERROR) "++show e) >> throwError e) +updbg :: MonadIO m => String -> (Maybe Object -> m (Maybe Object)) -> Maybe Object -> m (Maybe Object) +updbg msg f o = dbg ("(update with "++msg++")") >> f o >>= \o -> dbg ("(update complete "++show o++")") >> return o +#endif +#if 0 +_randTrace :: String -> RandO a -> RandO a +_randTrace = Dao.Random.randTrace +#else +_randTrace :: String -> RandO a -> RandO a +_randTrace _ = id +#endif + +---------------------------------------------------------------------------------------------------- + +-- A note on the binary format. +-- Most constructors have a unique prefix byte, and this allows more efficient encoding because +-- it is not necessary to place null terminators everywhere and you can determine exactly which +-- constructor is under the decoder cursor just from the byte prefix. This means there is an +-- address space for prefix bytes between 0x00 and 0xFF. This is an overview of that address space. +-- +-- 0x00..0x07 > The "Dao.Binary" module declares a few unique prefixes of its own for booleans, +-- variable-length integers, and maybe types, and of course the null terminator. +-- 0x08..0x1A > Each prefix here used alone indicates a 'CoreType's. But each prefix may be followed +-- by data which indicates that it is actuall one of the constructors for the 'Object' +-- data type. +-- +-- 0x25..0x26 'Struct' +-- 0x2E..0x2F 'TypeSym' +-- 0x33 'TypeStruct' +-- 0x37 'ObjType' (T_type) +-- +-- 0x42..0x45 > The 'RefSuffix' data type. These prefixes are re-used for the 'ReferenceExpr' data type +-- because there is a one-to-one mapping between these two data types. +-- 0x48..0x4F > The 'Reference' data type. These prefixes are re-used for the 'ReferenceExpr' data type +-- execpt for the 'RefWrapper' constructor which is mapped to @'RefPrefixExpr' 'REF'@. +-- +-- -- the abstract syntax tree -- -- +-- +-- 0x52..0x53 'RefPrefixExpr' +-- 0x59 'ParenExpr' +-- 0x60..0x64 'ObjectExpr' +-- 0x6A 'ArithExpr' +-- 0x6F 'AssignExpr' +-- 0x73 'ObjTestExpr' +-- 0x74..0x76 'RuleFuncExpr' +-- 0x7A..0x7B 'RuleHeadExpr' +-- 0x81 'DotLabelExpr' +-- 0x82 'AttributeExpr' +-- 0x86 'ObjListExpr' +-- 0xBA..0xCD 'InfixOp' +-- 0x8D..0x9D 'UpdateOp' -- Partially overlaps with 'InfixOp' +-- 0x8E..0x9B 'ArithPfxOp' -- Partially overlaps with 'InfixOp' +-- 0xA8..0xAF 'ScriptExpr' +-- 0xB6 'ElseExpr' +-- 0xBA 'IfElseExpr' +-- 0xBE 'WhileExpr' +-- 0xC5..0xC7 'TyChkExpr' +-- 0xCF..0xD0 'ParamExpr' +-- 0xD6 'ParamListExpr' +-- 0xDD 'CodeBlock' +-- 0xE9..0xEE 'TopLevelExpr' + +---------------------------------------------------------------------------------------------------- + +-- | An 'Action' is the result of a pattern match that occurs during an input string query. It is a +-- data structure that contains all the information necessary to run an 'Subroutine' assocaited with +-- a 'Glob', including the parent 'ExecUnit', the 'Dao.Glob.Glob' and the 'Dao.Glob.Match' objects, +-- and the 'Executables'. Use 'execute' to evaluate a 'Action' in the current thread. +-- +-- To execute an action in a separate thread, use 'forkExecAction'. +data Action + = Action + { actionTokens :: [Object] + , actionPattern :: Glob Object + , actionMatch :: M.Map Name Object + , actionCodeBlock :: Subroutine + } + deriving (Eq, Typeable) + +instance PPrintable Action where { pPrint = pPrintStructForm } + +instance ToDaoStructClass Action where + toDaoStruct = renameConstructor "Action" $ do + "tokens" .=@ actionTokens + "pattern" .=@ actionPattern + "match" .=@ actionMatch + "code" .=@ actionCodeBlock + +instance FromDaoStructClass Action where + fromDaoStruct = do + constructor "Action" + let err name o = flip (execThrow "match dictionary items must contain lists of tokens") [] $ + StructError + { structErrName = Nothing + , structErrField = Just (toUStr name) + , structErrValue = Just $ obj (typeOfObj o) + , structErrExtras = [] + } + let fmtMatches = fmap M.fromList . + mapM (\ (name, o) -> xmaybe (fromObj o) <|> err name o >>= return . (,) name) . M.assocs + return Action <*> req "tokens" <*> req "pattern" <*> (req "match" >>= fmtMatches) <*> req "code" + +instance ObjectClass Action where { obj=new; fromObj=objFromHata; } + +instance HataClass Action where + haskellDataInterface = interface "Action" $ do + autoDefEquality >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +instance Executable Action (Maybe Object) where + execute act = do + cq <- gets currentQuery + cp <- gets currentPattern + ccb <- gets currentCodeBlock + let setVar :: ObjectClass o => String -> (Action -> o) -> T_dict -> T_dict + setVar name f = M.insert (ustr name) (obj $ f act) + let setTokensVar = setVar "tokens" actionTokens + let setSelfVar = M.union (M.singleton (ustr "self") (obj $ setTokensVar $ mempty)) + let localVars = setSelfVar $ actionMatch act + modify $ \xunit -> + xunit + { currentQuery = Just $ actionTokens act + , currentPattern = Just $ actionPattern act + , currentCodeBlock = Just $ actionCodeBlock act + } + success <- optional $ runCodeBlock_ localVars (actionCodeBlock act) + modify (\xunit -> xunit{ currentQuery=cq, currentPattern=cp, currentCodeBlock=ccb }) + xmaybe success + +instance Executable [Action] [Object] where + execute = fmap concat . + mapM (\act -> catchPredicate (execute act) >>= \p -> case p of + OK (Just o) -> return [o] + PFail (ExecReturn (Just o)) -> return [o] + PFail err -> logUncaughtErrors [err] >> return [] + _ -> return [] + ) + +-- | Using an 'ExecTokenizer' function, break up a string into a list of tokens, returning them as a +-- 'TokenList' object. Input paramaters can be strings or lists of strings. If an input paramter is +-- a string, it is tokenized to a list of strings. If an input parameter is a list of strings, it is +-- considered to be already tokenized and simply appended to list of tokens produced by previous +-- parameters. +runTokenizerWith :: ExecTokenizer -> [Object] -> Exec [Object] +runTokenizerWith tok ox = fmap concat $ forM ox $ \o -> case o of + OString o -> fmap obj <$> runExecTokenizer tok o + OList ox -> return ox + o -> return [o] + +-- | Like 'runTokenizerWith', but uses the default tokenizer function set for this module. +runTokenizer :: [Object] -> Exec [Object] +runTokenizer ox = gets programTokenizer >>= \tok -> runTokenizerWith tok ox + +-- | Match a given input string to the 'Dao.Evaluator.currentPattern' of the current 'ExecUnit'. +-- Return all patterns and associated match results and actions that matched the input string, but +-- do not execute the actions. This is done by tokenizing the input string and matching the tokens +-- to the program using 'Dao.Glob.matchTree'. NOTE: Rules that have multiple patterns may execute +-- more than once if the input matches more than one of the patterns associated with the rule. *This +-- is not a bug.* Each pattern may produce a different set of match results, it is up to the +-- programmer of the rule to handle situations where the action may execute many times for a single +-- input. +-- +-- Once you have created an action group, you can execute it with 'Dao.Evaluator.execute'. +makeActionsForQuery :: [PatternTree Object [Subroutine]] -> [Object] -> Exec [Action] +makeActionsForQuery tree tokens = do + let match = matchTree False (T.unionsWith (++) tree) tokens + fmap concat $ forM match $ \ (patn, match, execs) -> do + match <- catchPredicate $ fmap M.fromList $ -- evaluate pattern type checkers + forM (M.assocs match) $ \ (name, (vartyp, ox)) -> case vartyp of + Nothing -> return (name, obj ox) + Just vartyp -> do + match <- catchPredicate $ referenceLookup $ Reference UNQUAL vartyp $ FuncCall [OList ox] NullRef + case match of + OK (_, Nothing) -> return (name, obj ox) + OK (_, Just o) -> return (name, o) + PFail (ExecReturn Nothing) -> return (name, obj ox) + PFail (ExecReturn (Just o)) -> return (name, o) + PFail err -> throwError err + Backtrack -> mzero + case match of + Backtrack -> return [] + PFail err -> logUncaughtErrors [err] >> return [] + OK match -> return $ + flip fmap execs $ \exec -> deepseq exec $! deepseq tokens $! deepseq patn $! deepseq match $! + Action + { actionPattern = patn + , actionTokens = fmap obj tokens + , actionMatch = match + , actionCodeBlock = exec + } + +-- | Evaluate an executable function between evaluating all of the "BEGIN{}" and "END{}" statements. +betweenBeginAndEnd :: Exec a -> Exec a +betweenBeginAndEnd runInBetween = get >>= \xunit -> do + -- Run all "BEGIN{}" procedures. + mapM_ execute (preExec xunit) + clearUncaughtErrorLog + -- Run the given function, presumably it performs a string execution. + a <- runInBetween + -- Update the "global this" pointer to include the uncaught exceptions. + errs <- OList . map new <$> clearUncaughtErrorLog + let upd = M.union (M.singleton (ustr "errors") errs) + referenceUpdate (Dao.Interpreter.reference GLOBAL (ustr "self")) False $ \o -> + return $ Just $ ODict $ upd $ case o of { Just (ODict o) -> o; _ -> mempty; } + -- Run all "END{}" procedures. + mapM_ execute (postExec xunit) + return a + +-- | Evaluates the @EXIT@ scripts for every presently loaded dao program, and then clears the +-- 'Dao.Interpreter.importGraph', effectively removing every loaded dao program and idea file from memory. +daoShutdown :: Exec () +daoShutdown = (M.elems <$> gets importGraph) >>= + mapM_ (\xunit -> inModule xunit $ gets quittingTime >>= mapM_ execute) + +-- | Returns a list of @'PatternTree' 'Object' ['Subroutine']@ objects from the global rule set and +-- the local rule set. +getLocalRuleSet :: Exec [PatternTree Object [Subroutine]] +getLocalRuleSet = do + sub <- gets currentCodeBlock + return $ maybe [] (return . staticRules) sub + +-- | Returns a list of @'PatternTree' 'Object' ['Subroutine']@ objects from the global rule set and +-- the local rule set. +getGlobalRuleSet :: Exec [PatternTree Object [Subroutine]] +getGlobalRuleSet = return <$> gets ruleSet + +_mkDoFunc :: String -> [Exec [PatternTree Object [Subroutine]]] -> (DaoFunc (), DaoFunc (), DaoFunc ()) +_mkDoFunc name selectors = (mkDo, mkDoAll, mkQuery) where + run f () ox = do + inTrees <- concat <$> sequence selectors + flip (,) () <$> (runTokenizer ox >>= makeActionsForQuery inTrees >>= f) + mkQuery = daoFunc{daoFuncName=ustr("query"++name), daoForeignFunc=run(return . Just . obj . fmap obj)} + mkDo = daoFunc{daoFuncName=ustr("do" ++name), daoForeignFunc=run(betweenBeginAndEnd . msum . fmap execute)} + mkDoAll = daoFunc{daoFuncName=ustr("doAll"++name), daoForeignFunc=run(betweenBeginAndEnd . fmap (Just . obj) . execute)} + +builtin_do :: DaoFunc () +builtin_doAll :: DaoFunc () +builtin_query :: DaoFunc () +(builtin_do, builtin_doAll, builtin_query) = _mkDoFunc "" [getLocalRuleSet, getGlobalRuleSet] + +builtin_doLocal :: DaoFunc () +builtin_doAllLocal :: DaoFunc () +builtin_queryLocal :: DaoFunc () +(builtin_doLocal, builtin_doAllLocal, builtin_queryLocal) = _mkDoFunc "Local" [getLocalRuleSet] + +builtin_doGlobal :: DaoFunc () +builtin_doAllGlobal :: DaoFunc () +builtin_queryGlobal :: DaoFunc () +(builtin_doGlobal, builtin_doAllGlobal, builtin_queryGlobal) = _mkDoFunc "Global" [getGlobalRuleSet] + +---------------------------------------------------------------------------------------------------- + +-- | When a 'Dao.Interpreter.AST.RuleExpr' is evaluated to an 'Object', it takes this form. +-- 'PatternRule' instantiats 'Executable' such that 'execute' converts it to a 'PatternTree'. +data PatternRule + = PatternRule{ rulePatterns :: [Object], ruleAction :: Subroutine } + deriving (Show, Typeable) + +instance NFData PatternRule where { rnf (PatternRule a b) = deepseq a $! deepseq b () } + +instance HasNullValue PatternRule where + nullValue = PatternRule{rulePatterns=[], ruleAction=nullValue} + testNull (PatternRule a b) = null a && testNull b + +instance PPrintable PatternRule where + pPrint (PatternRule pats exe) = (\a -> ppCallableAction "rule" a nullValue exe) $ case pats of + [] -> pString "()" + [pat] -> pPrint pat + pats -> pList (pString "rule") "(" ", " ")" (map pPrint pats) + +instance ToDaoStructClass PatternRule where + toDaoStruct = renameConstructor "PatternRule" $ do + "patterns" .=@ rulePatterns + "action" .=@ ruleAction + +instance FromDaoStructClass PatternRule where + fromDaoStruct = return PatternRule <*> req "patterns" <*> req "action" + +instance Executable PatternRule (PatternTree Object [Subroutine]) where + execute (PatternRule{ rulePatterns=pats, ruleAction=sub }) = do + globs <- mapM (constructPattern . return) pats + return $ insertMultiPattern (++) globs [sub] mempty + +instance ObjectClass PatternRule where { obj=new; fromObj=objFromHata; } + +instance HataClass PatternRule where + haskellDataInterface = interface "PatternRule" $ do + autoDefPPrinter >> autoDefToStruct >> autoDefFromStruct + +defaultTokenizer :: ExecTokenizer +defaultTokenizer = ExecTokenizer $ return . fmap obj . simpleTokenizer . uchars + +-- | This function takes a list of objects and constructs a list of @('Dao.Glob.Glob' 'Object')@s to +-- be inserted into a 'Dao.Glob.PatternTree' object. The input list of @['Object']@s will each form +-- a single pattern, then all of the patterns are unioned together to form the pattern tree. This +-- means token strings matched against the resulting @('Dao.Glob.Glob' 'Object')@ constructed by +-- this function will match any and all of the patterns. If any of the objects in the input list +-- are strings, the strings will be parsed into 'Dao.Glob.Glob' objects, and each string constant +-- within the 'Dao.Glob.Glob' object will be further tokenized with the 'programTokenizer'. +constructPatternWith :: ExecTokenizer -> [Object] -> Exec (Glob Object) +constructPatternWith tok = fmap (mconcat . mconcat) . mapM (derefObject>=>construct) where + construct o = case o of + OString o -> case readsPrec 0 (uchars o) of + [(glob, "")] -> fmap return $ parseOverSinglesM glob $ \str -> case str of + "" -> return [] + str -> fmap obj <$> runExecTokenizer tok (ustr str) + _ -> execThrow "unable to parse pattern" ExecErrorUntyped [] + OList ox -> return [makeGlob $ fmap Single ox] + OHaskell (Hata _ d) -> do + let err = throwBadTypeError "could not use as pattern expression" o [] + maybe err return $ msum $ + [ return <$> fromDynamic d + , fmap (makeGlob . fst) . T.assocs . ruleSetRules <$> fromDynamic d + ] + _ -> throwBadTypeError "could not create pattern from data of type" o [] + +-- | Like 'constructPatternWith' but uses the default 'ExecTokenizer' that has been set for the +-- current 'ExecUnit'. +constructPattern :: [Object] -> Exec (Glob Object) +constructPattern ox = gets programTokenizer >>= flip constructPatternWith ox + +---------------------------------------------------------------------------------------------------- + +-- The stateful data for the 'DaoSetup' monad. +data SetupModState + = SetupModState + { daoSatisfies :: M.Map UStr () + -- ^ a set of references that can satisfy "required" statements in Dao scripts. + , daoSetupConstants :: M.Map Name Object + , daoClasses :: MethodTable + , daoEntryPoint :: Exec () + } + +-- | This monadic type allows you to define a built-in module using procedural +-- programming syntax. Simply define each addition to the module one line at a time. Functions that +-- you can use include 'modProvides', 'modFunction', 'daoClass', and 'daoInitalize'. +-- +-- Define clever names for every 'DaoSetup' you write, then +type DaoSetup = DaoSetupM () +newtype DaoSetupM a = DaoSetup{ daoSetupM :: State SetupModState a } + deriving (Functor, Applicative, Monad) + +-- | This function is a placeholder used by the type system. The value of this function is +-- undefined, so strictly evaluating it will throw an exception. Fortunately, the only time you will +-- ever use this function is with the 'daoClass' function, which uses the type of this function but +-- never it's value. Refer to the documentation on 'daoClass' to see how to properly use this +-- function. +haskellType :: HataClass o => o +haskellType = error $ unwords $ + [ "the haskellType function is just a placeholder" + , "used by the type system, it must not be evaluated." + ] + +_updateSetupModState :: (SetupModState -> SetupModState) -> DaoSetup +_updateSetupModState f = DaoSetup (modify f) + +-- | Dao programs can declare "requires" statements along with it's imports. If your built-in module +-- provides what Dao programs might "required", then declare that this module provides that feature +-- using this function. +daoProvides :: UStrType s => s -> DaoSetup +daoProvides label = _updateSetupModState $ \st -> + st{ daoSatisfies = M.insert (toUStr label) () $ daoSatisfies st } + +-- | Associate an 'HataClass' with a 'Name'. This 'Name' will be callable from within Dao scripts. +-- > newtype MyClass = MyClass { ... } deriving (Eq, Ord) +-- > +-- > instance 'HataClass' MyClass where +-- > 'haskellDataInterface' = 'interface' $ do +-- > 'autoDefEquality' +-- > 'autoDefOrdering' +-- > ... +-- > +-- > setupDao :: 'DaoSetup' +-- > setupDao = do +-- > daoClass "myClass" (haskellType::MyClass) +-- > ... +daoClass :: (Typeable o, HataClass o) => o -> DaoSetup +daoClass ~o = _updateSetupModState $ \st -> + st{ daoClasses = _insertMethodTable o haskellDataInterface (daoClasses st) } + +-- | Define a built-in top-level function that is not a member method of any object. Examples of +-- built-in functions provided in this module are "println()" and "typeof()". +daoFunction :: (Show name, UStrType name) => name -> DaoFunc () -> DaoSetup +daoFunction name func = _updateSetupModState $ \st -> let nm = (fromUStr $ toUStr name) in + st{ daoSetupConstants = M.insert nm (new $ func{ daoFuncName=nm }) (daoSetupConstants st) } + +-- | Like 'daoFunction' but creates a function that takes no parameters. +daoFunction0 :: Name -> Exec (Maybe Object) -> DaoSetup +daoFunction0 name f = daoFunction name $ + DaoFunc + { daoFuncClass = [] + , daoFuncName = nil + , funcAutoDerefParams = False + , daoForeignFunc = \ () ox -> case ox of + [] -> flip (,) () <$> f + _ -> throwArityError "" 0 ox [(errInFunc, obj $ reference UNQUAL name)] + } + +-- | Define a constant value for any arbitrary 'Object'. +daoConstant :: (Show name, UStrType name) => name -> Object -> DaoSetup +daoConstant name o = _updateSetupModState $ \st -> + st{ daoSetupConstants = M.insert (fromUStr $ toUStr name) o (daoSetupConstants st) } + +-- | Provide an 'Exec' monad to perform when 'setupDao' is evaluated. You may use this function as +-- many times as you wish, every 'Exec' monad will be executed in the order they are specified. This +-- is a good way to create a read-eval-print loop. +daoInitialize :: Exec () -> DaoSetup +daoInitialize f = _updateSetupModState $ \st -> st{ daoEntryPoint = daoEntryPoint st >> f } + +-- | Use this function evaluate a 'DaoSetup' in the IO () monad. Use this to define the 'main' +-- function of your program. +setupDao :: DaoSetup -> IO (Predicate ExecControl ()) +setupDao setup0 = do + let setup = execState (daoSetupM $ loadEssentialFunctions >> setup0) $ + SetupModState + { daoSatisfies = M.empty + , daoSetupConstants = M.empty + , daoClasses = mempty + , daoEntryPoint = return () + } + xunit <- _initExecUnit + fmap fst $ ioExec (daoEntryPoint setup) $ + xunit + { providedAttributes = daoSatisfies setup + , builtinConstants = daoSetupConstants setup + , globalMethodTable = daoClasses setup + } + +-- | Simply run a single 'Exec' function in a fresh environment with no setup, and delete the +-- envrionment when finished returning only the 'Dao.Predicate.Predicate' result of the 'Exec' +-- evaluation. If you want to have more control over the runtime in which the 'Exec' function runs, +-- use 'setupDao' with 'daoInitialize'. +evalDao :: Exec a -> IO (Predicate ExecControl a) +evalDao f = _initExecUnit >>= fmap fst . ioExec f + +---------------------------------------------------------------------------------------------------- + +-- | All object methods that operate on object data types built-in to the Dao language, or built-in +-- to a library extending the Dao language, are stored in 'Data.Map.Map's from the functions name to +-- an object of this type. +-- +-- The @this@ of this function is the data type of what languages like C++ or Java would call the +-- "self" variable. 'DaoFunc's where the @this@ is () are considered ordinary functions that do not +-- operate on any object apart from their input parameters. +data DaoFunc this + = DaoFunc + { daoFuncClass :: [Name] + , daoFuncName :: Name + , funcAutoDerefParams :: Bool + , daoForeignFunc :: this -> [Object] -> Exec (Maybe Object, this) + } + deriving Typeable +instance Eq (DaoFunc this) where { a == b = daoFuncName a == daoFuncName b; } +instance Ord (DaoFunc this) where { compare a b = compare (daoFuncName a) (daoFuncName b) } +instance Show (DaoFunc this) where + show func = + if null (daoFuncClass func) + then uchars (daoFuncName func) + else foldr (\name str -> uchars name ++ "." ++ str) (uchars $ daoFuncName func) (daoFuncClass func) +instance PPrintable (DaoFunc this) where { pPrint = pShow } + +-- | Use this as the constructor of a 'DaoFunc'. By default the @this@ type is (). To change the +-- @this@ type, simply supply a different function type for the 'daoForeignFunc' field. For example: +-- > daoFunc{ daoFuncName=ustr "add", daoForeignFunc = retrun . (+1) } :: DaoFunc Int +daoFunc :: DaoFunc typ +daoFunc = + DaoFunc + { daoFuncClass = [] + , daoFuncName = nil + , funcAutoDerefParams = True + , daoForeignFunc = \typ _ -> return (Nothing, typ) + } + +-- | Execute a 'DaoFunc' +executeDaoFunc :: DaoFunc this -> this -> [Object] -> Exec (Maybe Object, this) +executeDaoFunc fn this params = do + args <- (if funcAutoDerefParams fn then mapM derefObject else return) params + pval <- catchPredicate (daoForeignFunc fn this args) + case pval of + OK (o, this) -> return (o, this) + PFail (ExecReturn o) -> return (o, this) + PFail err -> throwError err + Backtrack -> mzero + +-- Evaluate this function as one of the instructions in the monadic function passed to the +-- 'setupDao' function in order to install the most fundamental functions into the Dao evaluator. +-- This function must be evaluated in order to have access to the following functions: +-- > print, join, defined, delete +loadEssentialFunctions :: DaoSetup +loadEssentialFunctions = do + daoClass (haskellType :: H.HashMap Object Object) + daoClass (haskellType :: RuleSet) + daoClass (haskellType :: Pair) + daoFunction "print" builtin_print + daoFunction "println" builtin_println + daoFunction "join" builtin_join + daoFunction "str" builtin_str + daoFunction "quote" builtin_quote + daoFunction "concat" builtin_concat + daoFunction "concat1" builtin_concat1 + daoFunction "reverse" builtin_reverse + daoFunction "int" builtin_int + daoFunction "long" builtin_long + daoFunction "ratio" builtin_ratio + daoFunction "float" builtin_float + daoFunction "complex" builtin_complex + daoFunction "imag" builtin_imag + daoFunction "phase" builtin_phase + daoFunction "conj" builtin_conj + daoFunction "abs" builtin_abs + daoFunction "time" builtin_time + daoFunction "now" builtin_now + daoFunction "ref" builtin_ref + daoFunction "defined" builtin_check_if_defined + daoFunction "delete" builtin_delete + daoFunction "typeof" builtin_typeof + daoFunction "sizeof" builtin_sizeof + daoFunction "call" builtin_call + daoFunction "toHash" builtin_toHash + daoFunction "fromHash" builtin_fromHash + daoFunction "tokenize" builtin_tokenize + daoFunction "query" builtin_query + daoFunction "doAll" builtin_doAll + daoFunction "do" builtin_do + daoFunction "fromStruct" builtin_fromStruct + daoFunction "toStruct" builtin_toStruct + daoFunction "queryGlobal" builtin_queryGlobal + daoFunction "doAllGlobal" builtin_doAllGlobal + daoFunction "doGlobal" builtin_doGlobal + daoFunction "queryLocal" builtin_queryLocal + daoFunction "doAllLocal" builtin_doAllLocal + daoFunction "doLocal" builtin_doLocal + daoFunction "HashMap" builtin_HashMap + daoFunction "assocs" builtin_assocs + daoFunction "Pair" builtin_Pair + mapM_ (uncurry daoConstant) $ flip fmap [minBound..maxBound] $ \t -> + (toUStr $ show t, OType $ objTypeFromCoreType t) + +instance ObjectClass (DaoFunc ()) where { obj=new; fromObj=objFromHata; } +instance ObjectClass (DaoFunc Dynamic) where { obj=new; fromObj=objFromHata; } +instance ObjectClass (DaoFunc Hata) where { obj=new; fromObj=objFromHata; } +instance ObjectClass (DaoFunc Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (DaoFunc ()) where + haskellDataInterface = interface "Builtin_Function" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + +instance HataClass (DaoFunc Dynamic) where + haskellDataInterface = interface "Builtin_Dynamic_Method" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + +instance HataClass (DaoFunc Hata) where + haskellDataInterface = interface "Builtin_Haskell_Data_Method" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + +instance HataClass (DaoFunc Object) where + haskellDataInterface = interface "Builtin_Object_Method" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + +---------------------------------------------------------------------------------------------------- + +-- | This class provides a consistent interface, the 'obj' function, for converting a wide range of +-- types to an 'Object' type. +class ObjectClass o where + obj :: o -> Object + fromObj :: Object -> Maybe o + castToCoreType :: CoreType -> o -> XPure Object + castToCoreType _ _ = mzero + +execCastToCoreType :: ObjectClass o => CoreType -> o -> Exec Object +execCastToCoreType t = execute . castToCoreType t + +instance ObjectClass () where + obj () = ONull + fromObj o = case o of { ONull -> return (); _ -> mzero; } + castToCoreType t () = case t of + NullType -> return ONull + CharType -> return $ OChar '\0' + IntType -> return $ OInt 0 + WordType -> return $ OWord 0 + LongType -> return $ OLong 0 + DiffTimeType -> return $ ORelTime 0 + FloatType -> return $ OFloat 0 + RatioType -> return $ ORatio 0 + ComplexType -> return $ OComplex $ complex 0 0 + StringType -> return $ OString nil + BytesType -> return $ OBytes mempty + ListType -> return $ OList [] + DictType -> return $ ODict mempty + _ -> mzero + +instance ObjectClass Bool where + obj true = if true then OTrue else ONull + fromObj o = case o of { OTrue -> return True; ONull -> return False; _ -> mzero } + castToCoreType t o = case t of + NullType -> guard (not o) >> return ONull + TrueType -> guard o >> return OTrue + CharType -> return $ OChar $ if o then '1' else '0' + IntType -> return $ OInt $ if o then 1 else 0 + WordType -> return $ OWord $ if o then 1 else 0 + LongType -> return $ OLong $ if o then 1 else 0 + DiffTimeType -> return $ ORelTime $ if o then 1 else 0 + FloatType -> return $ OFloat $ if o then 1 else 0 + RatioType -> return $ ORatio $ if o then 1 else 0 + ComplexType -> return $ OComplex $ if o then complex 1 0 else complex 0 0 + StringType -> return $ obj $ if o then "true" else "false" + BytesType -> return $ OBytes $ B.pack $ return $ if o then 1 else 0 + _ -> mzero + +instance ObjectClass Char where + obj = OChar + fromObj o = case o of { OChar o -> return o; _ -> mzero; } + castToCoreType t = case t of + NullType -> \o -> guard (o=='\0') >> return ONull + TrueType -> \o -> case o of + '0' -> return ONull + '1' -> return OTrue + _ -> mzero + CharType -> return . OChar + IntType -> return . OInt . ord + WordType -> return . OWord . fromIntegral . ord + LongType -> return . OLong . fromIntegral . ord + DiffTimeType -> return . ORelTime . fromRational . toRational . ord + FloatType -> return . OFloat . fromRational . toRational . ord + RatioType -> return . ORatio . toRational . ord + ComplexType -> return . OComplex . flip complex 0 . fromRational . toRational . ord + StringType -> return . obj . (:[]) + BytesType -> return . OBytes . D.runPut . D.putWord64le . fromIntegral . ord + _ -> \ _ -> mzero + +charFromIntegral :: (MonadPlus m, Integral i) => i -> m Char +charFromIntegral i0 = + let i = fromIntegral i0 + in if ord(minBound::Char) <= i && i <= ord(maxBound::Char) then return (chr i) else mzero + +instance ObjectClass Int where + obj = OInt + fromObj o = case o of { OInt o -> return o; _ -> mzero; } + castToCoreType t = case t of + NullType -> \o -> guard (o==0) >> return ONull + TrueType -> \o -> return $ if o==0 then ONull else OTrue + CharType -> fmap OChar . charFromIntegral + IntType -> return . OInt + WordType -> return . OWord . fromIntegral + LongType -> return . OLong . toInteger + FloatType -> return . OFloat . fromRational . toRational + RatioType -> return . ORatio . toRational + ComplexType -> return . OComplex . flip complex 0 . fromRational . toRational + DiffTimeType -> return . ORelTime . fromRational . toRational + StringType -> return . obj . prettyShow . obj + BytesType -> return . OBytes . D.runPut . D.putWord64le . fromIntegral + _ -> \ _ -> mzero + +instance ObjectClass Word where + obj = OWord . fromIntegral + fromObj o = case o of { OWord o -> return (fromIntegral o); _ -> mzero; } + castToCoreType t = case t of + NullType -> \o -> guard (o==0) >> return ONull + TrueType -> \o -> return $ if o==0 then ONull else OTrue + CharType -> fmap OChar . charFromIntegral + IntType -> return . OInt . fromIntegral + WordType -> return . OWord . fromIntegral + LongType -> return . OLong . toInteger + FloatType -> return . OFloat . fromRational . toRational + RatioType -> return . ORatio . toRational + ComplexType -> return . OComplex . flip complex 0 . fromRational . toRational + DiffTimeType -> return . ORelTime . fromRational . toRational + StringType -> return . obj . prettyShow . obj + BytesType -> return . OBytes . D.runPut . D.putWord64le . fromIntegral + _ -> \ _ -> mzero + +instance ObjectClass Word64 where + obj = OWord + fromObj o = case o of { OWord o -> return o; _ -> mzero; } + castToCoreType t = case t of + NullType -> \o -> guard (o==0) >> return ONull + TrueType -> \o -> return $ if o==0 then ONull else OTrue + CharType -> fmap OChar . charFromIntegral + IntType -> return . OInt . fromIntegral + WordType -> return . OWord + LongType -> return . OLong . toInteger + FloatType -> return . OFloat . fromRational . toRational + RatioType -> return . ORatio . toRational + ComplexType -> return . OComplex . flip complex 0 . fromRational . toRational + DiffTimeType -> return . ORelTime . fromRational . toRational + StringType -> return . obj . prettyShow . obj + BytesType -> return . OBytes . D.runPut . D.putWord64le . fromIntegral + _ -> \ _ -> mzero + +instance ObjectClass Integer where + obj = OLong + fromObj o = case o of { OLong o -> return o; _ -> mzero; } + castToCoreType t = case t of + NullType -> \o -> guard (o==0) >> return ONull + TrueType -> \o -> return $ if o==0 then ONull else OTrue + CharType -> fmap OChar . charFromIntegral + IntType -> return . OInt . fromInteger + WordType -> return . OWord . fromInteger + LongType -> return . OLong + FloatType -> return . OFloat . fromRational . toRational + RatioType -> return . ORatio . toRational + ComplexType -> return . OComplex . flip complex 0 . fromRational . toRational + DiffTimeType -> return . ORelTime . fromRational . toRational + StringType -> return . obj . show + BytesType -> return . OBytes . B.reverse . D.encode + _ -> \ _ -> mzero + +instance ObjectClass NominalDiffTime where + obj = ORelTime + fromObj o = case o of { ORelTime o -> return o; _ -> mzero; } + castToCoreType t = case t of + NullType -> \o -> guard (toRational o == 0) >> return ONull + TrueType -> \o -> return $ if toRational o == 0 then ONull else OTrue + IntType -> return . OInt . round + WordType -> return . OWord . round + LongType -> return . OLong . round + FloatType -> return . OFloat . fromRational . toRational + DiffTimeType -> return . ORelTime + ComplexType -> return . OComplex . flip complex 0 . fromRational . toRational + _ -> \ _ -> mzero + +instance ObjectClass Double where + obj = OFloat + fromObj o = case o of { OFloat o -> return o; _ -> mzero; } + castToCoreType t = case t of + NullType -> \o -> guard (o==0) >> return ONull + TrueType -> \o -> return $ if o==0 then ONull else OTrue + CharType -> fmap OChar . charFromIntegral . (round :: Double -> Int) + IntType -> return . OInt . round + WordType -> return . OWord . round + LongType -> return . OLong . round + FloatType -> return . OFloat + RatioType -> return . ORatio . toRational + ComplexType -> return . OComplex . flip complex 0 . fromRational . toRational + DiffTimeType -> return . ORelTime . fromRational . toRational + StringType -> return . obj . show + BytesType -> return . OBytes . D.encode + _ -> \ _ -> mzero + +instance ObjectClass Rational where + obj = ORatio + fromObj o = case o of { ORatio o -> return o; _ -> mzero; } + castToCoreType t = case t of + NullType -> \o -> guard (o==0) >> return ONull + TrueType -> \o -> return $ if o==0 then ONull else OTrue + CharType -> fmap OChar . charFromIntegral . (round :: Rational -> Int) + IntType -> return . OInt . round + WordType -> return . OWord . round + LongType -> return . OLong . round + FloatType -> return . OFloat . fromRational + RatioType -> return . ORatio + ComplexType -> return . OComplex . flip complex 0 . fromRational + DiffTimeType -> return . ORelTime . fromRational . toRational + StringType -> return . obj . prettyShow . obj + _ -> \ _ -> mzero + +instance ObjectClass Complex where + obj = OComplex + fromObj o = case o of { OComplex o -> return o; _ -> mzero; } + castToCoreType t = case t of + NullType -> \o -> guard (complex 0 0 == o) >> return ONull + TrueType -> \o -> return $ if complex 0 0 == o then ONull else OTrue + IntType -> i OInt + WordType -> return . OWord . round . magnitude + LongType -> i OLong + FloatType -> f OFloat + RatioType -> f ORatio + ComplexType -> return . OComplex + DiffTimeType -> f ORelTime + StringType -> return . obj . prettyShow + _ -> \ _ -> mzero + where + f constr o = guard (imagPart o == 0) >> return (constr $ fromRational $ toRational $ realPart o) + i constr = f (constr . fromInteger . (round :: Rational -> Integer)) + +instance ObjectClass UStr where + obj = OString + fromObj o = case o of { OString o -> return o; _ -> mzero; } + castToCoreType t = case t of + StringType -> return . OString + _ -> castToCoreType t . uchars + +instance ObjectClass String where + obj = obj . toUStr + fromObj = fromObj >=> maybeFromUStr + castToCoreType t = case t of + NullType -> \o -> guard (o=="null") >> return ONull + TrueType -> \o -> case map toLower o of + "true" -> return OTrue + "yes" -> return OTrue + "no" -> return ONull + "false" -> return ONull + "null" -> return ONull + _ -> mzero + IntType -> pars OInt + WordType -> pars OWord + LongType -> pars OLong + FloatType -> pars OFloat + TimeType -> pars OAbsTime + StringType -> return . OString . ustr + RefType -> pars ORef + _ -> \ _ -> mzero + where + nospc = dropWhile isSpace + pars f str = case fmap (reverse . nospc . reverse) <$> readsPrec 0 (nospc str) of + [(o, "")] -> return (f o) + _ -> mzero + +instance ObjectClass B.ByteString where + obj = OBytes + fromObj o = case o of { OBytes o -> return o; _ -> mzero; } + castToCoreType t = case t of + NullType -> f (D.isEmpty >>= guard >> return ONull) + TrueType -> + f (D.getWord8 >>= \w -> + return $ case w of { 0->Just ONull; 1->Just OTrue; _->mzero; }) >=> xmaybe + CharType -> fmap OChar . (f D.getWord64le >=> charFromIntegral) + IntType -> fmap (OInt . fromIntegral) . f D.getWord64le + WordType -> fmap (OWord . fromIntegral) . f D.getWord64le + LongType -> return . OLong . D.decode . B.reverse + FloatType -> return . OFloat . D.decode + _ -> \ _ -> mzero + where + f :: D.Get o -> B.ByteString -> XPure o + f get = return . D.runGet get + +instance ObjectClass [Object] where + obj = OList + fromObj o = case o of { OList o -> return o; _ -> mzero; } + castToCoreType t = case t of + StringType -> fmap OList . loop return + BytesType -> fmap (OBytes . D.runPut . mapM_ D.putLazyByteString) . loop (\ (OBytes o) -> [o]) + ListType -> return . OList + _ -> \ _ -> mzero + where + loop f = fmap concat . + mapM (\o -> (xmaybe (fromObj o) >>= loop f) <|> (f <$> castToCoreType t o)) + +instance ObjectClass (M.Map Name Object) where + obj = ODict + fromObj o = case o of { ODict o -> return o; _ -> mzero; } + castToCoreType t o = case t of + NullType -> guard (M.null o) >> return ONull + DictType -> return $ ODict o + _ -> mzero + +instance ObjectClass Reference where + obj = ORef + fromObj o = case o of { ORef o -> return o; _ -> mzero; } + castToCoreType t o = case t of + StringType -> return $ obj $ '$':prettyShow o + RefType -> return (ORef o) + _ -> mzero + +instance ObjectClass Name where + obj n = ORef $ Reference UNQUAL n NullRef + fromObj o = case o of + OString o -> maybeFromUStr o + ORef (Reference UNQUAL name NullRef) -> return name + _ -> mzero + +instance ObjectClass ObjType where + obj = OType + fromObj o = case o of { OType o -> return o; _ -> mzero; } + castToCoreType t = case t of + TypeType -> return . OType + StringType -> return . obj . prettyShow + _ -> \ _ -> mzero + +instance ObjectClass CoreType where + obj = OType . objTypeFromCoreType + fromObj o = case o of + OType (ObjType [TypeStruct [CoreType o]]) -> return o + _ -> mzero + castToCoreType t = case t of + IntType -> return . OInt . fromIntegral . fromEnum + WordType -> return . OWord . fromIntegral . fromEnum + LongType -> return . OLong . fromIntegral . fromEnum + StringType -> return . obj . show + TypeType -> return . obj + _ -> \ _ -> mzero + +instance ObjectClass Struct where + obj = OTree + fromObj o = case o of { OTree o -> return o; _ -> mzero; } + castToCoreType t = case t of + TreeType -> return . OTree + RefType -> return . obj . structName + StringType -> return . obj . prettyShow + _ -> \ _ -> mzero + +instance ObjectClass UTCTime where + obj = OAbsTime + fromObj o = case o of { OAbsTime o -> return o; _ -> mzero; } + castToCoreType t = case t of + StringType -> return . obj . prettyShow . obj + TimeType -> return . OAbsTime + _ -> \ _ -> mzero + +instance ObjectClass Hata where + obj = OHaskell + fromObj o = case o of { OHaskell o -> return o; _ -> mzero; } + +instance ObjectClass Dynamic where + obj = opaque + fromObj o = case o of { OHaskell (Hata _ o) -> return o; _ -> mzero; } + +instance ObjectClass Object where + obj = id; + fromObj = return; + castToCoreType t o = case o of + ONull -> f False + OTrue -> f True + OChar o -> f o + OInt o -> f o + OWord o -> f o + OLong o -> f o + OAbsTime o -> f o + OFloat o -> f o + ORatio o -> f o + OComplex o -> f o + OString o -> f o + OBytes o -> f o + OList o -> f o + ODict o -> f o + ORef o -> f o + OType o -> f o + OTree o -> f o + ORelTime o -> f o + OHaskell _ -> mzero + where + f :: ObjectClass o => o -> XPure Object + f = castToCoreType t + +instance ObjectClass Location where { obj=new; fromObj=objFromHata; } + +instance ObjectClass Comment where { obj=new; fromObj=objFromHata; } + +instance ObjectClass [Comment] where { obj=listToObj; fromObj=listFromObj; } + +instance ObjectClass DotNameExpr where { obj=new; fromObj=objFromHata; } + +instance ObjectClass AST_DotName where { obj=new; fromObj=objFromHata; } + +instance ObjectClass DotLabelExpr where { obj=new; fromObj=objFromHata; } + +instance ObjectClass AST_DotLabel where { obj=new; fromObj=objFromHata; } + +listToObj :: ObjectClass o => [o] -> Object +listToObj = OList . map obj + +listFromObj :: ObjectClass o => Object -> Maybe [o] +listFromObj o = case o of + OList o -> mapM fromObj o + _ -> mzero + +-- | Create a new 'Object' containing the original value and a reference to the 'Interface' +-- retrieved by the instance of 'haskellDataInterface' for the data type. +new :: (HataClass typ, Typeable typ) => typ -> Object +new = OHaskell . toHata + +-- | Create a completely opaque haskell data type that can be used stored to a Dao language +-- variable, but never inspected or modified in any way. +opaque :: forall typ . Typeable typ => typ -> Object +opaque o = OHaskell $ flip Hata (toDyn o) $ + interfaceToDynamic (interface (show $ typeOf o) (return ()) :: Interface typ) + +-- | The inverse operation of 'new', uses 'fromObj' and 'fromHata' to extract the data type +-- wrapped up in the 'Object', assuming the 'Object' is the 'OHaskell' constructor holding a +-- 'Hata' container. +objFromHata :: (Typeable o, HataClass o) => Object -> Maybe o +objFromHata = fromObj >=> fromHata + +---------------------------------------------------------------------------------------------------- + +-- | This is the "Haskell Data" data type used to wrap-up a Haskell data types into a +-- 'Data.Dynamic.Dynamic' data type and associate this dynamic data with the 'Interface' used by the +-- runtime to read and modify the data. Whenever an non-primitive 'Object' is created, the data is +-- converted to a 'Data.Dynamic.Dynamic' value and paired with a copy of the 'Interface'. +data Hata = Hata (Interface Dynamic) Dynamic deriving Typeable + +instance Eq Hata where + Hata ifcA a == Hata ifcB b = + ((ifcA==ifcB)&&) $ maybe False id $ objEquality ifcA >>= \eq -> return (eq a b) + +instance Ord Hata where + compare (Hata ifcA a) (Hata ifcB b) = maybe err id $ + guard (ifcA==ifcB) >> objOrdering ifcA >>= \comp -> return (comp a b) where + err = error $ unwords $ + [ "cannot compare object of type", show (objHaskellType ifcA) + , "with obejct of type", show (objHaskellType ifcB) + ] + +instance Show Hata where { show (Hata o _) = show (objHaskellType o) } + +instance NFData Hata where { rnf (Hata _ _) = () } + +instance PPrintable Object where + pPrint o = case o of + ONull -> pString "null" + OTrue -> pString "true" + OChar o -> pShow o + OInt o -> pShow o + OWord o -> pString (show o++"U") + OLong o -> pString (show o++"L") + ORelTime o -> pShow o + OFloat o -> pString (show o++"f") + ORatio o -> + if denominator o == 1 + then pString (show (numerator o)++"R") + else pWrapIndent $ + [ pString "(", pString (show (numerator o)), pString "/" + , pString (show (denominator o)++"R"), pString ")" + ] + OComplex o -> pPrint o + OString o -> pShow o + OBytes o -> + if B.null o + then pString "data{}" + else pList (pString "data") "{" ", " "}" (map (pString . showHex) (B.unpack o)) + OList ox -> if null ox then pString "list{}" else pContainer "list " pPrint ox + ODict o -> + if M.null o + then pString "dict{}" + else pContainer "dict " (\ (a, b) -> pWrapIndent [pPrint a, pString " = ", pPrint b]) (M.assocs o) + ORef o -> pPrint o + OType o -> pPrint o + OTree o -> pPrint o + OAbsTime o -> pString ("date "++show o) + OHaskell (Hata ifc o) -> case objPPrinter ifc of + Nothing -> fail $ "cannot pretty print Haskell data type: "++show (objHaskellType ifc) + Just pp -> pp o + +instance B.Binary Hata MTab where + put (Hata ifc o) = do + let typeName = objInterfaceName ifc + mtab <- B.getCoderTable + case B.getEncoderForType typeName mtab of + Just fn -> do + tid <- B.newInStreamID typeName + B.put tid >> B.putWithBlockStream1M (fn o) + Nothing -> fail $ unwords ["no binary format method defied for Haskell type", uchars (toUStr typeName)] + get = do + B.updateTypes + mtab <- B.getCoderTable + tid <- B.get >>= B.decodeIndexLookup + maybe mzero id $ do + tid <- tid + fn <- B.getDecoderForType tid mtab + tab <- lookupMethodTable tid mtab + return (Hata tab <$> B.getWithBlockStream1M fn) + +instance HasNullValue Hata where + nullValue = toHata () + testNull (Hata ifc o) = case objNullTest ifc of + Nothing -> error ("to check whether objects of type "++show (objHaskellType ifc)++" are null is undefined behavior") + Just fn -> fn o + +-- | This is a convenience function for calling 'OHaskell' using just an initial value of type +-- @typ@. The 'Interface' is retrieved automatically using the instance of 'haskellDataInterface' for +-- the @typ@. +toHata :: (HataClass typ, Typeable typ) => typ -> Hata +toHata t = flip Hata (toDyn t) (interfaceTo t haskellDataInterface) where + interfaceTo :: Typeable typ => typ -> Interface typ -> Interface Dynamic + interfaceTo _ ifc = interfaceToDynamic ifc + +-- | Inverse operation of 'toHata', useful when instantiating 'ObjectClass', uses +-- 'Data.Dynamic.fromDynamic' to extract the value that has been wrapped in up the 'Hata' +-- constructor. +fromHata :: (HataClass typ, Typeable typ) => Hata -> Maybe typ +fromHata (Hata _ o) = fromDynamic o + +---------------------------------------------------------------------------------------------------- + +class Sizeable o where { getSizeOf :: o -> Exec Object } + +instance Sizeable Char where { getSizeOf = return . obj . ord } +instance Sizeable Word64 where { getSizeOf = return . obj } +instance Sizeable Int where { getSizeOf = return . obj . abs } +instance Sizeable Double where { getSizeOf = return . obj . abs } +instance Sizeable Integer where { getSizeOf = return . obj . abs } +instance Sizeable NominalDiffTime where { getSizeOf = return . obj . abs } +instance Sizeable Rational where { getSizeOf = return . obj . abs } +instance Sizeable Complex where { getSizeOf = return . obj . magnitude } +instance Sizeable UStr where { getSizeOf = return . obj . ulength } +instance Sizeable [Object] where { getSizeOf = return . obj . length } +instance Sizeable (M.Map Name Object) where { getSizeOf = return . obj . M.size } +instance Sizeable (H.HashMap Object Object) where { getSizeOf = return . obj . H.size } +instance Sizeable Hata where { getSizeOf (Hata ifc o) = maybe mzero ($ o) (objSizer ifc) } + +instance Sizeable Object where + getSizeOf o = case o of + OChar o -> getSizeOf o + OWord o -> getSizeOf o + OInt o -> getSizeOf o + OLong o -> getSizeOf o + ORelTime o -> getSizeOf o + OFloat o -> getSizeOf o + ORatio o -> getSizeOf o + OComplex o -> getSizeOf o + OString o -> getSizeOf o + OList o -> getSizeOf o + ODict o -> getSizeOf o + OHaskell o -> getSizeOf o + _ -> mzero + +---------------------------------------------------------------------------------------------------- + +-- $Building_structs +-- Here are all the basic functions for converting between Haskell language data types and Dao +-- language structures. +-- +-- Most 'FromDaoStruct' functions will backtrack when they fail to get the necessary data. This +-- function can make a backtracking function fail. For example: +-- > 'tryField' "x" >>= 'objType' +-- backtracks in any case +-- +-- > required (tryField "x" >>= objType) +-- > tryField "x" >>= required objType +-- These two forms do the same thing: fails if 'objType' backtracks, but not if the field doesn't +-- exist. +-- +-- > 'Control.Applicative.optional' ('tryField' "x" >>= 'objType') +-- returns 'Prelude.Nothing' if the field does not exist or if 'objType' backtracks +-- +-- > 'field' "x" >>= 'objType' +-- fails if the field does not exist, backtracks if it exists but is the wrong type +-- (you probably don't ever want to do this). +-- +-- > 'required' ('field' "x" >>= 'objType') +-- > 'field' "x" >>= 'required' 'objType' +-- These two forms are the same: fails if either the field does not exist or if 'objType' +-- backtracks. + +-- | This is the data type used as the intermediary between Haskell objects and Dao objects. If you +-- would like your Haskell data type to be used as a non-opaque data type in a Dao language script, +-- the first step is to instantiate your data type into this class. The next step would be to +-- instantiate your object into the 'HataClass' class. Instantiating the +-- 'HataClass' class alone will make your object usable in Dao language scripts, but +-- it will be an opaque type. Instantiating 'Struct' and declaring 'autoDefStruct' in the +-- 'defObjectInterface' will allow functions in the Dao language script to read and write +-- information to your data structure, modifying it during runtime. +-- +-- 'Struct' values are used lazily, so your data types will only be converted to and from 'Struct's +-- when absolutely necessary. This helps to conserver memory usage. +data Struct + = Nullary{ structName :: Name } + -- ^ models a constructor with no fields, for example 'Prelude.EQ', 'Prelude.GT' and + -- 'Prelude.LT'. + | Struct + { structName :: Name -- ^ provide the name for this constructor. + , fieldMap :: M.Map Name Object + } + deriving (Eq, Ord, Show, Typeable) + +structLookup :: Name -> Struct -> Maybe Object +structLookup name struct = case struct of + Nullary{} -> Nothing + Struct{ fieldMap=m } -> M.lookup name m + +instance NFData Struct where + rnf (Nullary a ) = deepseq a () + rnf (Struct a b) = deepseq a $! deepseq b () + +instance HasNullValue Struct where + nullValue = Nullary{ structName=ustr "NULL" } + testNull (Nullary{ structName=name }) = name == ustr "NULL" + testNull _ = False + +-- binary 0x25 0x26 +instance B.Binary Struct MTab where + put o = case o of + Nullary o -> B.putWord8 0x25 >> B.put o + Struct n o -> B.putWord8 0x26 >> B.put n >> B.put o + get = B.word8PrefixTable <|> fail "expecting Struct" + +instance B.HasPrefixTable Struct B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "Struct" 0x25 0x26 $ + [ Nullary <$> B.get + , return Struct <*> B.get <*> B.get + ] + +instance PPrintable Struct where + pPrint o = case o of + Nullary{ structName=name } -> pString ('#' : uchars (toUStr name)) + Struct{ structName=name, fieldMap=dict } -> + pList (pString ('#' : uchars (toUStr name))) "{" ", " "}" $ + flip map (M.assocs dict) $ \ (left, right) -> pInline $ + [pPrint left, pString " = ", pPrint right] + +instance HasRandGen Struct where + randO = _randTrace "Struct" $ countNode $ runRandChoice + randChoice = randChoiceList $ + [ scramble $ + return Struct <*> randO <*> (M.fromList <$> randListOf 1 4 (pure (,) <*> randO <*> randO)) + , Nullary <$> randO + ] + defaultO = _randTrace "D.Struct" $ Nullary <$> defaultO + +instance ToDaoStructClass Struct where { toDaoStruct = return () } + +instance FromDaoStructClass Struct where { fromDaoStruct = FromDaoStruct $ lift get } + +instance HataClass Struct where + haskellDataInterface = interface "Struct" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +-- | You can make your data type readable but not writable in the Dao runtime. That means a Dao +-- script can inspect elements of your data type, but not modify them As an example lets say you +-- have a 3D-point data type you would like to use in your Dao script. +-- > data Finite = +-- > Point2D{ get_x::'T_float', get_y::'T_float' } +-- > | Point3D{ get_x::'T_float', get_y::'T_float', get_z::'T_float' } +-- +-- Lets say you have already instantiated the 'HataClass' class and provided the Dao runtime with +-- a 'DaoFunc' (via 'setupDao') that constructs a Point3D at runtime: +-- > p = Point3D(1.9, 4.4, -2.1); +-- Now you would like to extend the 'HataClass' of your Point3D to also be readable at runtime. +-- If you instantiate 'ToDaoStructClass' your Dao language script could also read elements from the +-- point like so: +-- > distFromOrigin = sqrt(p.x*p.x + p.y*p.y + p.z*p.z); +-- However you cannot modify the point unless you also instantiate 'FromDaoStructClass'. So a statement +-- like this would result in an error: +-- > p.x /= distFromOrigin; +-- > p.y /= distFromOrigin; +-- > p.z /= distFromOrigin; +-- +-- You can convert this to a 'Struct' type using the 'fromData' function. There are many ways to +-- define fields in a 'Struct', here are a few: +-- > instance 'ToDaoStructClass' Point3D 'Object' where +-- > 'toDaoStruct' = 'fromData' "@Point2D@" $ do +-- > 'putPrimField' "x" get_x +-- > 'putPrimField' "y" get_y +-- > obj <- 'Control.Monad.Reader.Class.ask' +-- > case obj of +-- > Point3D _ _ z -> 'renameConstructor' "@Point3D@" $ do +-- > 'define' "z" ('obj' z) +-- > _ -> return () +-- +-- Finally, you should define the instantiation of Point3D into the 'HataClass' class so it +-- includes the directive 'autoDefToStruct'. +class ToDaoStructClass haskData where { toDaoStruct :: ToDaoStruct haskData () } + +-- | Continuing the example from above, if you do want your data type to be modifyable by functions +-- running in the Dao language runtime, you must instantiate this class, which is facilitated by the +-- 'toData' function. +-- > instance 'FromDaoStructClass' 'Point3D' where +-- > fromDaoStruct = 'toData' $ 'Control.Monad.msum' $ +-- > [ do 'constructor' "@Point2D@" +-- > return Point3D 'Control.Applicative.<*>' 'req' "x" 'Control.Applicative.<*>' 'req' "y" +-- > , do 'constructor' "@Point3D@" +-- > return Point3D 'Control.Applicative.<*>' 'req' "x" 'Control.Applicative.<*>' 'req' "y" 'Control.Applicative.<*>' 'req' "z" +-- > ] +-- +-- Do not forget to define the instantiation of Point3D into the 'HataClass' class so it +-- includes the directive 'autoDefFromStruct'. +-- +-- Note that an instance of 'FromDaoStructClass' must also instantiate 'ToDaoStructClass'. I can see no +-- use for objects that are only writable, that is they can be created at runtime but never +-- inspected at runtime. +class ToDaoStructClass haskData => FromDaoStructClass haskData where + fromDaoStruct :: FromDaoStruct haskData + +-- | If there is ever an error converting to or from your Haskell data type, you can +-- 'Control.Monad.Error.throwError' a 'StructError'. +data StructError + = StructError + { structErrName :: Maybe UStr + , structErrField :: Maybe UStr + , structErrValue :: Maybe Object + , structErrExtras :: [Name] + } + deriving (Eq, Ord, Typeable) + +instance PPrintable StructError where + pPrint err = do + let pp p msg f = case f err of + Nothing -> return () + Just o -> pString (msg++": ") >> p o >> pNewLine + pp pUStr "on constructor" structErrName + pp pUStr "on field" structErrField + pp pPrint "with value" structErrValue + let extras = structErrExtras err + if null extras then return () else pString ("non-member fields: "++show extras) + +instance HasNullValue StructError where + nullValue = + StructError + { structErrName=Nothing + , structErrField=Nothing + , structErrValue=Nothing + , structErrExtras=[] + } + testNull + ( StructError + { structErrName=Nothing + , structErrField=Nothing + , structErrValue=Nothing + , structErrExtras=[] + } + ) = True + testNull _ = False + +pPrintStructForm :: ToDaoStructClass o => o -> PPrint +pPrintStructForm o = case fromData toDaoStruct o of + PFail err -> pPrint err + Backtrack -> pString "(### FAILED TO CONVERT OBJECT TO STRUCT ###)" + OK struct -> pPrint struct + +---------------------------------------------------------------------------------------------------- + +-- Used to instantiate 'MonadError.throwError' by both the 'ToDaoStruct' and 'FromDaoStruct' monads. +_structThrowError + :: (MonadError ExecControl m) + => (forall a . PredicateT ExecControl (State st) a -> m a) -> (st -> Struct) -> ExecControl -> m b +_structThrowError constr inside err = + constr (lift $ gets inside) >>= \struct -> constr $ throwError $ case err of + ExecError{execErrorSubtype = ExecStructError info} -> + err { execErrorSubtype = ExecStructError $ + info{ structErrName = structErrName info <|> Just (toUStr $ structName struct) } } + err -> err + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass StructError where + toDaoStruct = renameConstructor "StructError" $ do + asks structErrName >>= optionalField "structName" . fmap OString + asks structErrField >>= optionalField "field" . fmap OString + asks structErrValue >>= optionalField "value" + asks structErrExtras >>= optionalField "extras" . fmap obj . refNames + +instance ToDaoStructClass (ParseError () DaoTT) where + toDaoStruct = renameConstructor "ParseError" $ do + asks parseErrMsg >>= ("message" .=?) + asks parseErrMsg >>= ("onToken" .=?) . fmap show + asks parseErrLoc >>= putLocation + +instance FromDaoStructClass StructError where + fromDaoStruct = do + constructor "StructError" + let str o = case o of + OString o -> return o + _ -> fail "expecting string value" + let ref o = case o of + ORef o -> case o of + Reference UNQUAL o NullRef -> return o + _ -> fail "not an unqualified reference singleton" + _ -> fail "not a reference type" + let lst o = case o of + OList o -> forM o ref + _ -> fail "expecting list value" + return StructError + <*> optional (tryField "structName" $ str) + <*> optional (tryField "field" $ str) + <*> optional (tryField "value" return) + <*> (tryField "extras" $ lst) + +instance ToDaoStructClass Comment where + toDaoStruct = ask >>= \co -> case co of + InlineComment o -> renameConstructor "InlineComment" $ "comment" .= o + EndlineComment o -> renameConstructor "EndlineComment" $ "comment" .= o + +instance FromDaoStructClass Comment where + fromDaoStruct = msum $ + [ constructor "InlineComment" >> InlineComment <$> req "comment" + , constructor "EndlineComment" >> EndlineComment <$> req "comment" + ] + +instance ToDaoStructClass AST_DotName where + toDaoStruct = renameConstructor "DotName" $ ask >>= \ (AST_DotName coms n) -> case coms of + Com () -> "name" .= n + coms -> "comments" .= coms >> "name" .= n + +instance FromDaoStructClass AST_DotName where + fromDaoStruct = constructor "DotName" >> + return AST_DotName <*> (maybe (Com ()) id <$> opt "comments") <*> req "name" + +instance ToDaoStructClass AST_DotLabel where + toDaoStruct = renameConstructor "DotLabel" $ do + (AST_DotLabel n nx loc) <- ask + "head" .= n + "tail" .= OList (map obj nx) + putLocation loc + +instance FromDaoStructClass AST_DotLabel where + fromDaoStruct = do + constructor "DotLabel" + let convert o = case sequence (map fromObj o) of + Nothing -> fail "\"tail\" field must contain a list of \"#DotName\" data types." + Just ox -> return ox + return AST_DotLabel <*> req "head" <*> (req "tail" >>= convert) <*> location + +instance ObjectClass StructError where { obj=new; fromObj=objFromHata; } + +instance HataClass StructError where + haskellDataInterface = interface "StructError" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest + autoDefToStruct >> autoDefFromStruct + +-- | Used to convert a 'Prelude.String' to a 'Dao.String.Name' by functions like 'define' and +-- 'setField'. Usually you will not need to use it. +mkLabel :: (UStrType name, MonadPlus m) => name -> m Name +mkLabel name = xmaybe $ maybeFromUStr (toUStr name) + +mkStructName :: (UStrType name, MonadPlus m) => name -> m Name +mkStructName name = mplus (mkLabel name) $ fail "invalid constructor name" + +mkFieldName :: (UStrType name, MonadPlus m) => name -> m Name +mkFieldName name = mplus (mkLabel name) $ fail "invalid field name" + +-- | This is a handy monadic and 'Data.Functor.Applicative' interface for instantiating +-- 'toDaoStruct' in the 'ToDaoStructClass' class. +newtype ToDaoStruct haskData a + = ToDaoStruct + { _runToDaoStruct :: PredicateT ExecControl (State (Struct, haskData)) a } + deriving (Functor, Applicative, Alternative, MonadPlus) + +instance Monad (ToDaoStruct haskData) where + return = ToDaoStruct . return + m >>= f = ToDaoStruct $ _runToDaoStruct m >>= _runToDaoStruct . f + fail msg = execThrow msg (ExecStructError nullValue) [] + +instance MonadState Struct (ToDaoStruct haskData) where + state f = ToDaoStruct $ lift $ state $ \ (struct, haskData) -> + let (a, struct') = f struct in (a, (struct', haskData)) + +instance MonadReader haskData (ToDaoStruct haskData) where + ask = ToDaoStruct $ lift $ fmap snd get + local upd f = ToDaoStruct $ PredicateT $ do + haskData <- gets snd + modify (\ (struct, _) -> (struct, upd haskData)) + a <- runPredicateT $ _runToDaoStruct f + modify (\ (struct, _) -> (struct, haskData)) + return a + +instance MonadError ExecControl (ToDaoStruct haskData) where + throwError = _structThrowError ToDaoStruct fst + catchError f catch = ToDaoStruct $ catchError (_runToDaoStruct f) (_runToDaoStruct . catch) + +instance MonadPlusError ExecControl (ToDaoStruct haskData) where + catchPredicate = ToDaoStruct . catchPredicate . _runToDaoStruct + predicate = ToDaoStruct . predicate + +-- | This function is typically used to evaluate the instantiation of 'toDaoStruct'. It takes two +-- parameters: first a computation to convert your data type to the 'Struct' using the 'ToDaoStruct' +-- monad, and second the data type you want to convert. You can use functions like 'defineWith' and +-- 'setField' to build your 'ToDaoStruct' computation. For example, lets say you have a Haskell data +-- type called @mydat::MyData@ where @MyData@ instantiates 'ToDaoStruct', you can convert it to a +-- Dao 'Struct' like so: +-- > 'fromData' 'toDaoStruct' mydat +-- Notice how it reads similar to ordinary English, "convert from (Haskell) data to a Dao 'Struct'" +fromData + :: ToDaoStruct haskData x + -> haskData + -> Predicate ExecControl Struct +fromData pred hask = evalState (runPredicateT $ _runToDaoStruct $ pred >> get) $ + (Struct{ structName=nil, fieldMap=M.empty }, hask) + +toDaoStructExec :: ToDaoStruct typ x -> typ -> Exec Struct +toDaoStructExec toDaoStruct = (predicate :: Predicate ExecControl T_struct -> Exec T_struct) . + fmapPFail ((\o -> newError{ execReturnValue=Just o}) . new) . fromData toDaoStruct + +-- | Overwrite the current 'Struct' with a 'Struct' produced by a 'toDaoStruct' instance of a +-- different type. This is useful when instantiating a newtype or a data type constructor that +-- contains only one item (the "inner" item), and the data type of the inner item instantiates +-- 'ToDaoStructClass', you can simply use the instance of 'toDaoStruct' for that data type to +-- instantiate 'toDaoStruct' for the outer data type. Just be sure that the constructor name for the +-- inner type does not conflict with the constructor name for the outer data type. For example: +-- > data X = X1 { ... } | X2 { ... } +-- > instance 'DaoToStructClass' X 'Object' where { ... } +-- > data Y = Y1 { ... } | Y2 { ... } +-- > instance 'DaoToStructClass' Y 'Object' where { ... } +-- > +-- > newtype WrapX = WrapX { unwrapX :: X } +-- > instance 'DaoToStructClass' WrapX 'Object' where +-- > 'toDaoStruct' = 'Control.Monad.Reader.ask' >>= 'innerToStruct' . unwrapX +-- > +-- > data X_or_Y = Is_X { getX :: X } | Is_Y { getY :: Y } +-- > instance 'DaoToStructClass' X_or_Y 'Object' where +-- > 'toDaoStruct' = 'Control.Monad.Reader.ask' >>= \xy -> case xy of +-- > Is_X x -> 'innerToStruct' x +-- > Is_Y y -> 'innerToStruct' y +-- +-- The inverse of this operation in the 'FromDaoStructClass' is 'Prelude.fmap', or equivalently the +-- 'Control.Applicative.<$>' operator. Here is an example using 'Control.Applicative.<$>': +-- > instance 'FromDaoStructClass' WrapX 'Object' where +-- > 'fromDaoStruct' = WrapX <$> 'fromDaoStruct' +-- > +-- > instance 'FromDaoStructClass' X_or_Y 'Object' where +-- > 'fromDaoStruct' = Is_X <$> 'fromDaoStruct' <|> Is_Y <$> 'fromDaoStruct' +-- +-- Another way to do exactly the same thing as the example above is: +-- > instance 'FromDaoStructClass' WrapX 'Object' where +-- > 'fromDaoStruct' = 'Prelude.fmap' WrapX 'fromDaoStruct' +-- > +-- > instance 'FromDaoStructClass' X_or_Y 'Object' where +-- > 'fromDaoStruct' = 'Prelude.fmap' Is_X 'fromDaoStruct' `'Control.Monad.mplus'` 'Prelude.fmap' Is_Y 'fromDaoStruct' +-- +-- It is possible to use 'renameConstructor' after evaluating 'innerToStruct' to use a different +-- constructor name while keeping all of the fields set by the evaluation of 'innerToStruct', +-- however if this is done, 'Prelude.fmap' will backtrack, so you should use 'innerFromStruct' +-- instead. +innerToStruct :: ToDaoStructClass inner => inner -> ToDaoStruct haskData () +innerToStruct = innerToStructWith toDaoStruct + +-- | Like 'innerToStruct' but lets you supply a 'ToDaoStruct' function for an arbitrary data type, +-- not just one that instantiates 'ToDaoStructClass'. +innerToStructWith :: ToDaoStruct inner () -> inner -> ToDaoStruct haskData () +innerToStructWith toDaoStruct o = ask >>= \haskData -> + predicate (fromData toDaoStruct o) >>= ToDaoStruct . lift . put . flip (,) haskData + +fmapHaskDataToStruct :: (haskData -> dyn) -> (dyn -> haskData) -> ToDaoStruct haskData a -> ToDaoStruct dyn a +fmapHaskDataToStruct to from (ToDaoStruct (PredicateT f)) = + ToDaoStruct $ PredicateT $ state $ fmap (fmap to) . runState f . fmap from + +-- | Use this function to set the 'structName' name of the constructor at some point, for example +-- when you observe some condition of the @haskData@ type that merits an alternative constructor +-- name. +renameConstructor :: UStrType name => name -> ToDaoStruct haskData ig -> ToDaoStruct haskData () +renameConstructor name f = do + name <- mkStructName name + modify $ \struct -> struct{ structName=name } + void f + +-- | Like 'renameConstructor' but deletes everything and makes the 'Struct' being constructed into a +-- 'Nullary'. You would typically do this only when you are instantiating 'toDaoStruct' and you +-- only have one constructor to define. +makeNullary :: UStrType name => name -> ToDaoStruct haskData () +makeNullary name = mkStructName name >>= \name -> put $ Nullary{ structName=name } + +-- | Use this when you have derived the "Prelude.Show" class for a data type where every constructor +-- in that data type takes no parameters, for example, the 'Prelude.Ordering' data type. +putNullaryUsingShow :: Show haskData => ToDaoStruct haskData () +putNullaryUsingShow = ask >>= makeNullary . show + +define :: UStrType name => name -> Object -> ToDaoStruct haskData Object +define name value = do + name <- mkFieldName name + modify $ \struct -> struct{ fieldMap = M.insert name value (fieldMap struct) } + return value + +-- | Defines an optional field. If the value given is 'Prelude.Nothing', nothing happens. Otherwise +-- the value is placed into the 'Struct' at the given @name@d field. This is the inverse opreation +-- of using 'Control.Applicative.optional' in the 'FromDaoStruct' monad. +optionalField :: UStrType name => name -> Maybe Object -> ToDaoStruct haskData (Maybe Object) +optionalField name = maybe (return Nothing) (fmap Just . define name) + +setField :: UStrType name => name -> (haskData -> Object) -> ToDaoStruct haskData Object +setField name f = ask >>= define name . f + +-- | This is an important function for instantiating 'ToDaoStructClass'. It takes any +-- value instantiating 'HataClass', converts it to an 'Object' using the 'new' +-- function. It is the inverse of 'objType'. +-- +-- It is recommended you use this function instead of 'defStructField', 'defPrimField', or +-- 'defDynField' whenever it is possible, i.e. whenever the data type you are putting instantiated +-- the 'HataClass' class. +defObjField + :: (UStrType name, Typeable o, ObjectClass o) + => name -> o -> ToDaoStruct haskData Object +defObjField name o = define name (obj o) + +-- | Synonym for 'defObjField' +(.=) :: (UStrType name, Typeable o, ObjectClass o) => name -> o -> ToDaoStruct haskData Object +(.=) = defObjField +infixr 2 .= + +-- | Like 'defObjField' but takes a field accessor to extract the data to be stored from the object +-- being converted. This function is defined as: +-- > \name accessor -> asks accessor >>= defObjField name +putObjField + :: (UStrType name, Typeable o, ObjectClass o) + => name -> (haskData -> o) -> ToDaoStruct haskData Object +putObjField name which = asks which >>= defObjField name + +-- | Synonym for 'putObjField' +(.=@) + :: (UStrType name, Typeable o, ObjectClass o) + => name -> (haskData -> o) -> ToDaoStruct haskData Object +(.=@) = putObjField +infixr 2 .=@ + +-- | Like 'putObjField' but operates on an object wrapped in a 'Prelude.Maybe', not doing anything +-- in the case of 'Prelude.Nothing'. +defMaybeObjField + :: (UStrType name, Typeable o, ObjectClass o) + => name -> Maybe o -> ToDaoStruct haskData (Maybe Object) +defMaybeObjField name = maybe (return Nothing) (fmap Just . defObjField name) + +(.=?) + :: (UStrType name, Typeable o, ObjectClass o) + => name -> Maybe o -> ToDaoStruct haskData (Maybe Object) +(.=?) = defMaybeObjField + +---------------------------------------------------------------------------------------------------- + +-- | This is a handy monadic and 'Data.Functor.Applicative' interface for instantiating +-- 'fromDaoStruct' in the 'FromDaoStructClass' class. It takes the form of a reader because what you +-- /read/ from the 'Struct' here in the Haskell language was /written/ by the Dao language +-- runtime. Think of it as "this is the data type used when the Dao runtime wants to write +-- information to my data structure." +-- +-- Because Dao is such a messy, fuzzy, not statically typed, interpreted language, the information +-- coming in from the Dao runtime requires a lot of sanitization. Therefore this monad provides +-- several functions for checking the type of information you are using to build your Haskell data +-- type. +-- +-- Be sure to make ample use of the 'Control.Monad.guard', 'Control.Monad.Error.throwError', and +-- 'Control.Monad.fail' functions. +-- +-- /NOTE:/ refer to the documentation of the 'constructor' monad for an important note on reading +-- Haskell data types with multiple constructors. +newtype FromDaoStruct a = + FromDaoStruct{ _runFromDaoStruct :: PredicateT ExecControl (State Struct) a } + deriving (Functor, Applicative, Alternative, MonadPlus) + +instance Monad FromDaoStruct where + return = FromDaoStruct . return + m >>= f = FromDaoStruct $ _runFromDaoStruct m >>= _runFromDaoStruct . f + fail msg = FromDaoStruct (lift $ gets structName) >>= \name -> + execThrow msg (ExecStructError $ nullValue{ structErrName = Just $ toUStr name }) [] + +instance MonadReader Struct FromDaoStruct where + ask = FromDaoStruct $ lift get + local upd f = FromDaoStruct $ PredicateT $ get >>= \st -> + return $ evalState (runPredicateT $ _runFromDaoStruct f) (upd st) + +instance MonadError ExecControl FromDaoStruct where + throwError = _structThrowError FromDaoStruct id + catchError (FromDaoStruct f) catch = FromDaoStruct $ catchError f (_runFromDaoStruct . catch) + +instance MonadPlusError ExecControl FromDaoStruct where + catchPredicate = FromDaoStruct . catchPredicate . _runFromDaoStruct + predicate = FromDaoStruct . predicate + +-- | This function is typically used to evaluate the instantiation of 'fromDaoStruct'. It takes two +-- parameters: first a computation to convert your data type to the Haskell data type from a +-- 'Struct' using the 'FromDaoStruct' monad, and second the 'Struct' you want to convert. For +-- example, if you have a Haskell data type 'MyData' which instantiates 'FromDaoStruct', you could +-- construct it from a properly formatted Dao 'Struct' using this statement: +-- > 'toData' 'fromDaoStruct' struct +-- Notice that this reads similar to ordinary English: "convert to (Haskell) data from a dao +-- struct." +toData :: FromDaoStruct haskData -> Struct -> Predicate ExecControl haskData +toData f = evalState (runPredicateT $ _runFromDaoStruct $ f >>= \o -> checkEmpty >> return o) + +-- | Using a 'FromDaoStruct' monadic function, convert a given 'Struct' to a Haskell data type +-- @typ@. +withFromDaoStructExec :: FromDaoStruct typ -> Struct -> Exec typ +withFromDaoStructExec fromDaoStruct = + predicate . fmapPFail ((\o -> newError{ execReturnValue=Just o }) . new) . toData fromDaoStruct + +-- | Given a 'Struct', use the 'structName' to lookup a 'FromDaoStruct' monadic function in the +-- current 'ExecUnit' suitable for constructing a 'Hata' Haskell data type. +fromDaoStructExec :: Struct -> Exec Hata +fromDaoStructExec struct = do + let name = structName struct + (MethodTable mtab) <- gets globalMethodTable + let badType msg = execThrow msg (ExecTypeError $ objTypeFromName name) [] + case M.lookup (structName struct) mtab of + Nothing -> badType "no available built-in data type" + Just ifc -> case objFromStruct ifc of + Nothing -> badType "data type cannot be constructed from hashed structure" + Just from -> Hata ifc <$> withFromDaoStructExec from struct + +-- | Checks if the 'structName' is equal to the given name, and if not then backtracks. This is +-- important when constructing Haskell data types with multiple constructors. +-- +-- A haskell data type with multiple constructors should be constructed with the +-- 'Control.Monad.msum' function like so: +-- > data MyData = A | B Int | C Int Int +-- > instance 'FromDaoStruct' ('Object) where +-- > 'fromDaoStruct' = 'toData' $ 'Control.Monad.msum' $ +-- > [ 'constructor' "A" >> return a, +-- > do 'constructor' "B" +-- > B 'Control.Applicative.<$>' ('field' "b1" >>= 'primType') +-- > do 'constructor' "C" +-- > 'Control.Applicative.return' C +-- > 'Control.Applicative.<*>' 'required' ('field' "c1" >>= 'primType') +-- > 'Control.Applicative.<*>' 'required' ('field' "c2" >>= 'primType') +-- > ] +-- /NOTE/ that if all three 'constructor's backtrack (evaluate to 'Control.Monad.mzero') the whole +-- monad will backtrack. By convention, you should let the monad backtrack, rather than writing a +-- 'Control.Monad.fail' statement as the final item in the 'Control.Monad.msum' list. +constructor :: UStrType name => name -> FromDaoStruct () +constructor name = (return (==) <*> mkStructName name <*> asks structName) >>= guard + +-- | The inverse operation of 'innerToStruct', but looks for a constructor of a different name. This +-- is important because every 'toDaoStruct' should set it's own unique constructor name, and if you +-- set a different constructor name while using the same 'fromDaoStruct' function to read the fields +-- of the struct, the 'fromDaoStruct' function will backtrack seeing the wrong constructor name. +-- If you have not renamed the constructor with 'renameConstructor' after using 'innerToStruct', do +-- not use this function, simply use 'Prelude.fmap' or the 'Control.Applicative.<$>' operator +-- instead. +-- +-- This function temporarily changes the constructor name to the constructor set by the @inner@ +-- type, that way the 'fromDaoStruct' instance of the @inner@ type will be fooled and read the +-- 'Struct' fields without backtracking. For example: +-- > newtype X = X{ getX :: Int } +-- > instance 'ToDataStruct' X where +-- > 'toDaoStruct' = do +-- > 'renameConstructor' "X" +-- > "getX" '.=@' getX +-- > +-- > newtype Y = Y{ innerX :: X } +-- > instance 'ToDataStruct' Y where +-- > 'toDaoStruct' = do +-- > -- the 'innerToStruct' function will use the 'toDaoStruct' for X +-- > 'Control.Monad.Reader.ask' >>= 'innerToStruct' . innerX +-- > -- then rename the constructor from "X" to "Y" +-- > 'renameConstructor' "Y" +-- > +-- Now when we want to define the accompanying 'FromDaoStructClass', we need to remember that we +-- used 'innerToStruct' and changed the 'structName' from "X" to "Y". Simply using 'Prelude.fmap' +-- (or equivalently 'Control.Applicative.<$>') will not work because the instance of 'fromDaoStruct' +-- for the @X@ data type will backtrack when it sees the 'structName' is "Y". +-- > instance 'FromDaoStructClass' Y where +-- > 'fromDaoStruct' = Y 'Control.Applicative.<$>' 'fromDaoStruct' -- /WRONG!/ This will always backtrack. +-- +-- The correct way to do it is to use 'innerFromStruct' like so: +-- > instance 'FromDaoStructClass' Y where +-- > 'fromDaoStruct' = Y 'Control.Applicative.<$> 'innerFromStruct' "X" -- CORRECT! +-- +innerFromStruct :: (UStrType name, FromDaoStructClass inner) => name -> FromDaoStruct inner +innerFromStruct tempName = do + name <- asks structName + tempName <- mkStructName tempName + let setname name = FromDaoStruct $ lift $ modify $ \struct -> struct{ structName=name } + o <- setname tempName >> mplus fromDaoStruct (setname name >> mzero) + setname name >> return o + +-- | Succeeds if the current 'Struct' is a 'Nullary' where the 'structName' is equal to the name +-- given to this function. +nullary :: UStrType name => name -> FromDaoStruct () +nullary name = ask >>= \struct -> case struct of + Nullary{} -> constructor name + _ -> mzero + +-- | Use the instantiation of 'Prelude.Read' derived for a type @haskData@ to construct the +-- @haskData from the 'structName' stored in a 'Nullary' 'Struct'. +getNullaryWithRead :: Read haskData => FromDaoStruct haskData +getNullaryWithRead = ask >>= \struct -> case struct of + Nullary{ structName=name } -> case readsPrec 0 (uchars name) of + [(haskData, "")] -> return haskData + _ -> mzero + _ -> mzero + +-- | If an error is thrown using 'Control.Monad.Error.throwError' or 'Control.Monad.fail' within the +-- given 'FromDaoStruct' function, the 'structErrField' will automatically be set to the provided +-- 'Name' value. +structCurrentField :: Name -> FromDaoStruct o -> FromDaoStruct o +structCurrentField name (FromDaoStruct f) = FromDaoStruct $ catchPredicate f >>= \o -> case o of + PFail (err@(ExecError{execErrorSubtype=ExecStructError info})) -> throwError $ + err{ execErrorSubtype = ExecStructError $ info{ structErrField = Just (toUStr name) } } + PFail err -> throwError err + OK o -> return o + Backtrack -> mzero + +-- | Retrieves an arbitrary 'Object' by it's field name, and backtraks if no such field is defined. +-- The value of the field is copied, and can be copied again after this operation. It is best not to +-- use this function, rather use 'tryField' to make sure each field is retrieved exactly once, then +-- use 'checkEmpty' to make sure there is no hidden extraneous data in the struct. +tryCopyField :: UStrType name => name -> (Object -> FromDaoStruct o) -> FromDaoStruct o +tryCopyField name f = (return M.lookup <*> mkFieldName name <*> asks fieldMap) >>= + xmaybe >>= structCurrentField (fromUStr $ toUStr name) . f + +-- | Like 'copyField', retrieves an arbitrary 'Object' by it's field name, and backtraks if no such +-- field is defined. However unlike 'tryCopyField', if the item is retrieved, it is deleted from the +-- inner 'Struct' so that it may not be used again. The reason for this is to use 'checkEmpty' and +-- 'requireEmpty', which can backtrack or fail if there are extraneous fields in the structure. +tryField :: UStrType name => name -> (Object -> FromDaoStruct o) -> FromDaoStruct o +tryField name f = do + name <- mkFieldName name + o <- tryCopyField name f + FromDaoStruct $ lift $ modify $ \st -> + case st of{ Struct{ fieldMap=m } -> st{ fieldMap=M.delete name m }; s -> s; } + return o + +_throwMissingFieldError :: Name -> FromDaoStruct o +_throwMissingFieldError name = throwError $ + newError{ execErrorSubtype = ExecStructError $ nullValue{ structErrField = Just $ toUStr name } } + +-- | Like 'field' but evaluates 'Control.Monad.Error.throwError' if the 'FromDaoStruct' function +-- backtracks or throws it's own error. Internally, this function makes use of 'copyField' and /not/ +-- 'tryField', so the field is preserved if it exists. +copyField :: UStrType name => name -> (Object -> FromDaoStruct o) -> FromDaoStruct o +copyField name f = mkFieldName name >>= \name -> + mplus (tryCopyField name f) (_throwMissingFieldError name) + +-- | Like 'field' but evaluates 'Control.Monad.Error.throwError' if the 'FromDaoStruct' function +-- backtracks or throws it's own error. Internally, this function makes use of 'tryField' and /not/ +-- 'tryCopyField', so the field is removed if it exists -- two consecutive calls to this function +-- with the same key absolutely will fail. +field :: UStrType name => name -> (Object -> FromDaoStruct o) -> FromDaoStruct o +field name f = mkFieldName name >>= \name -> mplus (tryField name f) (_throwMissingFieldError name) + +-- As you make calls to 'field' and 'tryField', the items in these fields in the 'Struct' are +-- being removed. Once you have all of the nata neccessary to construct the data 'Object', you can +-- check to make sure there are no extraneous unused data fields. If the 'Struct' is empty, this +-- function evaluates to @return ()@. If there are extranous fields in the 'Struct', 'throwError' is +-- evaluated. It is highly recommended that this function always be used as the last function +-- evaluated in the 'FromDaoStruct' monadic function. +checkEmpty :: FromDaoStruct () +checkEmpty = FromDaoStruct (lift get) >>= \st -> case st of + Struct{ fieldMap=m } -> when (not $ M.null m) $ + execThrow "assigned to non-member fields of structure" + (ExecStructError $ nullValue{ structErrExtras = M.keys m }) [] + Nullary{} -> return () + +-- | Takes a conversion as the first parameter. The second parameter will be provided by 'field' or +-- 'tryField' when you pass it as a partial function application. If the conversion function +-- backtracks, 'Control.Monad.Error.throwError' is evaluated with the appropriate error data set. +-- This function should usually not be required, as it is called by functions like 'opt', 'req', and +-- 'reqList'. +convertFieldData :: (Object -> FromDaoStruct o) -> Object -> FromDaoStruct o +convertFieldData f o = mplus (f o) $ throwError $ + newError{ execErrorSubtype = ExecStructError $ nullValue{ structErrValue=Just o } } + +-- | A required 'Struct' 'field'. This function is defined as +req :: (UStrType name, Typeable o, ObjectClass o) => name -> FromDaoStruct o +req name = field name (convertFieldData (xmaybe . fromObj)) + +-- | Check if a 'Struct' field exists using 'tryField', if it exists, convert it to the necessary +-- data type using 'fromObj' (which fails if an unexpected type is stored in that field). +opt :: (UStrType name, Typeable o, ObjectClass o) => name -> FromDaoStruct (Maybe o) +opt name = Just <$> tryField name (convertFieldData (xmaybe . fromObj)) <|> return Nothing + +-- | Like 'req' but internally uses 'listFromObj' instead of 'fromObj'. The field must exist, if it +-- does not this function evaluates to 'Control.Monad.Error.throwError'. Use 'optList' instead if +-- you can accept an empty list when the field is not defined. +reqList :: (UStrType name, Typeable o, ObjectClass o) => name -> FromDaoStruct [o] +reqList name = field name $ convertFieldData (xmaybe . listFromObj) + +-- | Like 'opt' but internally uses 'listFromObj' instead of 'fromObj'. The field may not exist, and +-- if it does not this function returns an empty list. Use 'reqList' to evaluate to +-- 'Control.Monad.Error.throwError' in the case the field does not exist. +optList :: (UStrType name, Typeable o, ObjectClass o) => name -> FromDaoStruct [o] +optList name = tryField name $ convertFieldData (maybe (return []) return . listFromObj) + +---------------------------------------------------------------------------------------------------- + +builtin_toStruct :: DaoFunc () +builtin_toStruct = + daoFunc + { daoForeignFunc = \ () ox -> do + let qref = reference UNQUAL (ustr "toStruct") + let wrongTypeErr o = throwBadTypeError "cannot convert to a struct from object of the given type" o [] + case ox of + [o] -> case o of + OTree _ -> return (Just o, ()) + OHaskell (Hata ifc d) -> case objToStruct ifc of + Just to -> flip (,) () . Just . obj <$> toDaoStructExec to d + Nothing -> wrongTypeErr o + o -> wrongTypeErr o + ox -> throwArityError "" 1 ox [(errInFunc, obj qref)] + } + +builtin_fromStruct :: DaoFunc () +builtin_fromStruct = + daoFunc + { daoForeignFunc = \ () ox -> do + let qref = reference UNQUAL (ustr "fromStruct") + case ox of + [o] -> case o of + OTree o -> flip (,) () . Just . OHaskell <$> fromDaoStructExec o + o -> throwBadTypeError "argument parameter is not a struct data type" o [] + ox -> throwArityError "" 1 ox [(errInFunc, obj qref)] + } + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass Location where + toDaoStruct = ask >>= \lo -> case lo of + LocationUnknown -> makeNullary "NoLocation" + Location{} -> renameConstructor "Location" $ do + "startingLine" .=@ startingLine + "startingColumn" .=@ startingColumn + "endingLine" .=@ endingLine + "endingColumn" .=@ endingColumn + +instance FromDaoStructClass Location where + fromDaoStruct = msum $ + [ nullary "NoLocation" >> return LocationUnknown + , do constructor "Location" + return Location + <*> req "startingLine" + <*> req "startingColumn" + <*> req "endingLine" + <*> req "endingColumn" + ] + +putLocation :: Location -> ToDaoStruct haskData () +putLocation loc = case loc of + LocationUnknown -> return () + Location{} -> void $ "location" .= loc + +location :: FromDaoStruct Location +location = opt "location" >>= maybe (return LocationUnknown) return + +putComments :: [Comment] -> ToDaoStruct haskData () +putComments = void . defObjField "comments" + +comments :: FromDaoStruct [Comment] +comments = req "comments" + +optComments :: FromDaoStruct (Maybe [Comment]) +optComments = opt "comments" + +instance HasRandGen Object where + randO = countNode $ recurse $ runRandChoice + randChoice = mappend (fmap unlimitObject defaultChoice) $ randChoiceList $ + [ ORef <$> randO + , depthLimitedInt 24 >>= \x -> + scramble $ OList <$> randList 0 x + , depthLimitedInt 24 >>= \x -> + scramble $ ODict . M.fromList <$> randListOf 0 x (return (,) <*> randO <*> randO) + , OType <$> randO + , OTree <$> randO + , ORatio <$> randO + , OComplex <$> randO + ] + defaultO = _randTrace "D.Object" runDefaultChoice + defaultChoice = randChoiceList $ + [ do i <- nextInt 10 -- OBytes + fmap (OBytes . B.concat) $ replicateM i $ + fmap (encode . (\i -> fromIntegral i :: Word32)) randInt + ] + +-- | This is a newtype of 'Object' with a specially defined instance for 'HasRandGen' that +-- guarantees the 'Object' values generated randomly can be pretty-printed an re-parsed back to the +-- exact same value, unambiguously. For example, the instance of 'HasRandGen' for 'LimitedObject' +-- will not produce any values of: +-- > 'Dao.Interpreter.OList' ['Dao.Interpreter.OInt' 1, 'Dao.Interpreter.OInt' 2, 'Dao.Interpreter.OInt' 3] +-- because this will be pretty-printed to "list {1,2,3}" and parsing that pretty printed object will +-- yield the data type: +-- > ('Dao.Interpreter.AST_Init' +-- > ('Dao.Interpreter.AST_DotLabel' ('Dao.String.Name' "list") [] 'Dao.Token.LocationUnknown') +-- > ('Dao.Interpreter.AST_OptObjList' [] 'Prelude.Nothing') +-- > ('Dao.Interpreter.AST_ObjList' [] +-- > [ 'Dao.Interpreter.Com' ('Dao.Interpreter.AST_Eval' ('Dao.Interpreter.AST_ObjArith' ('Dao.Interpreter.AST_Object' ('Dao.Interpreter.AST_ObjLiteral' (OInt 1 'Dao.Token.LocationUnknown'))))) +-- > , 'Dao.Interpreter.Com' ('Dao.Interpreter.AST_Eval' ('Dao.Interpreter.AST_ObjArith' ('Dao.Interpreter.AST_Object' ('Dao.Interpreter.AST_ObjLiteral' (OInt 2 'Dao.Token.LocationUnknown'))))) +-- > , 'Dao.Interpreter.Com' ('Dao.Interpreter.AST_Eval' ('Dao.Interpreter.AST_ObjArith' ('Dao.Interpreter.AST_Object' ('Dao.Interpreter.AST_ObjLiteral' (OInt 3 'Dao.Token.LocationUnknown'))))) +-- > ] +-- > ) +-- > ) +-- Obviously this is a completely different data structure than the data originally randomly +-- generated. If one were to evaluate it using 'Dao.Interpreter.execute', it would evaluate to the +-- originally generated random object value. But for simplicity the test suit does not evaluate +-- anything, it only compares the original randomly generated test object value to the object value +-- that was constructed by parsing the pretty printed form. +-- +-- Therefore, the only data structures that should be randomly generated for testing are the data +-- structures that pretty print to a form that can be parsed back to an identical value when +-- compared to the original. This limits the objects that can be generated to simple string and +-- integer literals, hence the name 'LimitedObject'. +newtype LimitedObject = LimitedObject { unlimitObject :: Object } deriving (Eq, Ord, Show) + +instance HasNullValue LimitedObject where + nullValue = LimitedObject nullValue + testNull (LimitedObject o) = testNull o + +instance HasRandGen LimitedObject where + randO = _randTrace "LimitedObject" $ countNode $ runRandChoice + randChoice = fmap LimitedObject $ randChoiceList $ + [ return ONull, return OTrue + , OInt <$> defaultO + , OWord <$> defaultO + , OLong <$> defaultO + , OFloat <$> defaultO + , OString <$> defaultO + , OAbsTime <$> defaultO + , ORelTime <$> defaultO + , OChar . chr . flip mod (ord(maxBound::Char)) <$> defaultO + ] + defaultO = randO + +---------------------------------------------------------------------------------------------------- + +-- | The 'Object' type extends the 'Data.Dynamic.Dynamic' data type with a few more constructors for +-- data types that are fundamental to a programming language, like integers, strings, and lists. +data Object + = ONull + | OTrue + | OChar T_char + | OInt T_int + | OWord T_word + | OLong T_long + | ORelTime T_diffTime + | OFloat T_float + | ORatio T_ratio + | OComplex T_complex + | OString T_string + | OBytes T_bytes + | OList T_list + | ODict T_dict + | ORef T_ref + | OType T_type + | OTree T_struct + | OAbsTime T_time + | OHaskell Hata + deriving (Eq, Ord, Typeable, Show) + +type T_char = Char +type T_int = Int +type T_word = Word64 +type T_long = Integer +type T_diffTime = NominalDiffTime +type T_float = Double +type T_ratio = Rational +type T_complex = Complex +type T_string = UStr +type T_bytes = B.ByteString +type T_list = [Object] +type T_dict = M.Map Name Object +type T_ref = Reference +type T_type = ObjType +type T_struct = Struct +type T_time = UTCTime + +instance NFData Object where + rnf ONull = () + rnf OTrue = () + rnf (OChar a) = deepseq a () + rnf (OInt a) = deepseq a () + rnf (OWord a) = deepseq a () + rnf (OLong a) = deepseq a () + rnf (ORelTime a) = deepseq a () + rnf (OFloat a) = deepseq a () + rnf (ORatio a) = deepseq a () + rnf (OComplex a) = deepseq a () + rnf (OString a) = deepseq a () + rnf (OBytes a) = seq a () + rnf (OList a) = deepseq a () + rnf (ODict a) = deepseq a () + rnf (ORef a) = deepseq a () + rnf (OType a) = deepseq a () + rnf (OTree a) = deepseq a () + rnf (OAbsTime a) = deepseq a () + rnf (OHaskell a) = deepseq a () + +instance Monoid (XPure Object) where + mempty = return ONull + mappend a b = a >>= \a -> b >>= \b -> case a of + ONull -> return b + OTrue -> case b of + OTrue -> return OTrue + _ -> mzero + a -> case b of + ONull -> return a + b -> xpure a + xpure b + +instance HasNullValue Object where + nullValue = ONull + testNull a = case a of + ONull -> True + OChar c -> testNull c + OInt i -> testNull i + OWord i -> testNull i + OLong i -> testNull i + OFloat f -> testNull f + ORelTime s -> testNull s + ORatio r -> testNull r + OComplex c -> testNull c + OString s -> testNull s + OBytes o -> testNull o + OList s -> testNull s + ODict m -> testNull m + OTree t -> testNull t + OHaskell o -> testNull o + _ -> False + +-- binary 0x08 0x1A Object-->CoreType +instance B.Binary Object MTab where + put o = do + let t = B.put (typeOfObj o) + p o = t >> B.put o + case o of + ONull -> t + OTrue -> t + OChar o -> p o + OInt o -> p o + OWord o -> p o + OLong o -> p o + ORelTime o -> p o + OFloat o -> p o + ORatio o -> p o + OComplex o -> p o + OString o -> p o + OBytes o -> p o + OList o -> t >> B.putUnwrapped o + ODict o -> p o + ORef o -> p o + OType o -> p o + OTree o -> p o + OAbsTime o -> p o + OHaskell o -> B.put o + get = B.word8PrefixTable <|> fail "expecting Object" + +instance B.HasPrefixTable Object B.Byte MTab where + prefixTable = + let g f = fmap f B.get + in mappend (OTree <$> B.prefixTable) $ B.mkPrefixTableWord8 "Object" 0x08 0x1A $ + [ return ONull + , return OTrue + , g OChar + , g OInt + , g OWord + , g OLong + , g ORelTime + , g OFloat + , g ORatio + , g OComplex + , g OString + , g OBytes + , OList <$> B.getUnwrapped + , g ODict + , g ORef + , g OType + , g OTree + , g OAbsTime + , mplus (OHaskell <$> B.get) + (B.get >>= \ (B.BlockStream1M bs1m) -> return (OBytes bs1m)) + ] + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass RefQualifier where { toDaoStruct=putNullaryUsingShow; } + +instance FromDaoStructClass RefQualifier where { fromDaoStruct=getNullaryWithRead; } + +instance ObjectClass RefQualifier where { obj=new; fromObj=objFromHata; } + +instance HataClass RefQualifier where + haskellDataInterface = interface "RefQualifier" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +data Reference + = Reference RefQualifier Name RefSuffix + | RefObject Object RefSuffix + | RefWrapper Reference + deriving (Eq, Ord, Typeable, Show) + +instance Monoid (XPure Reference) where + mempty = mzero + mappend a b = msum $ + [ a >>= \a -> b >>= \b -> case b of + Reference UNQUAL name suf -> let suf2 = DotRef name suf in case a of + Reference q name suf1 -> return $ Reference q name (suf1 <> suf2) + RefObject o suf1 -> return $ RefObject o (suf1 <> suf2) + RefWrapper a -> return a <> return b + _ -> execThrow + "only unqualified references can be appended to other references" + ExecErrorUntyped [(assertFailed, obj b)] + , a, b + ] + +instance Read Reference where + readsPrec _ str = loop [] (sp str) where + sp = dropWhile isSpace + loop rx str = do + (a, str) <- pure (span (\c -> isAlpha c || c=='_') str) + guard (not $ null a) + (ax, str) <- pure (span (\c -> isAlphaNum c || c=='_') str) + ax <- pure (fromUStr $ toUStr $ a++ax) + str <- pure (sp str) + case str of + '.':str -> loop (rx++[ax]) (sp str) + "" | not $ null rx -> [(Reference UNQUAL (head rx) $ refSuffixFromNames (tail $ rx++[ax]), "")] + "" -> [(Reference UNQUAL ax NullRef, "")] + _ -> error $ concat ["a=", show a, "ax=", show ax, "str=", show str] + +-- | Construct a 'Reference' with a 'RefQualifier' and a 'Name'. +reference :: RefQualifier -> Name -> Reference +reference q name = Reference q name NullRef + +-- | Construct a 'Reference' with an object. +refObject :: Object -> Reference +refObject = flip RefObject NullRef + +-- | Strip the 'RefSuffix' from the given 'Reference', changing it 'NullRef' and returning the +-- updated 'Referene' along with the 'RefSuffix' that was removed. If the 'Reference' is a +-- 'RefWrapper', nothing is changed. +referenceHead :: Reference -> (Reference, Maybe RefSuffix) +referenceHead qref = case qref of + Reference q name suf -> (Reference q name NullRef, Just suf) + RefObject o suf -> (RefObject o NullRef, Just suf) + RefWrapper r -> (RefWrapper r , Nothing ) + +-- | The 'Reference' data type has a 'RefWrapper' constructor which wraps a 'Reference' value, +-- protecting it from being de-referenced. This function unwraps the inner 'Reference' if it is +-- within a 'RefWrapper', or else returns the 'Reference' unchanged. +refUnwrap :: Reference -> Reference +refUnwrap r = case r of { RefWrapper r -> r; r -> r; } + +instance NFData Reference where + rnf (Reference q n r) = deepseq q $! deepseq n $! deepseq r () + rnf (RefObject o r ) = deepseq o $! deepseq r () + rnf (RefWrapper r ) = deepseq r () + +instance PPrintable Reference where + pPrint qref = case qref of + Reference q n r -> case q of + UNQUAL -> pInline [pPrint n, pPrint r] + q -> pInline [pPrint q, pString " ", pPrint n, pPrint r] + RefObject o r -> pInline [pString "(", pPrint o, pString ")", pPrint r] + RefWrapper r -> pInline [pString "$", pPrint r] + +-- binary 0x48 0x4E +instance B.Binary Reference MTab where + put qref = case qref of + Reference q n r -> prefix q $ B.put n >> B.put r where + prefix q = B.prefixByte $ case q of + { UNQUAL -> 0x48; LOCAL -> 0x49; CONST -> 0x4A; STATIC -> 0x4B; GLOBAL -> 0x4C; GLODOT -> 0x4D; } + RefObject o r -> B.prefixByte 0x4E $ B.put o >> B.put r + RefWrapper r -> B.prefixByte 0x4F $ B.put r + get = B.word8PrefixTable <|> fail "expecting Reference" + +instance B.HasPrefixTable Reference B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "Reference" 0x48 0x4F $ + [ f UNQUAL, f LOCAL, f CONST, f STATIC, f GLOBAL, f GLODOT + , return RefObject <*> B.get <*> B.get + , return RefWrapper <*> B.get + ] where { f q = return (Reference q) <*> B.get <*> B.get } + +instance HasRandGen Reference where + randO = _randTrace "Reference" $ recurse $ countNode $ runRandChoice + randChoice = randChoiceList $ + [ return Reference <*> randO <*> randO <*> randO + , return RefObject <*> scrambO <*> randO + , RefWrapper <$> scrambO + ] + defaultO = _randTrace "D.Reference" runDefaultChoice + defaultChoice = randChoiceList $ + [ return Reference <*> defaultO <*> defaultO <*> defaultO + , return RefObject <*> defaultO <*> defaultO + ] + +-- 'execute'-ing a 'Reference' will dereference it, essentially reading the value associated with +-- that reference from the 'ExecUnit'. +instance Executable Reference (Reference, Maybe Object) where { execute qref = referenceLookup qref } + +refAppendSuffix :: Reference -> RefSuffix -> Reference +refAppendSuffix qref appref = case qref of + Reference q name ref -> Reference q name (ref<>appref) + RefObject o ref -> RefObject o (ref<>appref) + RefWrapper qref -> RefWrapper $ refAppendSuffix qref appref + +-- | This is an important function used throughout most of the intepreter to lookup 'Object's +-- associated with 'Reference's. It returns a a pair containing updated copy of the given +-- 'Reference' and the 'Object' that was looked-up. The 'Reference' returned is a copy of the +-- 'Reference' parameter given but updated with information about where the reference was looked up. +-- For example, if you pass an 'UNQUAL' (unqualified) reference, it may be looked up in the local, +-- global, or const variable tables. The reference returned will not be 'UNQUAL', it will be either +-- 'GLOBAL', 'LOCAL', or 'CONST', depending on where the 'Object' returned was found. +-- +-- If the 'Reference' is a function call, the object returned will be the evaluation of the function +-- call, which may be void (a.k.a. 'Prelude.Nothing'). +referenceLookup :: Reference -> Exec (Reference, Maybe Object) +referenceLookup qref = case qref of + RefWrapper ref -> return $ (qref, Just (obj ref)) + qref -> do + (a, (qref, _, _)) <- runObjectFocus (updateIndex qref get) True qref () + return (qref, a) + +refNames :: [Name] -> Maybe Reference +refNames nx = case nx of + [] -> Nothing + n:nx -> Just $ Reference UNQUAL n $ refSuffixFromNames nx + +referenceFromUStr :: UStr -> Maybe Reference +referenceFromUStr s = breakup [] $ uchars s where + breakup refs s = case break (=='.') s of + (n, '.':s) -> breakup (refs++[ustr n]) s + (n, "" ) -> refNames $ refs++[ustr n] + _ -> Nothing + +fmapReference :: (RefSuffix -> RefSuffix) -> Reference -> Reference +fmapReference fn ref = case ref of + Reference q nm ref -> Reference q nm (fn ref) + RefObject o ref -> RefObject o (fn ref) + RefWrapper qref -> RefWrapper $ fmapReference fn qref + +setQualifier :: RefQualifier -> Reference -> Reference +setQualifier q ref = case ref of + Reference _ name ref -> Reference q name ref + RefObject o ref -> RefObject o ref + RefWrapper qref -> RefWrapper $ setQualifier q qref + +modRefObject :: (Object -> Object) -> Reference -> Reference +modRefObject mod ref = case ref of + RefObject o ref -> RefObject (mod o) ref + ref -> ref + +-- | This function performs an update on a 'Reference', it is the complement to the 'referenceLookup' +-- function. Evaluating 'referenceUpdate' on a 'Reference' will write/update the value associated with +-- it. If the boolean parameter is 'Prelude.True' it indicates that the value updated must already +-- exist, and an undefined reference error will be thrown if it does not exist. +referenceUpdate :: Reference -> Bool -> (Maybe Object -> Exec (Maybe Object)) -> Exec (Reference, Maybe Object) +referenceUpdate qref mustExist upd = do + -- The 'ExecUnit' is not actually modified in any way by 'updateIndex'. It is only used to + -- instruct Haskell's type system to select the class instance of 'updateIndex' for the data type: + -- > 'ObjectLens' 'ExecUnit' 'Reference' + (result, (qref, _, _)) <- + runObjectFocus (updateIndex qref $ execToFocusUpdater upd) mustExist (fst $ referenceHead qref) () + return (qref, result) + +---------------------------------------------------------------------------------------------------- + +-- $Object_types +-- Here we have a lambda calculus for describing types. Computationally, it is very similar to the +-- Prolog programming language, however an 'ObjType' is written using a subset the Dao scripting +-- langauge. + +data CoreType + = NullType + | TrueType + | CharType + | IntType + | WordType + | LongType + | DiffTimeType + | FloatType + | RatioType + | ComplexType + | StringType + | BytesType + | ListType + | DictType + | RefType + | TypeType + | TreeType + | TimeType + | HaskellType + deriving (Eq, Ord, Typeable, Enum, Bounded) + +instance Show CoreType where + show t = case t of + NullType -> "Null" + TrueType -> "True" + CharType -> "Char" + IntType -> "Int" + WordType -> "Word" + LongType -> "Long" + DiffTimeType -> "Diff" + FloatType -> "Float" + RatioType -> "Ratio" + ComplexType -> "Complex" + StringType -> "String" + BytesType -> "Bytes" + ListType -> "List" + DictType -> "Dict" + RefType -> "Ref" + TypeType -> "Type" + TreeType -> "Tree" + TimeType -> "Time" + HaskellType -> "Haskell" + +instance Read CoreType where + readsPrec _ str = map (\a -> (a, "")) $ case str of + "Null" -> [NullType] + "True" -> [TrueType] + "Char" -> [CharType] + "Int" -> [IntType] + "Word" -> [WordType] + "Long" -> [LongType] + "Diff" -> [DiffTimeType] + "Float" -> [FloatType] + "Ratio" -> [RatioType] + "Complex" -> [ComplexType] + "String" -> [StringType] + "Bytes" -> [BytesType] + "List" -> [ListType] + "Dict" -> [DictType] + "Ref" -> [RefType] + "Type" -> [TypeType] + "Tree" -> [TreeType] + "Time" -> [TimeType] + "Haskell" -> [HaskellType] + _ -> [] + +instance NFData CoreType where { rnf a = seq a () } + +instance UStrType CoreType where + toUStr = derive_ustr + maybeFromUStr a = case readsPrec 0 (uchars a) of + [(o, "")] -> Just o + _ -> Nothing + fromUStr a = case maybeFromUStr a of + Nothing -> error (show a++" is not a valid type identifier") + Just a -> a + +instance Iv.InfBound CoreType where + minBoundInf = Iv.Finite minBound + maxBoundInf = Iv.Finite maxBound + +instance PPrintable CoreType where { pPrint = pShow } + +-- binary 0x08 0x1A CoreType +instance B.Binary CoreType mtab where + put t = B.putWord8 $ case t of + NullType -> 0x08 + TrueType -> 0x09 + CharType -> 0x0A + IntType -> 0x0B + WordType -> 0x0C + LongType -> 0x0D + DiffTimeType -> 0x0E + FloatType -> 0x0F + RatioType -> 0x10 + ComplexType -> 0x11 + StringType -> 0x12 + BytesType -> 0x13 + ListType -> 0x14 + DictType -> 0x15 + RefType -> 0x16 + TypeType -> 0x17 + TreeType -> 0x18 + TimeType -> 0x19 + HaskellType -> 0x1A + get = B.word8PrefixTable <|> fail "expecting CoreType" + +instance B.HasPrefixTable CoreType B.Byte mtab where + prefixTable = B.mkPrefixTableWord8 "CoreType" 0x08 0x1A $ map return $ + [ NullType + , TrueType + , CharType + , IntType + , WordType + , LongType + , DiffTimeType + , FloatType + , RatioType + , ComplexType + , StringType + , BytesType + , ListType + , DictType + , RefType + , TypeType + , TreeType + , TimeType + , HaskellType + ] + +instance HasRandGen CoreType where + randO = toEnum <$> nextInt (fromEnum (maxBound::CoreType)) + defaultO = randO + +-- | Get the 'CoreType' o an 'Object'. +coreType :: Object -> CoreType +coreType o = case o of + ONull -> NullType + OTrue -> TrueType + OChar _ -> CharType + OInt _ -> IntType + OWord _ -> WordType + OLong _ -> LongType + ORelTime _ -> DiffTimeType + OFloat _ -> FloatType + ORatio _ -> RatioType + OComplex _ -> ComplexType + OString _ -> StringType + OBytes _ -> BytesType + OList _ -> ListType + ODict _ -> DictType + ORef _ -> RefType + OType _ -> TypeType + OTree _ -> TreeType + OAbsTime _ -> TimeType + OHaskell _ -> HaskellType + +---------------------------------------------------------------------------------------------------- + +-- | A symbol in the type calculus. +data TypeSym + = CoreType CoreType + -- ^ used when the type of an object is equal to it's value, for example Null and True, + -- or in situations where the type of an object has a value, for example the dimentions of a + -- matrix. + | TypeSym Name + | TypeVar Name [ObjType] + -- ^ a polymorphic type, like 'AnyType' but has a name. + deriving (Eq, Ord, Show, Typeable) + +instance NFData TypeSym where + rnf (CoreType a ) = deepseq a () + rnf (TypeSym a ) = deepseq a () + rnf (TypeVar a b) = deepseq a $! deepseq b () + +instance HasRandGen TypeSym where + randO = _randTrace "TypeSym" $ countNode $ runRandChoice + randChoice = randChoiceList $ + [CoreType <$> randO, TypeSym <$> randO, scramble $ return TypeVar <*> randO <*> randList 1 4] + defaultO = _randTrace "D.TypeSym" $ CoreType <$> defaultO + +instance PPrintable TypeSym where + pPrint t = case t of + CoreType t -> pPrint t + TypeSym t -> pPrint t + TypeVar t ctx -> pInline $ + concat [[pPrint t], guard (not (null ctx)) >> [pList_ "[" ", " "]" (map pPrint ctx)]] + +-- binary 0x2E 0x2F +instance B.Binary TypeSym mtab where + put o = case o of + CoreType o -> B.prefixByte 0x2D $ B.put o + TypeSym o -> B.prefixByte 0x2E $ B.put o + TypeVar ref ctx -> B.prefixByte 0x2F $ B.put ref >> B.put ctx + get = B.word8PrefixTable <|> fail "expecting TypeSym" + +instance B.HasPrefixTable TypeSym B.Byte mtab where + prefixTable = + B.mkPrefixTableWord8 "TypeSym" 0x2D 0x2F [CoreType <$> B.get, return TypeVar <*> B.get <*> B.get] + +---------------------------------------------------------------------------------------------------- + +-- | Complex type structures can be programmed by combining 'ObjSimpleType's. An empty 'TypeStruct' +-- is the "any-type", which matches anything. +newtype TypeStruct = TypeStruct [TypeSym] deriving (Eq, Ord, Show, Typeable) + +instance NFData TypeStruct where { rnf (TypeStruct a) = deepseq a () } + +instance HasNullValue TypeStruct where { nullValue = TypeStruct []; testNull (TypeStruct a) = null a; } + +instance PPrintable TypeStruct where + pPrint (TypeStruct tx) = case tx of + [] -> pString "AnyType" + tx -> pList (pString "type") "(" ", " ")" (map pPrint tx) + +-- binary 0x33 +instance B.Binary TypeStruct mtab where + put (TypeStruct o) = B.prefixByte 0x33 $ B.put o + get = B.word8PrefixTable <|> fail "expecting TypeStruct" + +instance B.HasPrefixTable TypeStruct B.Byte mtab where + prefixTable = B.mkPrefixTableWord8 "TypeStruct" 0x33 0x33 [TypeStruct <$> B.get] + +instance HasRandGen TypeStruct where + randO = _randTrace "TypeStruct" $ TypeStruct <$> randList 0 4 + defaultO = _randTrace "D.TypeStruct" $ TypeStruct <$> defaultList 0 4 + +---------------------------------------------------------------------------------------------------- + +-- | The fundamental 'Type' used to reason about whether an object is fit to be used for a +-- particular function. Any empty 'ObjType' is the "void-type" which matches nothing. +newtype ObjType = ObjType { typeChoices :: [TypeStruct] } deriving (Eq, Ord, Show, Typeable) + +instance NFData ObjType where { rnf (ObjType a) = deepseq a () } + +instance HasNullValue ObjType where { nullValue = ObjType []; testNull (ObjType a) = null a; } + +instance PPrintable ObjType where + pPrint t@(ObjType tx) = case fromObj (obj t) of + Just t -> pString $ show (t::CoreType) + Nothing -> case tx of + [] -> pString "VoidType" + tx -> pList (pString "anyOf") "(" ", " ")" (map pPrint tx) + +-- binary 0x37 +instance B.Binary ObjType mtab where + put (ObjType o) = B.prefixByte 0x37 $ B.put o + get = B.word8PrefixTable <|> fail "expecting ObjType" + +instance B.HasPrefixTable ObjType B.Byte mtab where + prefixTable = B.mkPrefixTableWord8 "ObjType" 0x37 0x37 [ObjType <$> B.get] + +instance HasRandGen ObjType where + randO = _randTrace "ObjType" $ recurse $ ObjType <$> randList 0 3 + defaultO = _randTrace "D.ObjType" $ ObjType <$> defaultList 1 4 + +typeOfObj :: Object -> ObjType +typeOfObj o = case o of + OHaskell o -> hataType o + o -> ObjType [TypeStruct [CoreType $ coreType o]] + +hataType :: Hata -> ObjType +hataType (Hata ifc _) = ObjType [TypeStruct [TypeSym $ objInterfaceName ifc]] + +objTypeFromCoreType :: CoreType -> ObjType +objTypeFromCoreType = ObjType . return . TypeStruct . return . CoreType + +objTypeFromName :: Name -> ObjType +objTypeFromName name = ObjType{ typeChoices = [TypeStruct [TypeSym name]] } + +---------------------------------------------------------------------------------------------------- + +-- | This is actually a part of the 'Reference' constructor, and 'Reference' is one of the built-in +-- 'Object' data types. There is a one-to-one mapping from this type to the 'RefSuffixExpr' and +-- 'AST_Ref' data types produced by the parser. +data RefSuffix + = NullRef + | DotRef Name RefSuffix + | Subscript [Object] RefSuffix + | FuncCall [Object] RefSuffix + deriving (Eq, Ord, Typeable, Show) + +instance Monoid RefSuffix where + mempty = NullRef + mappend left right = case left of + NullRef -> right + DotRef nm left -> DotRef nm $ left<>right + Subscript ox left -> Subscript ox $ left<>right + FuncCall ox left -> FuncCall ox $ left<>right + +-- | If the 'RefSuffix' is 'DotRef', 'Subscript', or 'FuncCall', the second parameter to these +-- constructors is overwritten with 'NullRef' so only the first parameter remains. +refSuffixHead :: RefSuffix -> RefSuffix +refSuffixHead suf = let lst = refSuffixToList suf in if null lst then NullRef else head lst + +-- | Evaluates to 'Prelude.True' if ay of the constructors within the 'RefSuffix' are 'FuncCall'. +refSuffixHasFuncCall :: RefSuffix -> Bool +refSuffixHasFuncCall suf = case suf of + NullRef -> False + DotRef _ suf -> refSuffixHasFuncCall suf + Subscript _ suf -> refSuffixHasFuncCall suf + FuncCall _ _ -> True + +-- | The 'RefSuffix' is a list-like data type, where most of the constructors may contain another +-- 'RefSuffix' structure as the "tail" of the list. This function "explodes" a 'RefSuffix' into a +-- list of 'RefSuffix's where "tail" is 'NullRef'. This is the inverse operation of +-- 'Data.Monoid.mconcat', so the following equality is always True: +-- > \r -> mconcat (refSuffixToList r) == r +refSuffixToList :: RefSuffix -> [RefSuffix] +refSuffixToList suf = case suf of + NullRef -> [] + DotRef a suf -> DotRef a NullRef : refSuffixToList suf + Subscript a suf -> Subscript a NullRef : refSuffixToList suf + FuncCall a suf -> FuncCall a NullRef : refSuffixToList suf + +-- | Construct a 'DotRef' with a 'NullRef' suffix. +dotRef :: Name -> RefSuffix +dotRef = flip DotRef NullRef + +-- | Construct a 'Subscript' with a 'NullRef' suffix. +subscript :: [Object] -> RefSuffix +subscript = flip Subscript NullRef + +-- | Construct a 'FuncCall' with a 'NullRef' suffix. +funcCall :: [Object] -> RefSuffix +funcCall = flip FuncCall NullRef + +instance HasNullValue RefSuffix where + nullValue = NullRef + testNull r = case r of { NullRef -> True; _ -> False } + +refSuffixFromNames :: [Name] -> RefSuffix +refSuffixFromNames nx = case nx of { [] -> NullRef; n:nx -> DotRef n $ refSuffixFromNames nx; } + +instance Read RefSuffix where + readsPrec _ str = case str of + '.':c:str | isAlpha c -> + case break (\c -> c=='.' || isAlphaNum c) (c:str) of + (cx, str) -> + maybe [] (return . (\ref -> (refSuffixFromNames ref, str))) $ sequence $ + fix (\loop str -> case break (=='.') str of + (cx, str) -> case cx of + [] -> [] + cx -> maybeFromUStr (ustr (dropWhile (=='.') cx)) : loop str + ) cx + str -> [(NullRef, str)] + +instance NFData RefSuffix where + rnf NullRef = () + rnf (DotRef a b) = deepseq a $! deepseq b () + rnf (Subscript a b) = deepseq a $! deepseq b () + rnf (FuncCall a b) = deepseq a $! deepseq b () + +instance PPrintable RefSuffix where + pPrint = pWrapIndent . loop where + loop r = case r of + NullRef -> [] + DotRef a b -> pString "." : pUStr (toUStr a) : loop b + Subscript a b -> pList_ "[" ", " "]" (map pPrint a) : loop b + FuncCall a b -> pList_ "(" ", " ")" (map pPrint a) : loop b + +instance HasRandGen RefSuffix where + randO = _randTrace "RefSuffix" $ recurse $ countNode $ runRandChoice + randChoice = randChoiceList $ + [ return NullRef + , scramble $ return DotRef <*> randO <*> randO + , depthLimitedInt 8 >>= \x -> return Subscript <*> randList 0 x <*> scrambO + , depthLimitedInt 8 >>= \x -> return FuncCall <*> randList 0 x <*> scrambO + ] + defaultO = _randTrace "D.RefSuffix" runDefaultChoice + defaultChoice = randChoiceList $ + [ return NullRef + , return Subscript <*> defaultList 0 1 <*> pure NullRef + , return FuncCall <*> defaultList 0 1 <*> pure NullRef + ] + +-- binary 0x42 0x45 +instance B.Binary RefSuffix MTab where + put r = case r of + NullRef -> B.putWord8 0x42 + DotRef a b -> B.prefixByte 0x43 $ B.put a >> B.put b + Subscript a b -> B.prefixByte 0x44 $ B.put a >> B.put b + FuncCall a b -> B.prefixByte 0x45 $ B.put a >> B.put b + get = B.word8PrefixTable <|> fail "expecting RefSuffix" + +instance B.HasPrefixTable RefSuffix B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "RefSuffix" 0x42 0x45 $ + [ return NullRef + , return DotRef <*> B.get <*> B.get + , return Subscript <*> B.get <*> B.get + , return FuncCall <*> B.get <*> B.get + ] + +---------------------------------------------------------------------------------------------------- + +newtype Complex = Complex (C.Complex Double) + deriving (Eq, Typeable, Floating, Fractional, Num) + +-- | Since 'Object' requires all of it's types instantiate 'Prelude.Ord', I have defined +-- 'Prelude.Ord' of 'Data.Complex.Complex' numbers to be the distance from 0, that is, the radius of +-- the polar form of the 'Data.Complex.Complex' number, ignoring the angle argument. +instance Ord Complex where + compare (Complex a) (Complex b) = compare (C.polar a) (C.polar b) + +instance Show Complex where + show (Complex a) = "("++show re++(if im<0 then "-" else "+")++show im++"i)" where + re = C.realPart a + im = C.imagPart a + +instance NFData Complex where { rnf (Complex a) = deepseq a $! () } + +instance HasNullValue Complex where + nullValue = Complex (0 C.:+ 0) + testNull (Complex c) = C.realPart c == 0 && C.imagPart c == 0 + +instance B.Binary Complex mtab where + put o = B.put (realPart o) >> B.put (imagPart o) + get = return complex <*> B.get <*> B.get + +instance PPrintable Complex where + pPrint (Complex (a C.:+ b)) + | a==0.0 && b==0.0 = pString "0i" + | a==0.0 = pString (show b++"i") + | b==0.0 = pShow a + | otherwise = pInline [pShow a, pString (if b<0 then "-" else "+"), pString (show b++"i")] + +instance HasRandGen Complex where { randO = return mkPolar <*> randO <*> randO; defaultO = randO; } + +realPart :: Complex -> Double +realPart (Complex o) = C.realPart o + +imagPart :: Complex -> Double +imagPart (Complex o) = C.imagPart o + +mkPolar :: Double -> Double -> Complex +mkPolar a b = Complex (C.mkPolar a b) + +cis :: Double -> Complex +cis = Complex . C.cis + +polar :: Complex -> (Double, Double) +polar (Complex o) = C.polar o + +magnitude :: Complex -> Double +magnitude (Complex o) = C.magnitude o + +phase :: Complex -> Double +phase (Complex o) = C.phase o + +conjugate :: Complex -> Complex +conjugate (Complex o) = Complex (C.conjugate o) + +complex :: Double -> Double -> Complex +complex a b = Complex (a C.:+ b) + +---------------------------------------------------------------------------------------------------- + +-- | Create the minimum-sized array that can store all of the indices in the given list, setting the +-- 'Data.Array.IArray.bounds' of the array automatically. Evaluates to 'Prelude.Nothing' if the +-- given list of elements is empty. +minAccumArray :: Ix i => (e -> e' -> e) -> e -> [(i, e')] -> Maybe (Array i e) +minAccumArray accfn deflt elems = + if null elems then Nothing else Just (accumArray accfn deflt bnds elems) where + idxs = map fst elems + i0 = head idxs + bnds = foldl (\ (lo, hi) i -> (min lo i, max hi i)) (i0, i0) (tail idxs) + +-- | Create the minimum-sized array that can store all of the indices in the given list, and setting +-- the 'Data.Array.IArray.bounds' of the array automatically. Evaluates to 'Prelude.Nothing' if the +-- given list of elements is empty. +minArray :: Ix i => e -> [(i, e)] -> Maybe (Array i e) +minArray deflt elems = minAccumArray (flip const) deflt elems + +---------------------------------------------------------------------------------------------------- + +-- | An alternative to 'Glob' expressions containing ordinary 'Dao.String.UStr's is a 'Glob' +-- expression containing 'FuzzyStr's. These strings approximately match the input string, ignoring +-- minor spelling errors and transposed characters. +newtype FuzzyStr = FuzzyStr UStr deriving (Ord, Typeable) + +instance Eq FuzzyStr where + a==b = + let ax = S.map toLower (S.fromList (uchars a)) + bx = S.map toLower (S.fromList (uchars b)) + in a == b + || ax == bx + || S.size (S.difference (S.union ax bx) (if S.size ax < S.size bx then ax else bx)) <= 1 + +instance Show FuzzyStr where { show (FuzzyStr str) = show str } + +instance Read FuzzyStr where + readsPrec p input = readsPrec p input >>= \ (s, rem) -> return (FuzzyStr (ustr s), rem) + +instance Monoid FuzzyStr where + mempty = FuzzyStr mempty + mappend (FuzzyStr a) (FuzzyStr b) = FuzzyStr (a<>b) + +instance HasNullValue FuzzyStr where + nullValue = FuzzyStr nullValue + testNull (FuzzyStr s) = testNull s + +instance UStrType FuzzyStr where { fromUStr = FuzzyStr; toUStr (FuzzyStr u) = u; } + +instance PPrintable FuzzyStr where { pPrint (FuzzyStr str) = pShow str } + +instance ObjectClass FuzzyStr where { obj=new; fromObj=objFromHata; } + +instance HataClass FuzzyStr where + haskellDataInterface = interface "FuzzyStr" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + +--instance Show (Glob FuzzyStr) where { show = show . fmap toUStr } + +--instance Read (Glob FuzzyStr) where +-- readsPrec prec str = readsPrec prec str >>= \ (glob, str) -> [(fmap fromUStr glob, str)] + +instance Show (GlobUnit Object) where + show o = case o of + Single o -> show o + globunit -> show (fmap (const "") globunit) + +instance PPrintable (GlobUnit Object) where { pPrint = pShow } + +instance Show (Glob Object) where + show glob = (++"\"") $ ('"':) $ do + o <- getPatUnits glob + let other o = "$("++prettyShow o++")" + case o of + Single o -> case o of + OString o -> uchars o + OHaskell (Hata _ifc dyn) -> case fromDynamic dyn of + Nothing -> other o + Just (FuzzyStr o) -> uchars o + _ -> other o + globunit -> show (fmap (const "") globunit) + +instance PPrintable (Glob Object) where { pPrint = pShow } + +instance ToDaoStructClass (GlobUnit Object) where + toDaoStruct = ask >>= \o -> case o of + Wildcard a t -> renameConstructor "Wildcard" $ "name" .= reference UNQUAL a >> "type" .=? t + AnyOne a t -> renameConstructor "AnyOne" $ "name" .= reference UNQUAL a >> "type" .=? t + Single a -> renameConstructor "Single" $ "item" .= a + +instance FromDaoStructClass (GlobUnit Object) where + fromDaoStruct = msum $ + [ constructor "Wildcard" >> return Wildcard <*> req "name" <*> opt "type" + , constructor "AnyOne" >> return AnyOne <*> req "name" <*> opt "type" + , constructor "Single" >> Single <$> req "item" + ] + +instance ObjectClass (GlobUnit Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (GlobUnit Object) where + haskellDataInterface = interface "GlobUnit" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + autoDefFromStruct >> autoDefToStruct + +instance ToDaoStructClass (Glob Object) where + toDaoStruct = renameConstructor "GlobPattern" $ "items" .=@ obj . map obj . getPatUnits + +instance FromDaoStructClass (Glob Object) where + fromDaoStruct = do + constructor "GlobPattern" + items <- reqList "items" + return (Glob{ getPatUnits=items, getGlobLength=length items }) + +instance ObjectClass (Glob Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (Glob Object) where + haskellDataInterface = interface "GlobPattern" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + defMethod "match" $ + daoFunc + { daoForeignFunc = \glob ox -> fmap (flip (,) glob . Just . obj) $ + forM (matchPattern False glob ox) $ \match -> fmap (obj . M.fromList . concat) $ + forM (M.assocs match) $ \ (name, (vartyp, ox)) -> case vartyp of + Nothing -> return [(name, obj ox)] + Just vartyp -> do + match <- catchPredicate $ referenceLookup $ Reference UNQUAL vartyp $ FuncCall ox NullRef + case match of + Backtrack -> return [] + OK (_, Nothing) -> return [(name, obj ox)] + OK (_, Just o) -> return [(name, obj o)] + PFail err -> throwError err + } + +---------------------------------------------------------------------------------------------------- + +newtype Pair = Pair (Object, Object) deriving (Eq, Ord, Show, Typeable) + +instance PPrintable Pair where + pPrint (Pair (a,b)) = pList (pString "Pair") "(" ", " ")" [pPrint a, pPrint b] + +instance ToDaoStructClass Pair where + toDaoStruct = renameConstructor "Pair" $ ask >>= \ (Pair (a, b)) -> "fst" .= a >> "snd" .= b + +instance FromDaoStructClass Pair where + fromDaoStruct = constructor "Pair" >> Pair <$> (return (,) <*> req "fst" <*> req "snd") + +instance ObjectClass Pair where { obj=new; fromObj=objFromHata; } + +instance HataClass Pair where + haskellDataInterface = interface "Pair" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + defIndexUpdater $ \ix upd -> do + (Pair (a,b)) <- get + let casti = extractXPure . castToCoreType IntType >=> fromObj + let badindex = execThrow "index for Pair data type must be a either 0 or 1" ExecErrorUntyped + let qref = reference UNQUAL (ustr "Pair") + case ix of + [i] -> do + i <- focusLiftExec (derefObject i) >>= + maybe (badindex [(actualType, obj (typeOfObj i))]) return . casti + (o, setter) <- case i of + 0 -> pure (a, \a -> (a, b)) + 1 -> pure (b, \b -> (a, b)) + i -> badindex [(assertFailed, OInt i)] + (result, (changed, o)) <- withInnerLens (Just o) upd + if changed + then + case o of + Nothing -> + execThrow "item in Pair object updated with void" ExecErrorUntyped [(ustr "index", obj i)] + Just o -> put (Pair $ setter o) >> return result + else return result + ix -> throwArityError "for subscript to Pair data type" 1 ix [(errInConstr, obj qref)] + +builtin_assocs :: DaoFunc () +builtin_assocs = + daoFunc + { daoForeignFunc = \ () ox -> do + let qref = reference UNQUAL (ustr "assocs") + case ox of + [o] -> do + let fromDict o = return $ + (Just $ obj $ fmap (\ (a,b) -> obj $ Pair (obj a, obj b)) $ M.assocs o, ()) + let badtype = throwBadTypeError "object does not contain association Pairs" o [] + case o of + ODict d -> fromDict d + OTree (Struct{fieldMap=d}) -> fromDict d + OHaskell _ -> maybe badtype (return . flip (,) () . Just) $ msum $ + [ fromObj o >>= return . obj . fmap (\ (ix, o) -> obj $ Pair (H.indexKey ix, o)) . H.assocs + ] + _ -> badtype + ox -> throwArityError "" 1 ox [(errInFunc, obj qref)] + } + +builtin_Pair :: DaoFunc () +builtin_Pair = + daoFunc + { daoForeignFunc = \ () ox -> case ox of + [a, b] -> return $ (Just $ obj $ Pair(a, b), ()) + ox -> throwArityError "Pair() constructor requires exactly two arguments" 2 ox [] + } + +---------------------------------------------------------------------------------------------------- + +-- | This is a newtype wrapper around a function that tokenizes a 'UStr' into smaller 'UStr's used +-- for constructing rule patterns, and also for tokenizing input strings into objects that can be +-- matched against rule patterns. +newtype ExecTokenizer = ExecTokenizer { runExecTokenizer :: UStr -> Exec [Object] } + deriving Typeable + +---------------------------------------------------------------------------------------------------- + +-- | This is the state that is used to run the evaluation algorithm. Every Dao program file that has +-- been loaded will have a single 'ExecUnit' assigned to it. Parameters that are stored in +-- 'Dao.Debug.DMVar's or 'Dao.Type.Resource's will be shared across all rules which are executed in +-- parallel, so for example 'execHeap' contains the variables global to all rules in a given +-- program. The remainder of the parameters, those not stored in 'Dao.Debug.DMVar's or +-- 'Dao.Type.Resource's, will have a unique copy of those values assigned to each rule as it +-- executes. +data ExecUnit + = ExecUnit + { globalMethodTable :: MethodTable + -- ^ In this slot will be stored a read-only @'Data.Map.Lazy.Map' 'Dao.String.UStr' + -- 'Interface'@ object that will allow any method with access to this + -- 'GenRuntime' to retrieve a 'Interface' by it's name string. Specifically, + -- this will be used by objects stored in the 'OHaskell' constructor. + , importGraph :: M.Map UPath ExecUnit + -- ^ every file opened, whether it is a data file or a program file, is registered here under + -- it's file path (file paths map to 'File's). + , defaultTimeout :: Maybe Int + -- ^ the default time-out value to use when evaluating 'execInputString' + , currentWithRef :: Maybe Object + -- ^ the current document is set by the @with@ statement during execution of a Dao script. + , taskForExecUnits :: Task + , currentQuery :: Maybe [Object] + , currentPattern :: Maybe (Glob Object) + , currentCodeBlock :: Maybe Subroutine + -- ^ when evaluating a 'Subroutine' selected by a string query, the action resulting from + -- that query is defnied here. It is only 'Data.Maybe.Nothing' when the module is first being + -- loaded from source code. + , currentBranch :: [Name] + -- ^ set by the @with@ statement during execution of a Dao script. It is used to prefix this + -- to all global-dot references before reading from or writing to those references. + , execStack :: Stack Name Object + -- ^ stack of local variables used during evaluation + , globalData :: T_dict + , providedAttributes :: M.Map UStr () + , builtinConstants :: T_dict + , execOpenFiles :: M.Map UPath ExecUnit + , programModuleName :: Maybe UPath + , preExec :: [Subroutine] + -- ^ the "guard scripts" that are executed before every string execution. + , postExec :: [Subroutine] + -- ^ the "guard scripts" that are executed after every string execution. + , quittingTime :: [Subroutine] + , programTokenizer :: ExecTokenizer + , ruleSet :: PatternTree Object [Subroutine] + , lambdaSet :: [CallableCode] + , uncaughtErrors :: [ExecControl] + , runtimeRefTable :: RefTable Object Dynamic + } + +-- Initializes a completely empty 'ExecUnit' +_initExecUnit :: IO ExecUnit +_initExecUnit = do + execTask <- initTask + reftable <- newRefTable + return $ + ExecUnit + { globalMethodTable = mempty + , defaultTimeout = Nothing + , importGraph = mempty + , currentWithRef = Nothing + , currentQuery = Nothing + , currentPattern = Nothing + , currentCodeBlock = Nothing + , currentBranch = [] + , globalData = mempty + , providedAttributes = mempty + , builtinConstants = mempty + , taskForExecUnits = execTask + , execStack = emptyStack + , execOpenFiles = mempty + , programModuleName = Nothing + , preExec = [] + , quittingTime = mempty + , programTokenizer = defaultTokenizer + , postExec = [] + , ruleSet = T.Void + , lambdaSet = [] + , uncaughtErrors = [] + , runtimeRefTable = reftable + } + +-- | Creates a new 'ExecUnit'. This is the only way to create a new 'ExecUnit', and it must be run +-- within the 'Exec' monad. The 'ExecUnit' produced by this function will have it's parent +-- 'ExecUnit' set to the value returned by the 'Control.Monad.Reader.Class.ask' instance of the +-- 'Exec' monad. +-- +-- The parent of all other 'ExecUnit's, the root of the family tree, is initalized internally by the +-- 'startDao' function. +newExecUnit :: Maybe UPath -> Exec ExecUnit +newExecUnit modName = get >>= \parent -> liftIO _initExecUnit >>= \child -> return $ + child + { programModuleName = modName + , builtinConstants = builtinConstants parent + , defaultTimeout = defaultTimeout parent + , globalMethodTable = globalMethodTable parent + , runtimeRefTable = runtimeRefTable parent + } + +-- | Execute an 'Exec' monadic function within a different 'ExecUnit' module. The result of the +-- 'Exec' monadic function is the first value in the tuple returned, any modifications to the given +-- 'ExecUnit' module are stored as the second value of the tuple returned. +inModule :: ExecUnit -> Exec a -> Exec (a, ExecUnit) +inModule subxunit exe = do + xunit <- get + result <- put subxunit >> catchPredicate exe + subxunit <- get + put xunit + result <- predicate result + return (result, subxunit) + +---------------------------------------------------------------------------------------------------- + +-- | A 'Task' is simply a group of threads executing in parallel, but evaluating a task is still +-- synchronous, i.e. evaluating 'taskLoop' on a 'Task' will block until every thread in the task has +-- completed. +data Task + = Task + { taskWaitChan :: Chan (ThreadId, Int) + , taskRunningThreads :: MVar (S.Set ThreadId) + } + +-- | Create a new 'Task'. +initTask :: IO Task +initTask = do + wait <- newChan + running <- newMVar S.empty + return $ Task{ taskWaitChan=wait, taskRunningThreads=running } + +-- | To halt a single thread in a 'Task', simply signal it with 'Control.Concurrent.killThread'. But +-- to halt everything the task is doing, use this function. Use of this function will never result in +-- deadlocks (I hope). +throwToTask :: Exception e => Task -> e -> IO () +throwToTask task e = do + let mvar = taskRunningThreads task + ((S.elems <$> readMVar mvar) >>= mapM_ (flip throwTo e)) + `finally` getChanContents (taskWaitChan task) >> return () + +-- | Like 'throwToTask', but throws 'Control.Exception.ThreadKilled'. +killTask :: Task -> IO () +killTask = flip throwToTask ThreadKilled + +-- | This is a better way to manage a 'Task' because all tasks evaluated are waited for +-- synchronously, but you can provide a callback that is evaluated after each task completes. This +-- prevents exceptions from occurring, for example: +-- > "thread blocked indefinitely in an MVar operation" +-- +-- Provide a list of IO functions to be evaluated in parallel. Also provide a callback function +-- that will be evaluated after each thread completes. This function should take two parameters and +-- return a bool: the 'Control.Concurrent.ThreadId' of the thread that completed and a positive +-- integer value indicating the number of threads that are still running, and the bool returned +-- should indicate whether or not the loop should continue. If you should halt the loop by returning +-- 'Prelude.False', the threads in the task that are still running will continue running, and you +-- should call 'killTask' after 'taskLoop' to halt them if halting them should be necessary. +-- +-- This function is also exception safe. All tasks evaluated in parallel will not fail to singal the +-- callback, even if the thread halts with an exception or asynchronous signal from a function like +-- 'Control.Concurrent.killThread'. If the thread evaluating this function is halted by an +-- exception, all threads in the 'Task' are also killed. +taskLoop :: Task -> [IO ()] -> (ThreadId -> Int -> IO Bool) -> IO () +taskLoop task parallelIO threadHaltedEvent = unless (null parallelIO) $ + (do mapM_ (forkInTask task) parallelIO + fix $ \loop -> waitFirst task >>= \ (thread, remain) -> + threadHaltedEvent thread remain >>= \contin -> unless (not contin || remain==0) loop + ) `onException` killTask task + where + waitFirst :: Task -> IO (ThreadId, Int) + waitFirst task = readChan (taskWaitChan task) + forkInTask :: Task -> IO () -> IO ThreadId + forkInTask task run = forkIO $ do + self <- myThreadId + bracket + (modifyMVar (taskRunningThreads task) $ \s' -> do + let s = S.delete self s' + return (s, S.size s) + ) + (\i -> writeChan (taskWaitChan task) (self, i)) + (\ _i -> run) + +-- | Works exactly like 'taskLoop', except you do not need to provide a callback function to be +-- evaluated after every task completes. Essentially, every IO function is evaluated in the 'Task' +-- in parallel, and this function blocks until all tasks have completed. +taskLoop_ :: Task -> [IO ()] -> IO () +taskLoop_ task inits = taskLoop task inits (\ _ _ -> return True) + +---------------------------------------------------------------------------------------------------- + +-- | This simple, humble little class is one of the most important in the Dao program because it +-- defines the 'execute' function. Any data type that can result in procedural execution in the +-- 'Exec' monad can instantiate this class. This will allow the instnatiated data type to be used as +-- a kind of executable code that can be passed around and evaluated at arbitrary points in your Dao +-- program. +-- +-- Note that there the @result@ type parameter is functionally dependent on the @exec@ type +-- parameter. This guarantees there is a one-to-one mapping from independent @exec@ types to +-- dependent @result@ types, i.e. if you data type @MyDat@ maps to a data type @Rzlt@, then @Rzlt@ +-- is the only possible data type that could ever be evaluated by 'execute'-ing the @MyDat@ +-- function. +-- +-- As a reminder, functional dependencies do not necessitate a one-to-one mapping from the +-- dependent type to the independent type, so the @result@ parameter may be the same for many +-- different @exec@ types. But once the compiler infers that the @exec@ parameter of the 'Executable' +-- class is @MyDat@, the @result@ type /must/ be @Rzlt@ and nothing else. +-- > instance Executable MyDat Rzlt +-- > instance Executable A () -- OK (different @exec@ parameters, same @result@ parameters) +-- > instance Executable B () -- OK +-- > instance Executable C () -- OK +-- > +-- > instance Executable D () -- COMPILER ERROR (same @exec@ parameters, different @result@ parameters) +-- > instance Executable D Int -- COMPILER ERROR +-- > instance Executable D Char -- COMPILER ERROR +-- In this example, should D instantiate () or Int or Char as it's result? You must choose only one. +class Executable exec result | exec -> result where { execute :: exec -> Exec result } + +---------------------------------------------------------------------------------------------------- + +-- | Since the 'ExecUnit' deals with a few different kinds of pointer values, namely +-- 'Data.IORef.IORef' and 'MVar', which all have similar functions for reading and updating, I have +-- defined this class to provide a consistent set of functions for working with the various pointers +-- data types. +class ExecRef var where + execReadRef :: var a -> Exec a + execTakeRef :: var a -> Exec a + execPutRef :: var a -> a -> Exec () + execSwapRef :: var a -> a -> Exec a + execModifyRef :: var a -> (a -> Exec (a, b)) -> Exec b + execModifyRef_ :: var a -> (a -> Exec a ) -> Exec () + execModifyRef_ var upd = execModifyRef var (\a -> upd a >>= \a -> return (a, ())) + +instance ExecRef MVar where + execModifyRef mvar upd = + Exec $ PredicateT $ StateT $ \xunit -> modifyMVar mvar $ \var -> do + (result, xunit) <- flip ioExec xunit $ execCatchIO (upd var) $ + [ newExecIOHandler $ flip (execThrow "") [] . ExecHaskellError + , newExecIOHandler $ flip (execThrow "") [] . ExecIOException + ] + let x var p = return (var, (p, xunit)) + case result of + Backtrack -> x var $ Backtrack + OK (var, o) -> x var $ OK o + PFail err -> x var $ PFail err + execModifyRef_ mvar upd = execModifyRef mvar (\var -> upd var >>= \var -> return (var, ())) + execReadRef = liftIO . readMVar + execTakeRef = liftIO . takeMVar + execPutRef mvar = liftIO . putMVar mvar + execSwapRef mvar = liftIO . swapMVar mvar + +instance ExecRef IORef where + execModifyRef ref upd = liftIO (readIORef ref) >>= upd >>= \ (var, b) -> liftIO (writeIORef ref var) >> return b + execModifyRef_ ref upd = liftIO (readIORef ref) >>= upd >>= liftIO . writeIORef ref + execReadRef = liftIO . readIORef + execTakeRef = execReadRef + execPutRef ref = liftIO . writeIORef ref + execSwapRef ref obj = liftIO (readIORef ref >>= \sw -> writeIORef ref obj >> return sw) + +---------------------------------------------------------------------------------------------------- + +data ObjFocusState o + = ObjFocusState + { targetReference :: Reference + -- ^ the whole reference we intend to use + , focalReference :: Reference + -- ^ the reference that is constructed piecewise as each part of the 'targetReference' is resolved. + , objectInFocus :: o + , objectInFocusChanged :: Bool + -- ^ this value is automatically set whenever the 'Control.Monad.State.put' function, or + -- 'Control.Monad.State.modify' functions are evaluated. This value is returned by functions + -- like 'withInnerFocus' and 'runObjectFocus' to indicate when the item being modified was + -- actually modified. + , focusLookup :: Bool + -- ^ when true, indicates that the current focus operation is a lookup. Lookups are different + -- from updates in that an update can continue recursive searching through an object tree even + -- if the reference to be updated is void. Assignment operations, for example, update void + -- references by writing to the reference. Lookup operations, on the other hand, will always + -- fail as soon as a void is encountered. + } + +-- Although the 'ObjectFocus' monad is a wrapper around a 'Dao.Predicate.PredicateT' monad +-- transformer that lifts the 'Exec' monad, backtracking (the instantiation of +-- 'Control.Monad.mzero') has a very different semantical meaning from the 'Exec' monad's semantical +-- meaning of backtracking. In the case of 'ObjectFocus', evaluating 'Control.Monad.mzero' indicates +-- a refernece being looked-up is undefined. To allow for 'Exec' to be lifted into 'ObjectFocus' and +-- also possibly evaluate to 'Control.Monad.mzero' without triggering a backtracking in the +-- 'ObjectFocus' monad, backtracking in the 'Exec' monad needs to be "caught" and re-thrown as an +-- error using 'Control.Monad.Error.throwError' wrapped up in the 'ObjFocusError' data type. However +-- this is all done "under the hood," the public API of the 'ObjectFocus' monad still has +-- 'Control.Monad.Error.throwError' instantiated to throw 'ExecControl' just like the 'Exec' monad: +-- > 'Control.Monad.Error.Class.MonadError' 'ExecControl' 'ObjectFocus' +-- and when evaluting the 'ObjectFocus' monad in the 'Exec' monad using 'runObjectFocus', this +-- error type is automatically caught again and converted back to 'Control.Monad.mzero', initiating +-- ordinary backtracking in the 'Exec' monad. +data ObjFocusError + = InnerExecBacktrack -- ^ a lifted 'Exec' monad evaluated to 'Control.Monad.mzero' + | InnerExecPFail ExecControl + -- ^ a lifted 'Exec' monad evaluated to 'Control.Monad.Error.throwError' + +-- | This is the stateful monad used by the 'ObjectLens' and 'ObjectFunctor' classes. It is called a +-- "focus" because the object we are focused on (on which we are looking up indicies or modifying +-- indicies) is stored in the state of the monad. The 'Control.Monad.State.modify' function modifies +-- the object in the focus. +newtype ObjectFocus o a + = ObjectFocus{ mapObjectLensToPredicate :: PredicateT ObjFocusError (StateT (ObjFocusState o) Exec) a } + deriving (Functor, Applicative, Alternative, MonadPlus) + +instance Monad (ObjectFocus o) where + return = ObjectFocus . return + (ObjectFocus m) >>= f = ObjectFocus $ m >>= mapObjectLensToPredicate . f + fail msg = _mapStructState (gets focalReference) >>= flip (execThrow msg) [] + +instance MonadError ExecControl (ObjectFocus o) where + throwError = ObjectFocus . throwError . InnerExecPFail + catchError (ObjectFocus f) catch = ObjectFocus $ catchError f $ \err -> case err of + InnerExecPFail err -> mapObjectLensToPredicate (catch err) + InnerExecBacktrack -> throwError InnerExecBacktrack + +instance MonadPlusError ExecControl (ObjectFocus o) where + catchPredicate (ObjectFocus f) = ObjectFocus $ catchPredicate f >>= \p -> case p of + OK o -> return $ OK o + PFail (InnerExecPFail e) -> return $ PFail e + PFail InnerExecBacktrack -> throwError InnerExecBacktrack + Backtrack -> return Backtrack + predicate = ObjectFocus . predicate . fmapPFail InnerExecPFail + +instance MonadIO (ObjectFocus o) where { liftIO = ObjectFocus . liftIO } + +instance MonadState o (ObjectFocus o) where + get = _mapStructState $ gets objectInFocus + put o = _mapStructState $ modify $ \st -> st{objectInFocus=o, objectInFocusChanged=True} + +-- | An 'ObjectFocus' function that updates a value within the data of type @o@ in focus at a given +-- @index@ using an inner 'ObjectFocus' function that focuses on the 'Object' value at the index if +-- it exists. The type of the inner 'ObjectFocus' is @('Prelude.Maybe' 'Object')@ because there may +-- be no value defined at the given index. +type ObjectUpdate o index = index -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus o (Maybe Object) + +-- | An 'ObjectFocus' that traverses the 'Object' in the focus by calling the provided traversal +-- function for every @index -> 'Object'@ relation defined within the data of type @o@. The +-- traversal function is an inner focus of type @[(index, 'Object')]@. The list in focus should +-- initially be empty when the inner traversal function is called. When the inner traversal function +-- is completed, it should contain every @(index, 'Object')@ that is intended to be stored back into +-- the data of type @o@. The outer 'ObjectFocus' should retrieve this list of pairs and determine +-- how to update the data of type @o@ accordingly. +type ObjectTraverse o index = (index -> Object -> ObjectFocus [(index, Object)] ()) -> ObjectFocus o () + +-- | This class provides functions that can be used to establish 'ObjectFocus' for various data +-- types. The class allows you to define an association between an index and and object type o, and +-- how the index is used to read and update the object o. +-- There are no functional dependencies between the object type and the index type, so using these +-- function may require type annotation. +class ObjectLens o index where { updateIndex :: ObjectUpdate o index } + +-- | This class provides the 'objectFMap' function for evaluating a functor over every item in an +-- 'bject in the focus of an 'ObjectFocus'. The function that maps to the functor object takes a +-- polymorphic index type and the 'Object' associated with that index. For example, in the case of a +-- 'T_dict' type, the index would be a 'Dao.String.Name', in the case of a 'T_list' type, the index +-- would be a 'Prelude.Integer'. +class ObjectFunctor o index where { objectFMap :: ObjectTraverse o index } + +_mapStructState :: StateT (ObjFocusState o) Exec a -> ObjectFocus o a +_mapStructState = ObjectFocus . lift + +_getTargetRefInfo :: ObjectFocus o Reference +_getTargetRefInfo = _mapStructState $ gets targetReference + +_setTargetRefInfo :: Reference -> ObjectFocus o () +_setTargetRefInfo qref = _mapStructState $ modify $ \st -> st{targetReference=qref} + +-- | This function will check if the 'focusLookup' boolean is set. If it is set, it checks if the +-- current 'objectInFocus' is 'Prelude.Nothing' and backtracks if it is. Otherwise it evaluates the +-- given function. +focusNext :: ObjectFocus (Maybe o) a -> ObjectFocus (Maybe o) a +focusNext f = do + isLookup <- _mapStructState (gets focusLookup) + if isLookup then get >>= maybe mzero (const f) else f + +-- | When instantiating the 'ObjectLens' class with a 'RefSuffix' index type, it is useful to +-- record the head of the 'RefSuffix' that is being used to resolve the index. When an +-- 'Control.Monad.fail' is evaluated, the current path (the 'RefSuffix') to the part of the object +-- where the failure occurred will be used in the error report. Bracketing your 'ObjectFocus' +-- evaluation in this function will help create better error reports. +focalPathSuffix :: RefSuffix -> ObjectFocus o a -> ObjectFocus o a +focalPathSuffix suf f = do + r <- _mapStructState $ get >>= \st -> do + let r = focalReference st + put (st{ focalReference=refAppendSuffix r suf }) >> return r + f >>= \a -> _mapStructState (modify $ \st -> st{ focalReference=r }) >> return a + +focusLiftExec :: Exec a -> ObjectFocus o a +focusLiftExec exec = ObjectFocus $ do + p <- lift $ lift $ catchPredicate exec + case p of + Backtrack -> throwError InnerExecBacktrack + PFail err -> throwError $ InnerExecPFail err + OK o -> return o + +execToFocusUpdater :: (Maybe Object -> Exec (Maybe Object)) -> ObjectFocus (Maybe Object) (Maybe Object) +execToFocusUpdater f = get >>= focusLiftExec . f >>= \o -> put o >> return o + +getFocalReference :: ObjectFocus o Reference +getFocalReference = _mapStructState (gets focalReference) + +-- | This is a kind of entry-point to the 'ObjectFocus' group of functions. First provide a boolean +-- value indicating whether this operation is a ('Prelude.True') lookup and should fail as soon as a +-- void address is encountered, or ('Prelude.False') an update that may insert a value at a void +-- address rather than failing. Second, provide a 'Reference' value for error reporting, to indicate +-- where a 'lookupIndex' or 'updateIndex' function failed. Note that using 'lookupIndex' and +-- 'updateIndex' functions instantiated for 'RefSuffix' indicies will append these indicies to the +-- 'Reference', so it might be better to pass the 'referenceHead' of the 'Reference'. Then supply an +-- object upon which the 'lookupIndex', 'updateIndex', or 'objectFMap' functions will be evaluating. +runObjectFocus :: ObjectFocus o a -> Bool -> Reference -> o -> Exec (a, (Reference, Bool, o)) +runObjectFocus f isLookup qref o = _runObjectFocus f st >>= \p -> case p of + OK o -> return o + PFail (InnerExecPFail e) -> throwError e + PFail InnerExecBacktrack -> mzero + Backtrack -> execThrow "undefined reference" qref [] + where + st= ObjFocusState + { targetReference = qref + , focalReference = fst (referenceHead qref) + , objectInFocus = o + , objectInFocusChanged = False + , focusLookup = isLookup + } + +_runObjectFocus :: ObjectFocus o a -> ObjFocusState o -> Exec (Predicate ObjFocusError (a, (Reference, Bool, o))) +_runObjectFocus (ObjectFocus f) st = flip evalStateT st $ runPredicateT $ f >>= \a -> do + o <- lift $ return (,,) <*> gets targetReference <*> gets objectInFocusChanged <*> gets objectInFocus + return (a, o) + +-- | This is a very important function because it allows you to evaluate an inner 'ObjectFocus' +-- monad that is focused on a different type from the type focus of the monad in the context in +-- which this function is evaluated. It allows you to select a sub-field of the current focus (for +-- example using 'Control.Monad.State.gets') and evaluate an updating function or lookup function +-- that uses value of the sub-field. This function returns the result of the evaluation, and the +-- updated value which can then be placed back into the sub-field if necessary. By composing +-- 'withInnerLens' functions, it is possible to construct a lens that can read and update any value +-- in arbitrarily complex data types. +withInnerLens :: sub -> ObjectFocus sub a -> ObjectFocus o (a, (Bool, sub)) +withInnerLens sub f = do + st <- _mapStructState get + o <- focusLiftExec $ _runObjectFocus f $ st{objectInFocus=sub} + ObjectFocus $ predicate $ o >>= \ (a, (_ref, changed, o)) -> return (a, (changed, o)) + +-- Used in the 'Interface' table to convert between a @typ@ and 'Data.Dynamic.Dynamic' value. +convertFocus :: (a -> b) -> (b -> a) -> ObjectFocus a x -> ObjectFocus b x +convertFocus a2b b2a f = get >>= flip withInnerLens f . b2a >>= \ (x, (changed, a)) -> + when changed (put $ a2b a) >> return x + +focusObjectClass :: ObjectClass o => ObjectFocus o a -> ObjectFocus Object a +focusObjectClass f = do + (a, (changed, o)) <- get >>= xmaybe . fromObj >>= flip withInnerLens f + when changed (put $ obj o) >> return a + +instance ObjectLens T_dict Name where + updateIndex name f = do + (result, (changed, o)) <- get >>= flip withInnerLens (focusNext f) . (M.lookup name) + when changed (modify $ M.alter (const o) name) + return result + +instance ObjectFunctor T_dict Name where + objectFMap f = get >>= + mapM (\ (name, o) -> focalPathSuffix (DotRef name NullRef) $ withInnerLens [] $ f name o + ) . M.assocs >>= put . M.fromList . concatMap (snd . snd) + +focusGuardStructName :: Name -> ObjectFocus T_struct () +focusGuardStructName name = get >>= guard . (==name) . structName + +focusStructAsDict :: ObjectFocus T_dict a -> ObjectFocus T_struct a +focusStructAsDict f = get >>= \struct -> case struct of + Nullary{ structName=name } -> do + (a, (changed, sub)) <- withInnerLens M.empty f + if M.null sub + then return () + else when changed (put $ Struct{ structName=name, fieldMap=sub }) + return a + Struct{ structName=name, fieldMap=sub } -> do + (a, (changed, sub)) <- withInnerLens sub f + when changed $ do + if M.null sub + then put (Nullary{ structName=name }) + else put (struct{ fieldMap=sub }) + return a + +instance ObjectLens T_struct Name where + updateIndex name f = focusStructAsDict $ updateIndex name f + +instance ObjectFunctor T_struct Name where + objectFMap f = focusStructAsDict $ objectFMap f + +updateHataAsStruct :: ObjectFocus T_struct a -> ObjectFocus Hata a +updateHataAsStruct f = do + (Hata ifc o) <- get + (fromStruct, toStruct) <- xmaybe (return (,) <*> objFromStruct ifc <*> objToStruct ifc) + -- here ^ evaluation backtracks if the field cannot be accessed + struct <- predicate $ fromData toStruct o + (a, (changed, struct)) <- withInnerLens struct f + when changed (predicate (toData fromStruct struct) >>= put . Hata ifc) + return a + +lookupHataAsStruct :: ObjectFocus T_struct a -> ObjectFocus Hata a +lookupHataAsStruct f = do + (Hata ifc o) <- get + toStruct <- xmaybe (objToStruct ifc) + struct <- predicate $ fromData toStruct o + fst <$> withInnerLens struct f + +instance ObjectLens Hata Name where + updateIndex name f = updateHataAsStruct $ updateIndex name f + +instance ObjectFunctor Hata Name where + objectFMap = flip mplus (return ()) . updateHataAsStruct . focusStructAsDict . objectFMap + +instance ObjectLens [Object] Integer where + updateIndex idx f = get >>= \ox -> + if idx == negate 1 + then do + (result, (changed, o)) <- withInnerLens Nothing f + when changed (put $ maybe ox (:ox) o) + return result + else do + let splitlen i rx ox = case ox of + [] -> (i, rx, []) + o:ox -> if i>= + mapM (\ (idx, o) -> focalPathSuffix (Subscript [obj idx] NullRef) $ withInnerLens [] $ f idx o + ) . zip [0..] >>= put . map snd . sortBy (\a b -> compare (fst a) (fst b)) . concatMap (snd . snd) + +_dictSubscriptUpdate + :: ObjectLens o Name + => String -> [Object] + -> ObjectFocus (Maybe Object) (Maybe Object) + -> ObjectFocus o (Maybe Object) +_dictSubscriptUpdate msg ix f = focusLiftExec (mapM derefObject ix) >>= \ix -> case ix of + [] -> fail $ "void subscript used to index "++msg + [ORef (Reference UNQUAL name suf)] -> updateIndex name $ updateIndex suf f + [_] -> fail $ "non-reference subscript used to update index of "++msg + _ -> fail $ "multi-dimensional subscript used to update index of "++msg + +-- Converts the function @f@ that is passed to an 'objectFMap' which takes an index value of type +-- @i@ to a value suitable for invoking an 'objectFMap' function instantiated for a different type +-- @fi@. +objectFMapConvert + :: (i -> ObjectFocus [(fi, Object)] fi) -> (fi -> ObjectFocus [(i, Object)] i) + -> (fi -> Object -> ObjectFocus [(fi, Object)] ()) + -> i -> Object + -> ObjectFocus [(i, Object)] () +objectFMapConvert i2fi fi2i f i o = getFocalReference >>= \qref -> do + (_, (_, changed, o)) <- focusLiftExec (runObjectFocus (i2fi i >>= flip f o) False qref []) + o <- forM o (\ (fi, o) -> fi2i fi >>= \i -> return (i, o)) + _mapStructState $ modify $ \st -> st{objectInFocusChanged=changed, objectInFocus=o} + +_dictSubscriptFMap + :: ObjectFunctor o Name + => String -> ([Object] -> Object -> ObjectFocus [([Object], Object)] ()) -> ObjectFocus o () +_dictSubscriptFMap msg f = objectFMap $ objectFMapConvert i2fi fi2i f where + i2fi :: Name -> ObjectFocus [([Object], Object)] [Object] + i2fi name = return [ORef $ Reference UNQUAL name NullRef] + fi2i :: [Object] -> ObjectFocus [(Name, Object)] Name + fi2i ix = focusLiftExec (mapM derefObject ix) >>= \ix -> case ix of + [ORef (Reference UNQUAL name NullRef)] -> return name + _ -> fail $ "improper index value used to update field while traversing "++msg + +_index1DIntegral :: Show a => String -> String -> [Object] -> (Integer -> ObjectFocus o a) -> ObjectFocus o a +_index1DIntegral msg1 msg2 ix f = focusLiftExec (mapM derefObject ix) >>= \ix -> case ix of + [] -> fail $ "void subscript used to "++msg1++" list"++msg2 + [i] -> case extractXPure (castToCoreType LongType i) >>= fromObj of + Nothing -> fail $ "non-integer subscript used to "++msg1++" list"++msg2 + Just i -> f i + _ -> fail $ "multi-dimensional subscript used to "++msg1++" list"++msg2 + +instance ObjectLens [Object] [Object] where + updateIndex ix f = _index1DIntegral "update" "" ix $ flip updateIndex f + +instance ObjectFunctor [Object] [Object] where + objectFMap = objectFMap . + objectFMapConvert (\i -> return [OLong i]) (\ix -> _index1DIntegral "traverse" "" ix return) + +instance ObjectLens T_dict [Object] where + updateIndex = _dictSubscriptUpdate "dictionary" + +instance ObjectFunctor T_dict [Object] where + objectFMap = _dictSubscriptFMap "dictionary" + +instance ObjectLens T_struct [Object] where + updateIndex = _dictSubscriptUpdate "struct" + +instance ObjectFunctor T_struct [Object] where + objectFMap = _dictSubscriptFMap "struct" + +_hataUpdateSubscript + :: (String -> ObjectFocus T_struct (Maybe Object)) + -> ObjectFocus Hata (Maybe Object) +_hataUpdateSubscript f = do + (Hata ifc _) <- get + updateHataAsStruct (f $ show $ objHaskellType ifc) <|> fail "cannot update field" + +_hataLookupSubscript :: (String -> ObjectFocus T_struct Object) -> ObjectFocus Hata Object +_hataLookupSubscript f = do + (Hata ifc _) <- get + lookupHataAsStruct $ f $ show $ objHaskellType ifc + +instance ObjectLens Hata [Object] where + updateIndex ix f = get >>= \ (Hata ifc o) -> case objIndexUpdater ifc of + Nothing -> _hataUpdateSubscript $ \msg -> _dictSubscriptUpdate msg ix f + Just update -> do + (result, (changed, o)) <- withInnerLens o $ update ix f + when changed (put $ Hata ifc o) >> return result + +instance ObjectFunctor Hata [Object] where + objectFMap f = get >>= \ (Hata ifc o) -> case objTraverse ifc of + Nothing -> updateHataAsStruct (_dictSubscriptFMap (show $ objHaskellType ifc) f) <|> + fail "cannot update field" + Just traverse -> do + ((), (changed, o)) <- withInnerLens o (traverse f) + when changed (put $ Hata ifc o) + +_tryFuncCall + :: Maybe Object -> [Object] -> RefSuffix + -> ObjectFocus (Maybe Object) (Maybe Object) + -> ObjectFocus (Maybe Object) (Maybe Object) + -> ObjectFocus (Maybe Object) (Maybe Object) +_tryFuncCall func args suf f els = maybe els id $ do + (Hata ifc d) <- func >>= fromObj + calls <- objCallable ifc + return $ do + -- Get the result of the function call, the result of the operation will become the focus. + this <- get + (result, this) <- focusLiftExec (calls d >>= flip (callCallables this) args) + put this + -- Focus on the result of the function call and evaluate an update on it. + -- The updated function result is ignored, any changes made to it are lost. + (result, _) <- case suf of + NullRef -> withInnerLens result f + _ -> withInnerLens result (updateIndex suf f) + -- The function call may have updated the "this" value, place this updated value back into the focus. + return result + +_refSuffixUpdate + :: (ObjectClass o, ObjectLens o i) + => o -> i -> RefSuffix + -> ObjectFocus (Maybe Object) (Maybe Object) + -> ObjectFocus (Maybe Object) (Maybe Object) +_refSuffixUpdate o i suf f = do + (result, (changed, o)) <- withInnerLens o $ updateIndex i $ updateIndex suf f + when changed (put $ Just $ obj o) >> return result + +-- | This is an 'ObjectUpdate' function which operates in the monad +-- > 'ObjectFocus' (Maybe 'Object') (Maybe 'Object') +-- If the object in the focus is an object constructed with 'ODict', 'OTree', or 'OHaskell', then +-- the 'Name' parameter passed to this function is used to lookup a function stored in the object in +-- focus. This function sets the object in focus to the "this" variable in the Dao runtime and then +-- calls the function with the given @['Object']@ arguments. The object in focus is updated by the +-- function call and the result of the function call is placed in the focus and updated by the next +-- update function with the next 'RefSuffix' provided (as the arguments to the 'ObjectUpdate'). This +-- is the semantics for Dao language expressions of the kind: +-- a.b(c).d(e) +-- that is, an objet stored in the variable "a" has a method "b" called with a parameter "(c)" and +-- the result of this call is an object with a method "d" that is called with the parameter "(e)". +-- Of course if the 'RefSuffix' is 'NullRef', the result of the method call is simply returned. The +-- result of "a.b(c)" is stored on the stack and used to select and evaluate the method "d(e)", +-- however if "d(e)" modified the value on the stack, this modified value is lost when it is popped +-- off of the stack after evaluation completes. There is currently no way to update objects in this +-- way, as the Dao runtime does not have a way to update arbitrary points in it's working memory. +-- This will hopefully be improved in future versions. +callMethod :: Name -> [Object] -> ObjectUpdate (Maybe Object) RefSuffix +callMethod name args suf f = do + qref <- _getTargetRefInfo + let err msg = execThrow msg qref [] + o <- get + case o of + Nothing -> err "method call on undefined reference" + Just o -> case o of + ODict d -> _tryFuncCall (M.lookup name d) args suf f (_refSuffixUpdate d name suf f) + OTree d -> _tryFuncCall (structLookup name d) args suf f (_refSuffixUpdate d name suf f) + OHaskell (Hata ifc d) -> case M.lookup name (objMethodTable ifc) of + Just func -> do + (result, d) <- focusLiftExec $ executeDaoFunc func d args + put (Just $ OHaskell $ Hata ifc d) + -- Next we take the result of this method call and let any 'RefSuffix's that may exist to + -- operate on it. Like _tryFuncCall, this will ignore changes made to the result of the + -- function call. + (result, _) <- case suf of + NullRef -> withInnerLens result f + _ -> withInnerLens result (updateIndex suf f) + return result + Nothing -> case objToStruct ifc of + Just toStruct -> do + struct <- predicate (fromData toStruct d) + _tryFuncCall (structLookup name struct) args suf f (_refSuffixUpdate (Hata ifc d) name suf f) + Nothing -> err "not a callable method function" + _ -> err "method call on atomic object" + -- TODO: provide a set of built-in methods available to every object. + +instance ObjectLens (Maybe Object) RefSuffix where + updateIndex suf f = _getTargetRefInfo >>= \qref -> focalPathSuffix suf $ get >>= \o -> case suf of + NullRef -> focusNext $ get >>= flip withInnerLens f >>= \ (result, (changed, o)) -> + when changed (put o) >> return result + DotRef name (FuncCall args suf) -> focusNext $ callMethod name args suf f + DotRef name suf -> case o of + Nothing -> mzero + Just o -> case o of + ODict o -> _refSuffixUpdate o name suf f + OTree o -> _refSuffixUpdate o name suf f + OHaskell o -> _refSuffixUpdate o name suf f + _ -> throwBadTypeError "referenced element of non-container object" o [] + Subscript ix suf -> focusNext $ case o of + Nothing -> mzero + Just o -> case o of + OList o -> _refSuffixUpdate o ix suf f + ODict o -> _refSuffixUpdate o ix suf f + OTree o -> _refSuffixUpdate o ix suf f + OHaskell o -> _refSuffixUpdate o ix suf f + _ -> throwBadTypeError "cannot subscript of non-indexed object" o [] + FuncCall args suf -> focusNext $ case o of + Nothing -> mzero + Just o -> do + (result, o) <- focusLiftExec (callObject qref o args) + _mapStructState $ modify $ \st -> st{ objectInFocus=o } + -- -^ Here we put the updated function back (it may have had it's static var table updated), + -- but we use '_mapStructState' to do it. This is because using 'modify' or 'put' will + -- automatically set the 'objectInFocusChanged' flag. Since many functions 'CONST' and we + -- would like to update the function's static table without modifying the function itself + -- without also triggering the exception thrown when a const variable is modified, we must + -- make sure we update it in a way that would not indicate that the function object itself + -- has been modified. + (result, _) <- case suf of + NullRef -> withInnerLens result f + suf -> withInnerLens result (updateIndex suf f) + return result + +instance ObjectFunctor Object RefSuffix where + objectFMap f = get >>= \o -> case o of + OList o -> travers o int2subs subs2int OList + ODict o -> travers o ref2subs subs2ref ODict + OTree o -> travers o ref2subs subs2ref OTree + OHaskell o -> travers o ref2subs subs2ref OHaskell + _ -> return () + where + int2subs i = return $ Subscript [OLong i] NullRef + subs2int i = case i of + Subscript [o] NullRef -> case extractXPure (castToCoreType LongType o) >>= fromObj of + Nothing -> fail "while traversing list, updating function returned non-integer index value" + Just i -> return i + _ -> fail "while traversing list, updating function returned non-subscript reference as index" + ref2subs i = return $ DotRef i NullRef + subs2ref i = case i of + DotRef name NullRef -> return name + _ -> fail "while traversing structure, updating function returned invalid reference" + travers o to from constr = do + (_, (changed, o)) <- withInnerLens o (objectFMap $ objectFMapConvert to from f) + when changed (put $ constr o) + +instance ObjectFunctor (Maybe Object) RefSuffix where + objectFMap f = get >>= maybe (return ()) (fmap fst . flip withInnerLens (objectFMap f)) + +-- | If you have a data type @o@ instantiating @'ObjectLens' o index@ with a given index type, and +-- this data type @o@ is a field of another @data@ type, you can instantiate 'updateIndex' for this +-- data type by providing functions to unwrap and wrap the data type @o@ inside of it. For +-- @newtype@s, the wrapper function can be given as @('Prelude.const' MyNewtype)@ where +-- @MyNewtype@ is the newtype constructor. +innerDataUpdateIndex + :: (Show o, ObjectLens o index) + => (dt -> o) -> (dt -> o -> dt) + -> index -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus dt (Maybe Object) +innerDataUpdateIndex unwrap wrap i upd = get >>= \dt -> do + (result, (changed, o)) <- withInnerLens (unwrap dt) (updateIndex i upd) + when changed (modify $ flip wrap o) >> return result + +---------------------------------------------------------------------------------------------------- + +instance ObjectLens (Stack Name Object) Name where + updateIndex name upd = do + ((result, changed), stack) <- get >>= + stackUpdateM (flip withInnerLens upd >=> \ (result, (changed, o)) -> return ((result, changed), o)) name + when changed (put stack) >> return result + +-- | This function can be used to automatically instantiate 'updateIndex' for any type @o@ that also +-- instantiates @'ObjectLens' o 'Dao.String.Name'@. +referenceUpdateName :: ObjectLens o Name => Reference -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus o (Maybe Object) +referenceUpdateName qref f = case qref of + Reference _ name suf -> updateIndex name $ updateIndex suf f + RefObject o suf -> case o of + ORef o -> referenceUpdateName (refAppendSuffix o suf) f + _ -> fail "cannot update reference" + RefWrapper _ -> fail "cannot update reference" + +-- | This function can be used to automatically instantiate 'lookupIndex' for any type @o@ that also +-- instantiates @'ObjectLens' o 'Dao.String.Name'@. This function may also performs updates on variables +-- in place if the variable contains an object and the reference is a method call which updates the +-- object. +referenceLookupName :: ObjectLens o Name => Reference -> ObjectFocus o Object +referenceLookupName qref = case qref of + Reference _ name suf -> updateIndex name get >>= + fmap fst . flip withInnerLens (updateIndex suf get) >>= maybe (execThrow "" qref []) return + RefObject o suf -> case o of + ORef o -> referenceLookupName (refAppendSuffix o suf) + _ -> fail "cannot update reference" + RefWrapper _ -> fail "cannot update reference" + +instance ObjectLens (Stack Name Object) Reference where { updateIndex = referenceUpdateName } + +---------------------------------------------------------------------------------------------------- + +updateLocal :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object) +updateLocal name suf f = do + stack <- focusLiftExec (gets execStack) + (result, (changed, o)) <- withInnerLens (stackLookup name stack) (updateIndex suf f) + -- The updateIndex function may have performed a function call that updated the local stack so we + -- need to get the (possibly) updated stack from the 'ExecUnit' once again and operate on that. + when changed $ focusLiftExec (gets execStack) >>= \stack -> focusLiftExec $ modify $ \xunit -> + xunit{ execStack = snd $ stackUpdate (const ((), o)) name stack } + return (Reference LOCAL name suf, result) + +updateConst :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object) +updateConst name suf f = do + let qref = Reference CONST name suf + consts <- focusLiftExec (gets builtinConstants) + (result, (changed, _)) <- withInnerLens (M.lookup name consts) (updateIndex suf f) + when changed $ case suf of -- Modifying a const variable directly fails. + NullRef -> execThrow "attempted modification of immutable value" ExecErrorUntyped [(modifiedConst, obj qref)] + _ -> return () -- modifying a member of a const value is OK but the updated value is disgarded. + return (qref, result) + +updateStatic :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object) +updateStatic name suf f = do + let qref = Reference STATIC name suf + store <- focusLiftExec (gets currentCodeBlock) >>= maybe mzero return + (result, (changed, o)) <- withInnerLens (M.lookup name $ staticVars store) (updateIndex suf f) + when changed $ focusLiftExec (gets currentCodeBlock) >>= \store -> case store of + Nothing -> return () + Just store -> focusLiftExec $ modify $ \xunit -> + xunit + { currentCodeBlock = Just $ + store{ staticVars = M.alter (const o) name (staticVars store) } + } + return (qref, result) + +updateGlobal :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object) +updateGlobal name suf f = do + let qref = Reference GLOBAL name suf + store <- focusLiftExec (gets globalData) + (result, (changed, o)) <- withInnerLens (M.lookup name store) (updateIndex suf f) + when changed $ focusLiftExec (gets globalData) >>= \store -> focusLiftExec $ modify $ \xunit -> + xunit{ globalData = M.alter (const o) name store } + return (qref, result) + +updateWithRef :: Name -> RefSuffix -> ObjectFocus (Maybe Object) (Maybe Object) -> ObjectFocus () (Reference, Maybe Object) +updateWithRef name suf f = do + let qref = Reference GLODOT name suf + store <- focusLiftExec (gets currentWithRef) + case store of + Nothing -> updateGlobal name suf f + Just o -> do + (result, (changed, o)) <- withInnerLens (Just o) (updateIndex suf f) + when changed $ focusLiftExec $ modify $ \xunit -> xunit{ currentWithRef=o } + return (qref, result) + +instance ObjectLens () Name where + updateIndex name = updateIndex (Reference UNQUAL name NullRef) + +instance ObjectLens () Reference where + updateIndex qref f = do + (qref, result) <- case qref of + Reference q name suf -> case q of + UNQUAL -> fmap fst $ withInnerLens () $ msum $ + [ updateLocal name suf f + , updateConst name suf f + , updateStatic name suf f + , updateGlobal name suf f + , updateWithRef name suf f + ] + LOCAL -> updateLocal name suf f + CONST -> updateConst name suf f + STATIC -> updateStatic name suf f + GLOBAL -> updateGlobal name suf f + GLODOT -> updateWithRef name suf f + _ -> execThrow "cannot update reference" qref [] + _setTargetRefInfo qref >> return result + +---------------------------------------------------------------------------------------------------- + +-- | Error report indicating which function was being evaluated when the error occurred. +errInFunc :: Name +errInFunc = ustr "errInFunc" + +-- | Error report indicating which function was being evaluated when the error occurred. +errInConstr :: Name +errInConstr = ustr "errInConstr" + +-- | Error report indicating which function was being evaluated when the error occurred. +errInInitzr :: Name +errInInitzr = ustr "errInInitzr" + +-- | Error report indicating which function was being evaluated when the error occurred. +errOfReference :: Name +errOfReference = ustr "errOfReference" + +-- | Error report for function calls indicating which argument to the function was incorrect. +argNum :: Name +argNum = ustr "argNum" + +-- | Error report for function calls indicating the number of arguments passed to the function. +numArgsPassed :: Name +numArgsPassed = ustr "numArgsPassed" + +-- | Error report for subscript expressions indicating the number of dimensions expected +expectNumArgs :: Name +expectNumArgs = ustr "expectNumArgs" + +-- | Error report for subscript expressions indicating the number of dimensions expected +exectDimension :: Name +exectDimension = ustr "expectDimension" + +-- | Error report used any place an object value of an incorrect data type was given. +expectType :: Name +expectType = ustr "expectType" + +-- | Error report indicating that the data type of the 'Object' given was incorrect. +actualType :: Name +actualType = ustr "actualType" + +-- | Error report indicating the data type of the right-hand side of an infix operator. +leftSideType :: Name +leftSideType = ustr "leftSideType" + +-- | Error report indicating the data type of the right-hand side of an infix operator. +rightSideType :: Name +rightSideType = ustr "rightSideType" + +-- | Error report indicating an attempt to modify a 'CONST' 'Reference'. +modifiedConst :: Name +modifiedConst = ustr "modifiedConst" + +-- | Error report indicating an object value was of the correct type but was out of bounds or was +-- otherwise not correct. +assertFailed :: Name +assertFailed = ustr "assertFailed" + +-- | Error report indicating a function call evalauted to void. +returnedVoid :: Name +returnedVoid = ustr "returnedVoid" + +-- | This is a simple dictionary of strings that can translate the keys of the 'execErrorInfo' +-- dictionary to more meaningful explanatory strings when reporting error messages. +errorDict :: M.Map Name UStr +errorDict = M.fromList $ fmap (fmap ustr) $ + [(errInFunc , "in function call") + ,(errInConstr , "in constructor") + ,(errInInitzr , "in initializer list") + ,(errOfReference, "of reference") + ,(argNum , "argument number") + ,(expectNumArgs , "number of arguments expected") + ,(exectDimension, "dimensional data type") + ,(numArgsPassed , "number of arguments given") + ,(expectType , "expecting type") + ,(actualType , "actual type used") + ,(leftSideType , "data type of the left-hand operand") + ,(rightSideType , "data type of the right-hand operand") + ,(modifiedConst , "modification on constant reference") + ,(assertFailed , "object value fails assertion test") + ,(returnedVoid , "expression evaluated to void") + ] + +---------------------------------------------------------------------------------------------------- + +-- | This data type is use to halt normal evaluation and force the result of evaluating the code to +-- be a particular value of this type. The 'Exec' monad instantiates +-- 'Control.Monad.Error.Class.MonadError' such that 'Control.Monad.Error.Class.throwError' throws a +-- value of this type. However, it is not only used for exceptions. The Dao scripting language's +-- "return" statement throws an 'ExecReturn' value which is caught using +-- 'Control.Monad.Error.Class.catchError' when evaluating function calls. +data ExecControl + = ExecReturn { execReturnValue :: Maybe Object } + | ExecError + { execErrorMessage :: UStr + , execErrorInModule :: Maybe UStr + , execErrorLocation :: Location + , execErrorSubtype :: ExecErrorSubtype + , execErrorInfo :: T_dict + } + deriving Typeable + +instance Show ExecControl where { show=prettyShow } + +instance HasNullValue ExecControl where + nullValue = ExecReturn Nothing + testNull (ExecReturn Nothing) = True + testNull _ = False + +instance PPrintable ExecControl where + pPrint err = case err of + ExecError{ execErrorMessage=msg, execErrorLocation=loc } -> do + maybe (return ()) (pString . (++":") . uchars) (execErrorInModule err) + pShow loc >> pString (if testNull loc then " " else ": ") + when (not $ msg==nil) (pUStr msg) + pIndent $ do + pEndLine >> pPrint (execErrorSubtype err) + forM_ (M.assocs $ execErrorInfo err) $ \ (key, val) -> do + pEndLine + maybe (pPrint key >> pString ": ") (pString . (++" ") . uchars) (M.lookup key errorDict) + pPrint val + ExecReturn{ execReturnValue=o } -> maybe (return ()) pPrint o + +instance ToDaoStructClass ExecControl where + toDaoStruct = ask >>= \o -> case o of + ExecReturn{} -> renameConstructor "ExecReturn" $ asks execReturnValue >>= ("value" .=?) + ExecError {} -> renameConstructor "ExecError" $ do + asks execErrorInModule >>= ("inModule" .=?) + "message" .=@ execErrorMessage + "location" .=@ execErrorLocation + "subtype" .=@ execErrorSubtype + "info" .=@ execErrorInfo + +instance HataClass ExecControl where + haskellDataInterface = interface "ExecControl" $ do + autoDefPPrinter >> autoDefNullTest >> autoDefToStruct + +instance HasNullValue ExecErrorSubtype where + nullValue = ExecErrorUntyped + testNull ExecErrorUntyped = True + testNull _ = False + +newError :: ExecControl +newError = + ExecError + { execErrorMessage = nil + , execErrorInModule = Nothing + , execErrorLocation = LocationUnknown + , execErrorSubtype = ExecErrorUntyped + , execErrorInfo = mempty + } + +throwArityError :: MonadError ExecControl m => String -> Int -> [o] -> [(Name, Object)] -> m ig +throwArityError msg i ox info = execThrow fullmsg ExecErrorUntyped moreInfo where + (before, after) = splitAt 100 ox + fullmsg = (++(if null msg then "" else ", "++msg)) $ + if null after then "incorrect number of arguments given" else "over 100 arguments given" + moreInfo = concat $ + [ if null after then [(numArgsPassed, OInt $ length before)] else [] + , [(expectNumArgs, OInt i)], info + ] + +throwBadTypeError :: MonadError ExecControl m => String -> Object -> [(Name, Object)] -> m ig +throwBadTypeError msg o info = execThrow msg (ExecTypeError $ typeOfObj o) info + +throwParseError :: MonadError ExecControl m => String -> Maybe UPath -> ParseError () DaoTT -> [(Name, Object)] -> m ig +throwParseError msg mod err info = throwError $ + newError + { execErrorMessage = ustr msg + , execErrorInfo = M.fromList info + , execErrorLocation = parseErrLoc err + -- -^ set the error location in the 'ExecControl' structure + , execErrorSubtype = ExecParseError $ err{ parseErrLoc = LocationUnknown } + -- -^ delete the location to prevent it from being displayed twice + , execErrorInModule = mod + } + +-- | Evaluate a monadic function which may throw an 'ExecControl' 'Dao.Predicate.PFail' predicate +-- value. If the monadic function does fail, the 'Doa.Predicate.PFail' value will be updated with +-- the 'Dao.Token.Location' value retrieved by evaluating 'Dao.Token.getLocation' on the object +-- provided. If the evaluation failed and has already set an error location, the location is not +-- modified by this function, which guarantees the inner-most call to 'errLocation' will set the +-- location of the error. +errLocation :: (MonadError ExecControl m, HasLocation o) => o -> m a -> m a +errLocation o f = catchError f $ \err -> case err of + ExecError{execErrorLocation=LocationUnknown} -> + throwError $ err{execErrorLocation=getLocation o} + err -> throwError err + +-- | Evaluate a monadic function which may throw an 'ExecControl' 'Dao.Predicate.PFail' predicate +-- value. If the monadic function does fail, the 'Doa.Predicate.PFail' value will be updated with +-- the given module name. If the evaluation failed and has already set an error module, the module +-- is not modified by this function, which guarantees the inner-most call to 'errModule' will set +-- the module of the error. +errModule :: MonadError ExecControl m => UPath -> m a -> m a +errModule path f = catchError f $ \err -> case err of + ExecError{execErrorInModule=mod} -> throwError $ err{execErrorInModule=mplus mod (Just path)} + err -> throwError err + +-- | Like 'errModule' but sets the module reported by the error to be the current module of the +-- 'ExecUnit' if it is defined. If it is not defined, this function is equivalent to 'Prelude.id'. +errCurrentModule :: Exec a -> Exec a +errCurrentModule f = gets programModuleName >>= \mod -> maybe id errModule mod $ f + +-- | Evaluate a monadic function which may throw an 'ExecControl' 'Dao.Predicate.PFail' predicate +-- value. If the monadic function does fail, the 'execErrorInfo' field of the 'ExecError' value in +-- the 'Dao.Predicate.PFail' predicate will be updated with the field 'Name' and 'Object' value +-- provided here. +errInfo :: MonadError ExecControl m => Name -> Object -> m a -> m a +errInfo name o f = catchError f $ \err -> case err of + ExecError{execErrorInfo=info} -> throwError $ err{execErrorInfo=M.insert name o info} + err -> throwError err + +-- | Evaluate an 'Exec', but if it throws an exception, set record an 'ObjectExpr' where +-- the exception occurred in the exception information. +updateExecErrorInfo :: Name -> Object -> Exec a -> Exec a +updateExecErrorInfo name o fn = catchError fn $ \err -> case err of + ExecReturn{} -> throwError err + ExecError{execErrorInfo=info} -> throwError $ err{ execErrorInfo = M.insert name o info } + +-- | If an error has not been caught, log it in the module where it can be retrieved later. This +-- function only stores errors constructed with 'ExecError', the 'ExecReturn' constructed objects +-- are ignored. +logUncaughtErrors :: [ExecControl] -> Exec () +logUncaughtErrors errs = modify $ \xunit -> + xunit{ uncaughtErrors = uncaughtErrors xunit ++ + (errs >>= \e -> case e of { ExecReturn{} -> []; ExecError{} -> [e]; }) } + +-- | Clear the log of uncaught 'ExecError' values stored by 'logUncaughtErrors'. +clearUncaughtErrorLog :: Exec [ExecControl] +clearUncaughtErrorLog = do + errs <- gets uncaughtErrors + modify $ \xunit -> xunit{ uncaughtErrors = [] } + return errs + +---------------------------------------------------------------------------------------------------- + +data ExecErrorSubtype + = ExecErrorUntyped + | ExecThrow Object + -- ^ thrown when evaluating a "throw" statement, that is 'Dao.Interpreter.AST.ReturnExpr' + | ExecStructError StructError -- ^ thrown by 'toDaoStruct' or 'fromDaoStruct' + | ExecUndefinedRef Reference -- ^ signals reference lookup failed + | ExecTypeError ObjType -- ^ catch-all exception thrown when wrong data type is used. + | ExecUpdateOpError UpdateOp -- ^ thrown when an update operator fails + | ExecIOException IOException -- ^ re-thrown when caught from the IO monad + | ExecHaskellError ErrorCall -- ^ re-thrown when caught from the IO monad + | ExecParseError (ParseError () DaoTT) + | ExecInfixOpError ObjType InfixOp ObjType -- ^ thrown when an infix operator fails + | ExecLoopCtrl LoopCtrl + -- ^ inspired by the Python language, break and continue loop control statements are exceptions. + deriving (Eq, Typeable) + +instance Show ExecErrorSubtype where { show=prettyShow } + +instance ToDaoStructClass ExecErrorSubtype where + toDaoStruct = ask >>= \o -> case o of + ExecErrorUntyped -> makeNullary "Error" + ExecThrow o -> renameConstructor "Exception" $ "threw" .= o + ExecStructError o -> innerToStruct o + ExecUndefinedRef o -> renameConstructor "UndefinedRef" $ "reference" .= o + ExecTypeError o -> renameConstructor "TypeMismatch" $ "usedType" .= o + ExecUpdateOpError o -> renameConstructor "UpdateOpError" $ "operator" .= o + ExecIOException o -> renameConstructor "HaskellIOException" $ "message" .= obj (show o) + ExecHaskellError o -> renameConstructor "HaskellError" $ "message" .= obj (show o) + ExecParseError o -> innerToStruct o + ExecInfixOpError a o b -> renameConstructor "InfixOpError" $ + "operator" .= o >> "left" .= a >> "right" .= b + ExecLoopCtrl o -> innerToStruct o + +instance PPrintable ExecErrorSubtype where + pPrint o = case o of + ExecErrorUntyped -> return () + ExecThrow o -> pString "threw exception " >> pPrint o + ExecStructError o -> pPrint o + ExecUndefinedRef o -> pString "undefined reference " >> pPrint o + ExecTypeError o -> pString "cannot use value of type " >> pPrint o + ExecUpdateOpError o -> pString "cannot apply update with operator " >> pPrint o + ExecIOException o -> pString (show o) + ExecHaskellError o -> pString (show o) + ExecParseError o -> pPrint o + ExecInfixOpError a o b -> do + pString "incompatible types on either side of operator " >> pPrint o + pIndent $ do + pEndLine >> pString "left-hand side of operator is value of type: " >> pPrint a + pEndLine >> pString "right-hand side of operator is value of type: " >> pPrint b + ExecLoopCtrl o -> pPrint o + +instance ObjectClass ExecErrorSubtype where { obj=new; fromObj=objFromHata; } + +instance HataClass ExecErrorSubtype where + haskellDataInterface = interface "ErrorSubtype" $ do + autoDefEquality >> autoDefPPrinter >> autoDefToStruct + +---------------------------------------------------------------------------------------------------- + +data LoopCtrl + = LoopCtrl + { loopCtrlEscaped :: Bool + -- ^ Has this exception gone past a function call context boundary? + , loopCtrlContinue :: Bool + -- ^ Is this control expression a continue statement? (if not it is a break statement) + } + deriving (Eq, Typeable) + +loopCtrl :: Bool -> LoopCtrl +loopCtrl contin = LoopCtrl{ loopCtrlEscaped=False, loopCtrlContinue=contin } + +instance PPrintable LoopCtrl where + pPrint ctrl = pString $ concat $ + [ if loopCtrlContinue ctrl then "continue" else "break" + , " statement evaluated is not within a loop" + ] + +instance ToDaoStructClass LoopCtrl where + toDaoStruct = renameConstructor "LoopCtrl" $ "isContinue" .=@ loopCtrlContinue + +catchLoopCtrl :: Exec a -> (Bool -> Exec a) -> Exec a +catchLoopCtrl try catch = catchError try $ \err -> case err of + ExecError{ execErrorSubtype = + ExecLoopCtrl (LoopCtrl{ loopCtrlEscaped=False, loopCtrlContinue=contin }) } -> catch contin + _ -> throwError err + +-- | When defining an iterator, you should catch break and continue statements. This function is a +-- replacement for 'Control.Monad.forM' that handles break and continue statements correctly. +execForM :: [o] -> (o -> Exec a) -> Exec [a] +execForM ox f = loop ox [] where + loop ox rev = case ox of + [] -> return rev + o:ox -> do + (contin, r) <- catchLoopCtrl ((,) True . return <$> f o) (return . flip (,) []) + (if contin then loop ox else return) (rev++r) + +-- | Like 'execForM' but ignores the values returned by the iterating function. +execForM_ :: [o] -> (o -> Exec a) -> Exec () +execForM_ ox f = loop ox where + loop ox = case ox of + [] -> return () + o:ox -> catchLoopCtrl (void $ f o) (flip when (loop ox)) + +---------------------------------------------------------------------------------------------------- + +-- | All evaluation of the Dao language takes place in the 'Exec' monad. It instantiates +-- 'Control.Monad.MonadIO.MonadIO' to allow @IO@ functions to be lifeted into it. It instantiates +-- 'Control.Monad.Error.MonadError' and provides it's own exception handling mechanism completely +-- different from the Haskell runtime, so as to allow for more control over exception handling in +-- the Dao runtime. +newtype Exec a = Exec{ execToPredicate :: PredicateT ExecControl (StateT ExecUnit IO) a } + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO) + +instance MonadState ExecUnit Exec where { state = Exec . lift . state } + +instance MonadError ExecControl Exec where + throwError = Exec . throwError + catchError (Exec try) catch = Exec (catchError try (execToPredicate . catch)) + +instance MonadPlusError ExecControl Exec where + catchPredicate (Exec f) = Exec (catchPredicate f) + predicate = Exec . predicate + +---------------------------------------------------------------------------------------------------- + +-- | The 'XPure' type is like 'Exec' but does not lift IO or contain any reference to any +-- 'ExecUnit', so it is guaranteed to work without side-effects, but it also instantiates the +-- 'Control.Monad.MonadPlus', 'Control.Applicative.Alternative', 'Control.Monad.Error.MonadError' +-- and 'Dao.Predicate.MonadPlusError' classes so you can do computation with backtracking and +-- exceptions. Although this monad evaluates to a pure function, it does have stateful data: a +-- 'Dao.String.UStr' that will call a "print stream", which is provided for general purpose; a place +-- to print information throughout evaluation like a "print()" statement. The 'xnote' function +-- serves as the "print()" function for this monad. Use the ordinary 'Control.Monad.State.get' and +-- 'Control.Monad.State.modify' APIs for working with the print stream data. +-- +-- You can also evaluate an 'XPure' monad within an 'Exec' monad by simply using the 'execute' +-- function. This will automatically convert the internal 'Dao.Predicate.Predicate' of the 'XPure' +-- monad to the 'Dao.Predicate.Predicate' of the 'Exec' monad, meaning if you 'execute' an 'XPure' +-- monad that backtracks or throws an error, the 'Exec' monad will backtrack or throw the same +-- error. +newtype XPure a = XPure { xpureToState :: PredicateT ExecControl (State UStr) a } + deriving (Functor, Applicative, Alternative, MonadPlus) + +instance Show a => Show (XPure a) where + show (XPure p) = case evalState (runPredicateT p) nil of + Backtrack -> "(BACKTRACK)" + PFail err -> "(PFAIL "++prettyShow err++")" + OK o -> "(OK "++show o++")" + +instance Monad XPure where + return = XPure . return + (XPure a) >>= f = XPure $ a >>= xpureToState . f + fail msg = execThrow msg ExecErrorUntyped [] + +-- | Convert a value wrapped in an XPure monad to a pair containing the internal state 'Dao.String.UStr' and +-- 'Dao.Predicate.Predicate' value. +runXPure :: XPure a -> (Predicate ExecControl a, UStr) +runXPure = flip runState nil . runPredicateT . xpureToState + +-- | Like 'Control.Monad.State.evalState', but works on the 'XPure' monad, i.e. it is defined as +-- > 'Prelude.fst' . 'runXPure' +evalXPure :: XPure a -> Predicate ExecControl a +evalXPure = fst . runXPure + +-- | Like 'evalXPure' but evaluates to 'Prelude.Maybe' instead of a 'Dao.Predicate.Predicate'. +-- 'Dao.Predicate.Backtrack' and 'Dao.Predicate.PFail' both map to 'Prelude.Nothing', +-- 'Dao.Predicate.OK' maps to 'Prelude.Just'. +extractXPure :: XPure a -> Maybe a +extractXPure = okToJust . evalXPure + +instance MonadError ExecControl XPure where + throwError = XPure . throwError + catchError (XPure f) catch = XPure $ catchError f (xpureToState . catch) + +instance MonadPlusError ExecControl XPure where + predicate = XPure . predicate + catchPredicate (XPure f) = XPure $ catchPredicate f + +instance MonadState UStr XPure where { state = XPure . lift . state } + +instance Executable (XPure a) a where + execute (XPure f) = predicate $ evalState (runPredicateT f) mempty + +-- | Like 'Control.Applicative.pure' or 'Control.Monad.return' but the type is not polymorphic so +-- there is no need to annotate the monad to which you are 'Control.Monad.return'ing, which is +-- helpful when using functions like 'exceute' to convert the 'XPure' monad to the 'Exec' monad. +xpure :: a -> XPure a +xpure = pure + +-- | Like 'xpure' but wraps any data type that instantiates the 'ObjectClass' class. +xobj :: ObjectClass a => a -> XPure Object +xobj = xpure . obj + +-- | Append a string of any 'UStrType' to the general-purpose print stream contained within the +-- 'XPure' monad. +xnote :: UStrType s => s -> XPure () +xnote = modify . flip mappend . toUStr + +-- | Like 'xnote' but lets you operate on the 'Data.ByteString.Lazy.UTF8.ByteString'. +xonUTF8 :: (U.ByteString -> U.ByteString) -> XPure () +xonUTF8 = modify . fmapUTF8String + +-- | Works on any 'Control.Monad.MonadPlus' type, including 'Prelude.Maybe', 'Exec' and 'XPure', is +-- defined as: > 'Prelude.maybe' 'Control.Monad.mzero' 'Control.Monad.return' which is useful +-- shorthand for converting a value wrapped in a 'Prelude.Maybe' data type to a value wrapped in the +-- 'Control.Monad.MonadPlus' type. +xmaybe :: MonadPlus m => Maybe a -> m a +xmaybe = maybe mzero return + +---------------------------------------------------------------------------------------------------- + +class ExecThrowable o where + toExecErrorInfo :: o -> ExecErrorSubtype + -- | Like 'Prelude.error' but works for the 'Exec' monad, throws an 'ExecControl' using + -- 'Control.Monad.Error.throwError' constructed using the given 'Object' value as the + -- 'execReturnValue'. + execThrow + :: (Monad m, MonadError ExecControl m, ExecThrowable o, UStrType msg) + => msg -> o -> [(Name, Object)] -> m ig + execThrow msg o info = throwError $ + newError + { execErrorMessage = toUStr msg + , execErrorSubtype = toExecErrorInfo o + , execErrorInfo = M.fromList info + } + +instance ExecThrowable ExecErrorSubtype where { toExecErrorInfo = id } +instance ExecThrowable Object where { toExecErrorInfo = ExecThrow } +instance ExecThrowable StructError where { toExecErrorInfo = ExecStructError } +instance ExecThrowable Reference where { toExecErrorInfo = ExecUndefinedRef } +instance ExecThrowable IOException where { toExecErrorInfo = ExecIOException } +instance ExecThrowable ErrorCall where { toExecErrorInfo = ExecHaskellError } +instance ExecThrowable UpdateOp where { toExecErrorInfo = ExecUpdateOpError } +instance ExecThrowable (ParseError () DaoTT) where { toExecErrorInfo = ExecParseError } +instance ExecThrowable LoopCtrl where { toExecErrorInfo = ExecLoopCtrl } + +ioExec :: Exec a -> ExecUnit -> IO (Predicate ExecControl a, ExecUnit) +ioExec func xunit = runStateT (runPredicateT (execToPredicate func)) xunit + +---------------------------------------------------------------------------------------------------- + +-- | This is the data type analogous to the 'Exec' monad what 'Control.Exception.Handler' is to the +-- @IO@ monad. +newtype ExecHandler a = + ExecHandler { execHandler :: ExecUnit -> Handler (Predicate ExecControl a, ExecUnit) } + +instance Functor ExecHandler where + fmap f (ExecHandler h) = ExecHandler (fmap (fmap (\ (p, xunit) -> (fmap f p, xunit))) h) + +-- | Create an 'ExecHandler'. +newExecIOHandler :: Exception e => (e -> Exec a) -> ExecHandler a +newExecIOHandler h = ExecHandler (\xunit -> Handler (\e -> ioExec (h e) xunit)) + +-- | Using an 'ExecHandler' like 'execIOHandler', catch any exceptions thrown by the Haskell +-- language runtime and wrap them up in the 'Exec' monad. +execCatchIO :: Exec a -> [ExecHandler a] -> Exec a +execCatchIO tryFunc handlers = Exec $ PredicateT $ StateT $ \xunit -> + liftIO $ catches (ioExec tryFunc xunit) (fmap (\h -> execHandler h xunit) handlers) + +-- | Like 'execCatchIO' but with the arguments 'Prelude.flip'ped. +execHandleIO :: [ExecHandler a] -> Exec a -> Exec a +execHandleIO = flip execCatchIO + +-- | An 'ExecHandler' for catching 'Control.Exception.ErrorCall's and re-throwing them to the +-- 'Procedural' monad using 'Control.Monad.Error.throwError', allowing the exception to be caught +-- and handled by Dao script code. +execIOHandler :: ExecHandler () +execIOHandler = newExecIOHandler $ flip (execThrow "") [] . ExecIOException + +-- | An 'ExecHandler' for catching 'Control.Exception.ErrorCall's and re-throwing them to the +-- 'Procedural' monad using 'Control.Monad.Error.throwError', allowing the exception to be caught +-- and handled by Dao script code. +execErrorHandler :: ExecHandler () +execErrorHandler = newExecIOHandler $ flip (execThrow "") [] . ExecHaskellError + +-- | This will catch an 'ExecControl' thrown by 'Control.Monad.Error.throwError', but re-throw +-- 'ExecError's. +catchReturn :: (Maybe Object -> Exec a) -> Exec a -> Exec a +catchReturn catch f = catchPredicate f >>= \pval -> case pval of + PFail (ExecReturn a) -> catch a + pval -> predicate pval + +---------------------------------------------------------------------------------------------------- +-- $StackOperations +-- Operating on the local stack. + +-- | Push a new empty local-variable context onto the stack. Does NOT 'catchReturnObj', so it can be +-- used to push a new context for every level of nested if/else/for/try/catch statement, or to +-- evaluate a macro, but not a function call. Use 'execFuncPushStack' to perform a function call within +-- a function call. The stack is always poped when this function is done evaluating, even if the +-- given 'Exec' function evaluates to 'Control.Monad.mzero' or 'Control.Monad.Error.throwError'. +execNested :: T_dict -> Exec a -> Exec (a, T_dict) +execNested init exe = do + store <- gets execStack + modify $ \xunit -> xunit{ execStack = stackPush init store } + result <- catchPredicate exe + store <- gets execStack + (store, dict) <- pure (stackPop store) + modify $ \xunit -> xunit{ execStack = store } + result <- predicate result + return (result, dict) + +-- | Like 'execNested' but immediately disgards the local variables when the inner 'Exec' function +-- has completed evaluation. +execNested_ :: T_dict -> Exec a -> Exec a +execNested_ init = fmap fst . execNested init + +-- | Keep the current 'execStack', but replace it with a new empty stack before executing the given +-- function. This function is different from 'nestedExecStak' in that it acually removes the current +-- execution stack so a function call cannot modify the local variables of the function which called +-- it. Furthermore it catches evaluation of a "return" statement allowing the function which called +-- it to procede with execution after this call has returned. +execFuncPushStack :: T_dict -> Exec (Maybe Object) -> Exec (Maybe Object, T_dict) +execFuncPushStack dict exe = execNested dict (catchPredicate exe) >>= \ (pval, dict) -> case pval of + OK o -> return (o, dict) + Backtrack -> mzero + PFail err -> case err of + ExecReturn o -> return (o, dict) + ExecError{execErrorSubtype=ExecLoopCtrl ctrl} -> throwError $ + err{execErrorSubtype=ExecLoopCtrl $ ctrl{loopCtrlEscaped=False}} + err -> throwError err + +execFuncPushStack_ :: T_dict -> Exec (Maybe Object) -> Exec (Maybe Object) +execFuncPushStack_ dict = fmap fst . execFuncPushStack dict + +execWithStaticStore :: Subroutine -> Exec a -> Exec a +execWithStaticStore sub exe = do + store <- gets currentCodeBlock + modify (\st -> st{ currentCodeBlock=Just sub }) + result <- catchPredicate exe + modify (\st -> st{ currentCodeBlock=store }) + predicate result + +execWithWithRefStore :: Object -> Exec a -> Exec a +execWithWithRefStore o exe = do + store <- gets currentWithRef + modify (\st -> st{ currentWithRef=Just o }) + result <- catchPredicate exe + modify (\st -> st{ currentWithRef=store }) + predicate result + +withExecTokenizer :: ExecTokenizer -> Exec a -> Exec a +withExecTokenizer newtokzer f = do + oldtokzer <- gets programTokenizer + modify $ \xunit -> xunit{ programTokenizer=newtokzer } + p <- catchPredicate f + modify $ \xunit -> xunit{ programTokenizer=oldtokzer } + predicate p + +---------------------------------------------------------------------------------------------------- + +instance (Typeable a, ObjectClass a) => ToDaoStructClass (Com a) where + toDaoStruct = renameConstructor "Com" $ do + co <- ask + let put o = "com" .= obj o + case co of + Com o -> put o >> return () + ComBefore c1 o -> "before" .= c1 >> put o >> return () + ComAfter o c2 -> put o >> "after" .= c2 >> return () + ComAround c1 o c2 -> "before" .= c1 >> put o >> "after" .= c2 >> return () + +instance (Typeable a, ObjectClass a) => FromDaoStructClass (Com a) where + fromDaoStruct = do + constructor "Com" + let f name = tryField name (maybe (fail name) return . fromObj) + before <- optional $ f "before" + after <- optional $ f "after" + o <- req "com" + return $ maybe (Com o) id $ msum $ + [ return ComAround <*> before <*> pure o <*> after + , return ComBefore <*> before <*> pure o + , return ComAfter <*> pure o <*> after + ] + +instance (Typeable a, ObjectClass a) => + ObjectClass (Com a) where { obj=new; fromObj=objFromHata; } +instance (Typeable a, ObjectClass a) => HataClass (Com a) where + haskellDataInterface = interface "Com" $ do + autoDefToStruct >> autoDefFromStruct + +instance (Typeable a, ObjectClass a) => + ObjectClass [Com a] where { obj=listToObj; fromObj=listFromObj; } + +---------------------------------------------------------------------------------------------------- + +setupCodeBlock :: CodeBlock Object -> Subroutine +setupCodeBlock scrp = + Subroutine + { origSourceCode = scrp + , staticVars = mempty + , staticRules = mempty + , staticLambdas = [] + , executable = execute scrp >> return Nothing + } + +-- binary 0xDD +instance B.Binary (CodeBlock Object) MTab where + put (CodeBlock o) = B.prefixByte 0xDD $ B.put o + get = B.tryWord8 0xDD $ CodeBlock <$> B.get + +instance Executable (CodeBlock Object) () where { execute (CodeBlock ox) = mapM_ execute ox } + +instance ObjectClass (CodeBlock Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (CodeBlock Object) where + haskellDataInterface = interface "CodeBlock" $ do + autoDefNullTest >> autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt >> autoDefPPrinter + defDeref $ \o -> catchError (execute o >> return Nothing) $ \e -> case e of + ExecReturn o -> return o + ExecError{} -> throwError e + -- TODO: define autoDefIterator, defIndexer, autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- | A subroutine is contains a 'CodeBlock' and an 'Data.IORef.IORef' to it's own static data. It +-- also has a reference to the last evaluation of 'execute' over it's 'CodeBlock', which provides a +-- hint to the Haskell runtime system that this code can be cached rather than evaluating the +-- 'CodeBlock' fresh every time. In a sense, it is a "live" 'CodeBlock' that can actually be +-- executed. +data Subroutine + = Subroutine + { origSourceCode :: CodeBlock Object + , staticVars :: T_dict + , staticRules :: PatternTree Object [Subroutine] + , staticLambdas :: [CallableCode] + , executable :: Exec (Maybe Object) + } + deriving Typeable + +instance Eq Subroutine where { a==b = origSourceCode a == origSourceCode b } + +instance Ord Subroutine where { compare a b = compare (origSourceCode a) (origSourceCode b) } + +instance Show Subroutine where { show o = "Subroutine "++show (codeBlock (origSourceCode o)) } + +instance NFData Subroutine where { rnf (Subroutine a _ _ _ _) = deepseq a () } + +instance HasNullValue Subroutine where + nullValue = + Subroutine + { origSourceCode = nullValue + , staticVars = mempty + , staticRules = mempty + , staticLambdas = [] + , executable = return Nothing + } + testNull (Subroutine a _ _ _ _) = testNull a + +instance PPrintable Subroutine where + pPrint = pPrint . flip MetaEvalExpr LocationUnknown . origSourceCode + +instance ToDaoStructClass Subroutine where + toDaoStruct = renameConstructor "Subroutine" $ do + "code" .=@ origSourceCode + "vars" .=@ staticVars + "rules" .=@ (\rs -> RuleSet{ ruleSetRules=rs, ruleSetTokenizer=Nothing }) . staticRules + "lambdas" .=@ staticLambdas + +instance FromDaoStructClass Subroutine where + fromDaoStruct = do + constructor "Subroutine" + sub <- setupCodeBlock <$> req "code" + vars <- req "vars" + (RuleSet{ ruleSetRules=rules }) <- req "rules" + lambdas <- req "lambdas" + return $ sub{ staticVars=vars, staticRules=rules, staticLambdas=lambdas } + +instance Executable Subroutine (Maybe Object) where + execute sub = execWithStaticStore sub $ + catchReturn return ((execute (origSourceCode sub) :: Exec ()) >> return Nothing) :: Exec (Maybe Object) + +instance ObjectClass Subroutine where { obj=new; fromObj=objFromHata; } + +instance HataClass Subroutine where + haskellDataInterface = interface "Subroutine" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +-- | Although 'Subroutine' instantiates 'Executable', this function allows you to easily place a +-- group of defined local variables onto the call stack before and the have the 'Subroutine' +-- executed. +runCodeBlock :: T_dict -> Subroutine -> Exec (Maybe Object, T_dict) +runCodeBlock initStack sub = execWithStaticStore sub $ + execFuncPushStack initStack (executable sub >>= liftIO . evaluate) + +runCodeBlock_ :: T_dict -> Subroutine -> Exec (Maybe Object) +runCodeBlock_ initStack = fmap fst . runCodeBlock initStack + +---------------------------------------------------------------------------------------------------- + +data RuleSet + = RuleSet + { ruleSetRules :: PatternTree Object [Subroutine] + , ruleSetTokenizer :: Maybe ExecTokenizer + } + deriving Typeable + +instance HasNullValue RuleSet where + nullValue = RuleSet{ ruleSetRules=nullValue, ruleSetTokenizer=Nothing } + testNull (RuleSet{ruleSetRules=r, ruleSetTokenizer=tok}) = + testNull r && maybe True (const False) tok + +instance Monoid RuleSet where + mempty = nullValue + mappend (RuleSet{ruleSetRules=a, ruleSetTokenizer=tokA}) (RuleSet{ruleSetRules=b, ruleSetTokenizer=tokB}) = + RuleSet{ ruleSetRules=mappend a b, ruleSetTokenizer=mplus tokA tokB } + +instance Sizeable RuleSet where { getSizeOf = return . obj . T.size . ruleSetRules } + +instance PPrintable RuleSet where + pPrint (RuleSet{ ruleSetRules=tree }) = pList (pString "RuleSet") "{ " ", " "}" $ + T.assocs tree >>= \ (ix, subs) -> do + let rule ix = case ix of + [] -> "" + Single (OString s) : ix -> uchars s ++ rule ix + Single o : ix -> prettyShow o ++ rule ix + i : ix -> show i ++ rule ix + sub <- subs + [ pClosure (pString "rule " >> pShow (rule ix)) "{" "}" $ + map pPrint $ codeBlock $ origSourceCode sub ] + +instance ObjectClass RuleSet where { obj=new ; fromObj=objFromHata; } + +instance HataClass RuleSet where + haskellDataInterface = interface "RuleSet" $ do + autoDefNullTest >> autoDefSizeable >> autoDefPPrinter + let qrefRuleSet = reference UNQUAL (ustr "RuleSet") + let initParams ox = case ox of + [] -> return $ RuleSet{ ruleSetRules=mempty, ruleSetTokenizer=Nothing } + [o] -> do + let err :: Exec RuleSet + err = throwBadTypeError "" o [(errInConstr, obj qrefRuleSet)] + maybe err return $ do + fromObj o >>= \ (Hata ifc _) -> objCallable ifc + let tok = ExecTokenizer $ \ox -> do + toks <- fst <$> callObject (RefObject o NullRef) o [obj ox] + mplus (xmaybe $ toks >>= fromObj) $ + execThrow "tokenizer for rule function did not return a list of objects" ExecErrorUntyped [] + return $ RuleSet{ ruleSetRules=mempty, ruleSetTokenizer=Just tok } + _ -> throwArityError "" 1 ox [(errInInitzr, obj qrefRuleSet)] + -- TODO: ^ the constructor for a 'PatternTree' should take tokenizer function. + let listParams tree = + foldM (\ rs@(RuleSet{ruleSetRules=tree, ruleSetTokenizer=maybeTok}) (i, o) -> case o of + InitSingle o -> case fromObj o >>= \ (Hata _ d) -> fromDynamic d of + Nothing -> throwBadTypeError "expecting rule or RuleSet" o $ + [(errInFunc, obj qrefRuleSet), (errInConstr, OInt i)] + Just p -> do + newtree <- maybe id withExecTokenizer maybeTok $ execute (p::PatternRule) + return $ rs{ ruleSetRules=T.unionWith (++) tree newtree } + InitAssign{} -> fail "cannot use assignment expression in initializer of RuleSet" + ) tree . zip [1..] + defInitializer initParams listParams + defInfixOp ORB $ \ _ rs o -> fmap (obj . mappend rs) $ mplus (xmaybe $ fromObj o) $ + (throwBadTypeError "when uninioning RuleSet values" o []) + let run f = + daoFunc + { daoForeignFunc = \rs -> + runTokenizer >=> makeActionsForQuery [ruleSetRules rs] >=> fmap (flip (,) rs) . f + } + defMethod "query" $ run $ return . Just . obj . fmap obj + defMethod "do" $ run $ msum . fmap execute + defMethod "doAll" $ run $ fmap (Just . obj . fmap obj) . execute + defMethod "tokenize" $ + daoFunc + { daoForeignFunc = \rs -> fmap (flip (,) rs . Just . obj) . + maybe runTokenizer runTokenizerWith (ruleSetTokenizer rs) + } + +---------------------------------------------------------------------------------------------------- + +-- | A subroutine is specifically a callable function (but we don't use the name Function to avoid +-- confusion with Haskell's "Data.Function"). +data CallableCode + = CallableCode + { argsPattern :: ParamListExpr Object + , returnType :: ObjType + , codeSubroutine :: Subroutine + } + deriving (Show, Typeable) + +-- Used by the instantiation of CallableCode and PatternRule into the PPrintable class. +ppCallableAction :: String -> PPrint -> ObjType -> Subroutine -> PPrint +ppCallableAction what pats typ exe = + pClosure (pString what >> pats >> pPrint typ) "{" "}" (map pPrint (codeBlock (origSourceCode exe))) + +-- | Interface used during evaluation of Dao scripts to determine whether or not an if or while +-- statement should continue. Also, turns out to be handy for plenty of other reasons. +instance HasNullValue CallableCode where + nullValue = + CallableCode{argsPattern=nullValue, returnType=nullValue, codeSubroutine=nullValue} + testNull (CallableCode a b c) = testNull a && testNull b && testNull c + +instance NFData CallableCode where { rnf (CallableCode a b _) = deepseq a $! deepseq b () } + +instance PPrintable [CallableCode] where + pPrint = sequence_ . intersperse (pString " ^ ") . + fmap (\ (CallableCode pats ty exe) -> ppCallableAction "function" (pPrint pats) ty exe >> pEndLine) + +instance ObjectClass [CallableCode] where { obj=new; fromObj=objFromHata; } + +instance HataClass [CallableCode] where + haskellDataInterface = interface "Function" $ do + autoDefNullTest >> autoDefPPrinter + defCallable return + defInfixOp XORB $ \ _ a o -> case fromObj o of + Just b -> return $ obj (a++b) + Nothing -> fail "left-hand side of bitwise-XOR operator (^) is a Function, right hand side is not" + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_CodeBlock Object) where + toDaoStruct = renameConstructor "CodeBlock" $ "list" .=@ getAST_CodeBlock + +instance FromDaoStructClass (AST_CodeBlock Object) where + fromDaoStruct = constructor "CodeBlock" >> AST_CodeBlock <$> req "list" + +instance ObjectClass (AST_CodeBlock Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_CodeBlock Object) where + haskellDataInterface = interface "CodeBlockExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0xC5 0xC7 +instance B.Binary a MTab => B.Binary (TyChkExpr a Object) MTab where + put o = case o of + NotTypeChecked a -> B.prefixByte 0xC5 $ B.put a + TypeChecked a b c -> B.prefixByte 0xC6 $ B.put a >> B.put b >> B.put c + DisableCheck a b c d -> B.prefixByte 0xC7 $ B.put a >> B.put b >> B.put c >> B.put d + get = B.word8PrefixTable <|> fail "expecting TyChkExpr" + +instance B.Binary a MTab => B.HasPrefixTable (TyChkExpr a Object) B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "TyChkExpr" 0xC5 0xC7 $ + [ NotTypeChecked <$> B.get + , return TypeChecked <*> B.get <*> B.get <*> B.get + , return DisableCheck <*> B.get <*> B.get <*> B.get <*> B.get + ] + +instance (Eq a, Ord a, Typeable a, ObjectClass a) => + ObjectClass (TyChkExpr Object a) where { obj=new; fromObj=objFromHata; } + +instance (Eq a, Ord a, Typeable a, ObjectClass a) => + HataClass (TyChkExpr Object a) where + haskellDataInterface = interface "TypedExec" $ do + autoDefEquality >> autoDefOrdering + +---------------------------------------------------------------------------------------------------- + +instance ObjectClass a => ToDaoStructClass (AST_TyChk a Object) where + toDaoStruct = ask >>= \o -> case o of + AST_NotChecked o -> renameConstructor "UntypedExpression" $ "expr" .= obj o + AST_Checked o coms typ loc -> renameConstructor "TypedExpression" $ do + "expr" .= obj o + "colon" .= coms + "typeExpr" .= typ + putLocation loc + +instance (Typeable a, ObjectClass a) => FromDaoStructClass (AST_TyChk a Object) where + fromDaoStruct = msum $ + [do constructor "UntypedExpression" + AST_NotChecked <$> req "expr" + ,do constructor "TypedExpression" + return AST_Checked <*> req "expr" <*> req "colon" <*> req "typeExpr" <*> location + ] + +instance (Eq a, Ord a, PPrintable a, Typeable a, ObjectClass a) => + ObjectClass (AST_TyChk a Object) where { obj=new; fromObj=objFromHata; } + +instance (Eq a, Ord a, PPrintable a, Typeable a) => HataClass (AST_TyChk a Object) where + haskellDataInterface = interface "TypedExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + -- autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0xCF 0xD0 +instance B.Binary (ParamExpr Object) MTab where + put (ParamExpr True a b) = B.prefixByte 0xCF $ B.put a >> B.put b + put (ParamExpr False a b) = B.prefixByte 0xD0 $ B.put a >> B.put b + get = B.word8PrefixTable <|> fail "expecting ParamExpr" + +instance B.HasPrefixTable (ParamExpr Object) B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "ParamExpr" 0xCF 0xD0 $ + [ return (ParamExpr True ) <*> B.get <*> B.get + , return (ParamExpr False) <*> B.get <*> B.get + ] + +instance ObjectClass (ParamExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (ParamExpr Object) where + haskellDataInterface = interface "ParamExpr" $ do + autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_Param Object) where + toDaoStruct = ask >>= \o -> case o of + AST_NoParams -> makeNullary "NoParameters" + AST_Param coms tychk loc -> renameConstructor "Parameter" $ do + maybe (return ()) putComments coms + "typeCheck" .= tychk + putLocation loc + +instance FromDaoStructClass (AST_Param Object) where + fromDaoStruct = msum $ + [ nullary "NoParameters" >> return AST_NoParams + , constructor "Parameter" >> return AST_Param <*> optComments <*> req "typeCheck" <*> location + ] + +instance ObjectClass (AST_Param Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_Param Object) where + haskellDataInterface = interface "ParameterExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0xD6 +instance B.Binary (ParamListExpr Object) MTab where + put (ParamListExpr tyChk loc) = B.prefixByte 0xD6 $ B.put tyChk >> B.put loc + get = B.word8PrefixTable <|> fail "expecting ParamListExpr" + +instance B.HasPrefixTable (ParamListExpr Object) B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "ParamListExpr" 0xD6 0xD6 $ + [return ParamListExpr <*> B.get <*> B.get] + +instance ObjectClass (ParamListExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (ParamListExpr Object) where + haskellDataInterface = interface "ParameterList" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_ParamList Object) where + toDaoStruct = ask >>= \o -> case o of + AST_ParamList tychk loc -> renameConstructor "ParamList" $ do + "typeCheck" .= tychk + putLocation loc + +instance FromDaoStructClass (AST_ParamList Object) where + fromDaoStruct = constructor "ParamList" >> return AST_ParamList <*> req "typeCheck" <*> location + +instance ObjectClass (AST_ParamList Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_ParamList Object) where + haskellDataInterface = interface "ParameterListExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0x7A 0x7B +instance B.Binary (RuleHeadExpr Object) MTab where + put o = case o of + RuleStringExpr a b -> B.prefixByte 0x7A $ B.put a >> B.put b + RuleHeadExpr a b -> B.prefixByte 0x7B $ B.put a >> B.put b + get = B.word8PrefixTable <|> fail "expecting RuleHeadExpr" + +instance B.HasPrefixTable (RuleHeadExpr Object) B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "RuleHeadExpr" 0x7A 0x7B + [ return RuleStringExpr <*> B.get <*> B.get + , return RuleHeadExpr <*> B.get <*> B.get + ] + +instance Executable (RuleHeadExpr Object) [Object] where + execute o = case o of + RuleStringExpr r _ -> return [obj r] + RuleHeadExpr r _ -> forM r $ + execute . DerefAssignExpr >=> checkVoid (getLocation o) "item in rule header" + +instance ObjectClass (RuleHeadExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (RuleHeadExpr Object) where + haskellDataInterface = interface "RuleHeader" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_RuleHeader Object) where + toDaoStruct = ask >>= \o -> case o of + AST_NullRules coms loc -> renameConstructor "NoStrings" $ do + putComments coms >> putLocation loc + AST_RuleString itm loc -> renameConstructor "StringItem" $ do + "items" .= itm >> putLocation loc + AST_RuleHeader lst loc -> renameConstructor "ValuesList" $ do + "items" .= lst >> putLocation loc + +instance FromDaoStructClass (AST_RuleHeader Object) where + fromDaoStruct = msum $ + [ constructor "NoStrings" >> return AST_NullRules <*> comments <*> location + , constructor "StringItem" >> return AST_RuleString <*> req "items" <*> location + , constructor "ValuesList" >> return AST_RuleHeader <*> reqList "items" <*> location + ] + +instance ObjectClass (AST_RuleHeader Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_RuleHeader Object) where + haskellDataInterface = interface "RuleHeaderExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- $Exec_helpers +-- Functions for working with object values when building built-in functions callable from within a +-- dao script. + +asReference :: Object -> XPure Reference +asReference = xmaybe . fromObj + +_getRuleSetParam :: [Object] -> Exec (Maybe RuleSet, [Object]) +_getRuleSetParam ox = return $ case ox of + [] -> (Nothing, []) + o:ox -> maybe ((Nothing, o:ox)) (\o -> (Just o, ox)) (fromObj o) + +-- Checks the list of parameters, and if there are more than one, checks if the first parameter is +-- an 'OHaskell' object which can be converted to 'CallableCode' using 'objToCallable'. If so, the +-- callables are returned and the results of pattern matching can be used as parameters to these +-- functions. +_getFuncStringParams :: [Object] -> Exec (Maybe [CallableCode], [UStr]) +_getFuncStringParams ox = case ox of + [] -> fail "no parameters passed to function" + [o] -> (,) Nothing <$> oneOrMoreStrings [o] + o:lst -> do + calls <- (Just <$> objToCallable o) <|> return Nothing + (,) calls <$> oneOrMoreStrings lst + where + oneOrMoreStrings ox = case concatMap extractStringElems ox of + [] -> fail "parameter arguments contain no string values" + ox -> return ox + +asInteger :: Object -> XPure Integer +asInteger o = case o of + OWord o -> return (toInteger o) + OInt o -> return (toInteger o) + OLong o -> return o + OFloat o -> return (round o) + ORatio o -> return (round o) + ORelTime o -> return (round (toRational o)) + _ -> mzero + +asRational :: Object -> XPure Rational +asRational o = case o of + OInt o -> return (toRational o) + OWord o -> return (toRational o) + OLong o -> return (toRational o) + OFloat o -> return (toRational o) + ORelTime o -> return (toRational o) + ORatio o -> return o + OComplex o | imagPart o == 0 -> return (toRational (realPart o)) + _ -> mzero + +asComplex :: Object -> XPure T_complex +asComplex o = case o of + OComplex o -> return o + o -> asRational o >>= return . flip complex 0 . fromRational + +-- | A function which is basically the absolute value function, except it also works on 'Complex' +-- numbers, returning the magnitude of the number if it is 'Complex'. +asPositive :: Object -> XPure Object +asPositive o = case o of + OInt o -> return (OInt $ abs o) + OWord o -> return (OWord o) + OLong o -> return (OLong $ abs o) + OFloat o -> return (OFloat $ abs o) + ORelTime o -> return (ORelTime $ abs o) + OComplex o -> return (OFloat $ magnitude o) + _ -> mzero + +-- | Remove one layer of 'OList' objects, i.e. any objects in the list that are 'OList' constructors +-- will have the contents of those lists concatenated, and all non-'OList' constructors are treated +-- as lists of single objects. Also returns the number of concatenations. +objConcat :: [Object] -> (Int, [Object]) +objConcat ox = (sum a, concat b) where + (a, b) = unzip (ox >>= \o -> maybe [(0, [o])] (return . (,) 1) (fromObj o)) + +-- | Checks if an 'Object' is a numerical type, returns the numeric 'CoreType' if so, evaluates to +-- 'Control.Monad.mzero' if not. +isNumeric :: Object -> XPure CoreType +isNumeric o = do + let t = coreType o + guard (CharType <= t && t <= ComplexType) + return t + +eval_Prefix_op :: ArithPfxOp -> Object -> XPure Object +eval_Prefix_op op o = join $ xmaybe $ + fromObj o >>= \ (Hata ifc o) -> objArithPfxOpTable ifc >>= (! op) >>= \f -> return (f op o) + +-- Pass the 'InfixOp' associated with the 'Prelude.Num' function so it can check whether the +-- 'defInfixOp' for that operator has been defined for objects of 'HaskellType'. +eval_Infix_op :: InfixOp -> Object -> Object -> XPure Object +eval_Infix_op op a b = join $ xmaybe $ onhask a b <|> (guard isCommut >> onhask b a) where + isCommut = infixOpCommutativity op + onhask a b = fromObj a >>= \ (Hata ifc a) -> + (\f -> f op a b) <$> (objInfixOpTable ifc >>= (! op)) + +_evalNumOp1 :: (forall a . Num a => a -> a) -> Object -> XPure Object +_evalNumOp1 f o = case o of + OChar o -> return $ OChar $ chr $ mod (f $ ord o) (ord maxBound) + OInt o -> return $ OInt $ f o + OWord o -> return $ OWord $ f o + OLong o -> return $ OLong $ f o + ORelTime o -> return $ ORelTime $ f o + OFloat o -> return $ OFloat $ f o + ORatio o -> return $ ORatio $ f o + OComplex o -> return $ OComplex $ f o + _ -> mzero + +-- Evaluate a 2-ary function for any core type that instantiates the 'Prelude.Num' class. +_evalNumOp2 :: (forall a . Num a => a -> a -> a) -> Object -> Object -> XPure Object +_evalNumOp2 f a b = do + let t = max (coreType a) (coreType b) + a <- castToCoreType t a + b <- castToCoreType t b + case (a, b) of + (OChar a, OChar b) -> return $ OChar $ chr $ mod (f (ord a) (ord b)) (ord maxBound) + (OInt a, OInt b) -> return $ OInt $ f a b + (OWord a, OWord b) -> return $ OWord $ f a b + (OLong a, OLong b) -> return $ OLong $ f a b + (ORelTime a, ORelTime b) -> return $ ORelTime $ f a b + (OFloat a, OFloat b) -> return $ OFloat $ f a b + (ORatio a, ORatio b) -> return $ ORatio $ f a b + (OComplex a, OComplex b) -> return $ OComplex $ f a b + _ -> mzero + +instance Num (XPure Object) where + a + b = a >>= \a -> b >>= \b -> case (a, b) of + (OString a, OString b) -> return $ OString $ a<>b + (OBytes a, OBytes b) -> return $ OBytes $ a<>b + (OList a, OList b) -> return $ OList $ a++b + (ODict a, ODict b) -> return $ ODict $ M.union b a + (a, b) -> _evalNumOp2 (+) a b <|> eval_Infix_op ADD a b + a * b = a >>= \a -> case a of + OList ax -> OList <$> mapM ((* b) . xpure) ax + ODict ax -> (ODict . M.fromList) <$> + mapM (\ (key, a) -> fmap ((,) key) (xpure a * b)) (M.assocs ax) + a -> b >>= \b -> case b of + OList bx -> OList <$> mapM (((xpure a) *) . xpure) bx + ODict bx -> (ODict . M.fromList) <$> + mapM (\ (key, b) -> fmap ((,) key) (xpure a * xpure b)) (M.assocs bx) + b -> _evalNumOp2 (*) a b <|> eval_Infix_op MULT a b + a - b = a >>= \a -> b >>= \b -> case a of + -- on strings, the inverse operation of "join(b, a)", every occurence of b from a. + OString a -> case b of + OString b -> return $ OString $ mconcat $ splitString a b + _ -> mzero + -- on lists, removes the item b from the list a + OList a -> return $ OList $ filter (/= b) a + ODict a -> case b of + ODict b -> return $ ODict $ M.difference a b + ORef (Reference UNQUAL b NullRef) -> return $ ODict $ M.delete b a + ORef _ -> + execThrow "dictionary key must be a single unqualified name" ExecErrorUntyped [(assertFailed, b)] + _ -> mzero + a -> _evalNumOp2 (-) a b <|> eval_Infix_op SUB a b + negate a = (a >>= _evalNumOp1 negate) <|> (a >>= eval_Prefix_op NEGTIV) + abs a = (a >>= _evalNumOp1 abs ) <|> (a >>= eval_Prefix_op NEGTIV) + signum a = a >>= _evalNumOp1 signum + fromInteger = return . obj + +_xpureApplyError :: String -> String -> a +_xpureApplyError name msg = error $ concat $ concat $ + [["cannot evaluate ", name], guard (not $ null msg) >> [": ", msg]] + +_xpureApply2 :: String -> (Object -> Object -> a) -> XPure Object -> XPure Object -> a +_xpureApply2 name f a b = case evalXPure ab of + PFail e -> _xpureApplyError name (prettyShow e) + Backtrack -> _xpureApplyError name "" + OK o -> o + where + ab = do + ta <- coreType <$> a + tb <- coreType <$> b + let t = max ta tb + a <- a >>= castToCoreType t + b <- b >>= castToCoreType t + return (f a b) + +_xpureApply1 :: String -> (Object -> XPure a) -> XPure Object -> a +_xpureApply1 name f o = case evalXPure $ o >>= f of + PFail e -> _xpureApplyError name (prettyShow e) + Backtrack -> _xpureApplyError name "" + OK o -> o + +_xpureMaybeApply1 :: (Object -> XPure a) -> XPure Object -> Maybe a +_xpureMaybeApply1 f o = case evalXPure $ o >>= f of + PFail _ -> Nothing + Backtrack -> Nothing + OK o -> Just o + +instance Eq (XPure Object) where + (==) = _xpureApply2 "(==)" (==) + (/=) = _xpureApply2 "(/=)" (/=) + +instance Ord (XPure Object) where + compare = _xpureApply2 "compare" compare + (<) = _xpureApply2 "(<)" (<) + (<=) = _xpureApply2 "(<=)" (<=) + (>) = _xpureApply2 "(>)" (>) + (>=) = _xpureApply2 "(>=)" (>=) + +instance Real (XPure Object) where + toRational = _xpureApply1 "toRational" $ castToCoreType LongType >=> xmaybe . fromObj + +eval_Int_op1 :: String -> (forall a . Integral a => a -> a) -> XPure Object -> XPure Object +eval_Int_op1 name f o = o >>= \o -> case o of + OChar o -> return $ OChar (chr $ flip mod (ord maxBound) $ f $ ord o) + OInt o -> return $ OInt (f o) + OWord o -> return $ OWord (f o) + OLong o -> return $ OLong (f o) + _ -> throwBadTypeError "wrong data type for object passed to function" o $ + [(errInFunc, obj (ustr name :: Name))] + +_xpureCastTo :: XPure CoreType -> XPure Object -> XPure Object +_xpureCastTo typ a = join $ xpure castToCoreType <*> typ <*> a + +-- In order for @('XPure' 'Object')@ to be used with the 'Prelude.Div' and 'Prelude.mod' functions, +-- it must instantiate 'Integral', which means it must instantiate 'Prelude.Enum'. This +-- instantiation is an attempt at making the functions behave as they would for ordinary enumerated +-- data types; it is /NOT/ pretty, but it basically works. +instance Enum (XPure Object) where + succ = eval_Int_op1 "succ" succ + pred = eval_Int_op1 "pred" pred + toEnum = return . obj + fromEnum = _xpureApply1 "fromEnum" $ castToCoreType IntType >=> xmaybe . fromObj + enumFrom = fix (\loop o -> o : loop (succ o)) + enumFromThen lo hi = fix (\loop o -> o : loop (hi-lo+o)) lo + enumFromTo a b = + if maybe False (const True) (extractXPure typ) + then case compare aa bb of + EQ -> repeat aa + LT -> loop ( loop (>bb) (negate inc) aa + else [] + where + loop ok inc a = a : let b = a+inc in if ok b then loop ok inc b else [] + typ = a >>= \a -> b >>= \b -> do + let t = max (coreType a) (coreType b) + guard (CharType <= t && t <= ComplexType) >> xpure t + inc = typ >>= flip castToCoreType (OChar '\x01') + aa = _xpureCastTo typ a + bb = _xpureCastTo typ b + enumFromThenTo a b c = + if maybe False (const True) $ extractXPure typ + then case compare aa bb of + EQ -> repeat aa + LT -> if aa if aa>cc then loop (>cc) aa else [] + else [] + where + loop ok a = a : let b = a+inc in if ok b then loop ok b else [] + typ = a >>= \a -> b >>= \b -> c >>= \c -> do + let t = max (coreType a) $ max (coreType b) $ (coreType c) + guard (CharType <= t && t <= RatioType) >> xpure t + inc = bb-aa + aa = _xpureCastTo typ a + bb = _xpureCastTo typ b + cc = _xpureCastTo typ c + +_xpureDivFunc + :: String + -> (forall a . Integral a => a -> a -> (a, a)) + -> XPure Object -> XPure Object -> (XPure Object, XPure Object) +_xpureDivFunc name div a b = _xpureApply2 name f aa bb where + f a b = case (a, b) of + (OChar a, OChar b) -> pair (ord a) (ord b) (OChar . chr) + (OInt a, OInt b) -> pair a b OInt + (OWord a, OWord b) -> pair a b OWord + (OLong a, OLong b) -> pair a b OLong + _ -> (mzero, mzero) + pair a b constr = let (c, d) = div a b in (xpure $ constr c, xpure $ constr d) + typ = a >>= \a -> b >>= \b -> do + let t = max (coreType a) (coreType b) + guard (CharType <= t && t <= LongType) >> xpure t + aa = _xpureCastTo typ a + bb = _xpureCastTo typ b + +instance Integral (XPure Object) where + toInteger = _xpureApply1 "toInteger" (castToCoreType LongType >=> xmaybe . fromObj) + quotRem a b = _xpureDivFunc "quoteRem" quotRem a b + divMod a b = _xpureDivFunc "divMod" divMod a b + div a b = a >>= \a -> b >>= \b -> case (a, b) of + (OString a, OString b) -> return $ OWord $ fromIntegral $ length $ splitString a b + _ -> fst (_xpureDivFunc "(/)" divMod (xpure a) (xpure b)) <|> eval_Infix_op DIV a b + mod a b = a >>= \a -> b >>= \b -> case (a, b) of + (OString a, OString b) -> return $ OList $ map OString $ splitString a b + _ -> snd (_xpureDivFunc "(%)" divMod (xpure a) (xpure b)) <|> eval_Infix_op MOD a b + +_xpureFrac :: (forall a . Floating a => a -> a) -> XPure Object -> XPure Object +_xpureFrac f a = a >>= \a -> case a of + ORelTime a -> xpure $ ORelTime $ fromRational $ toRational $ + f (fromRational (toRational a) :: Double) + OFloat a -> xpure $ OFloat $ f a + ORatio a -> xpure $ ORatio $ toRational $ f $ (fromRational a :: Double) + OComplex a -> xpure $ OComplex $ f a + _ -> mzero + +_xpureFrac2 :: (forall a . Floating a => a -> a -> a) -> XPure Object -> XPure Object -> XPure Object +_xpureFrac2 f a b = a >>= \a -> b >>= \b -> do + let t = max (coreType a) (coreType b) + a <- castToCoreType t a + b <- castToCoreType t b + case (a, b) of + (ORelTime a, ORelTime b) -> xpure $ ORelTime $ fromRational $ toRational $ + f (fromRational (toRational a) :: Double) (fromRational (toRational b) :: Double) + (OFloat a, OFloat b) -> xpure $ OFloat $ f a b + (ORatio a, ORatio b) -> xpure $ ORatio $ toRational $ + f (fromRational a :: Double) (fromRational b :: Double) + (OComplex a, OComplex b) -> xpure $ OComplex $ f a b + _ -> mzero + +instance Fractional (XPure Object) where + a / b = _xpureFrac2 (/) a b + recip = _xpureFrac recip + fromRational = xpure . ORatio + +instance Floating (XPure Object) where + pi = xpure $ OFloat pi + logBase = _xpureFrac2 logBase + (**) a b = _xpureFrac2 (**) a b + exp = _xpureFrac exp + sqrt = _xpureFrac sqrt + log = _xpureFrac log + sin = _xpureFrac sin + tan = _xpureFrac tan + cos = _xpureFrac cos + asin = _xpureFrac asin + atan = _xpureFrac atan + acos = _xpureFrac acos + sinh = _xpureFrac sinh + tanh = _xpureFrac tanh + cosh = _xpureFrac cosh + asinh = _xpureFrac asinh + atanh = _xpureFrac atanh + acosh = _xpureFrac acosh + +_xpureRealFrac :: Integral b => String -> (forall a . RealFrac a => a -> b) -> XPure Object -> b +_xpureRealFrac name f = _xpureApply1 name $ \o -> case o of + ORelTime a -> xpure $ f a + OFloat a -> xpure $ f a + ORatio a -> xpure $ f a + _ -> mzero + +instance RealFrac (XPure Object) where + properFraction = let name = "properFraction" in _xpureApply1 name $ \o -> case o of + ORelTime o -> f ORelTime o + OFloat o -> f OFloat o + ORatio o -> f ORatio o + _ -> xpure (error $ "cannot evaluate properFraction on object "++prettyShow o, mzero) + where { f constr o = let (i, b) = properFraction o in xpure (i, xpure $ constr b) } + truncate = _xpureRealFrac "truncate" truncate + round = _xpureRealFrac "round" round + ceiling = _xpureRealFrac "ceiling" ceiling + floor = _xpureRealFrac "floor" floor + +_xpureBits :: (forall a . Bits a => a -> a) -> (B.ByteString -> B.ByteString) -> XPure Object -> XPure Object +_xpureBits f g o = o >>= \o -> case o of + OChar o -> return $ OChar $ chr $ mod (f $ ord o) (ord maxBound) + OInt o -> return $ OInt $ f o + OWord o -> return $ OWord $ f o + OLong o -> return $ OLong $ f o + OBytes o -> return $ OBytes $ g o + _ -> mzero + +_xpureBits2 :: InfixOp -> (forall a . Bits a => a -> a -> a) -> (T_dict -> T_dict -> T_dict) -> (B.ByteString -> B.ByteString -> B.ByteString) -> XPure Object -> XPure Object -> XPure Object +_xpureBits2 op bits dict bytes a b = a >>= \a -> b >>= \b -> do + let t = max (coreType a) (coreType b) + a <- castToCoreType t a + b <- castToCoreType t b + case (a, b) of + (OChar a, OChar b) -> return $ OChar $ chr $ mod (bits (ord a) (ord b)) (ord maxBound) + (OInt a, OInt b) -> return $ OInt $ bits a b + (OWord a, OWord b) -> return $ OWord $ bits a b + (OLong a, OLong b) -> return $ OLong $ bits a b + (ODict a, ODict b) -> return $ ODict $ dict a b + (OTree a, OTree b) -> case (a, b) of + (Struct{ structName=na, fieldMap=ma }, Struct{ structName=nb, fieldMap=mb }) | na==nb -> + xpure $ OTree $ a{ fieldMap = dict ma mb } + _ -> throwBadTypeError "cannot operate on dissimilar struct types" (OTree b) $ + [(expectType, obj (typeOfObj (OTree a)))] + (OBytes a, OBytes b) -> return $ OBytes $ bytes a b + _ -> eval_Infix_op op a b + +_dict_XOR :: (Object -> Object -> Object) -> T_dict -> T_dict -> T_dict +_dict_XOR f a b = M.difference (M.unionWith f a b) (M.intersectionWith f a b) + +instance Bits (XPure Object) where + a .&. b = _xpureBits2 AND (.&.) (M.intersectionWith (flip const)) (bytesBitArith (.&.)) a b <|> + (a >>= \a -> b >>= \b -> eval_Infix_op ANDB a b) + a .|. b = _xpureBits2 ORB (.|.) (M.unionWith (flip const)) (bytesBitArith (.|.)) a b <|> + (a >>= \a -> b >>= \b -> eval_Infix_op ORB a b) + xor a b = _xpureBits2 XORB xor (_dict_XOR (flip const)) (bytesBitArith xor ) a b <|> + (a >>= \a -> b >>= \b -> eval_Infix_op XORB a b) + complement = _xpureBits complement (B.map complement) + shift o i = o >>= \o -> case o of + OList o -> xpure $ OList $ case compare i 0 of + EQ -> o + LT -> reverse $ drop (negate i) $ reverse o + GT -> drop i o + _ -> _xpureBits (flip shift i) (flip bytesShift (fromIntegral i)) (xpure o) + rotate o i = _xpureBits (flip shift i) (flip bytesRotate (fromIntegral i)) o + bit i = xpure $ if i<64 then OWord (bit i) else OBytes (bytesBit (fromIntegral i)) + testBit o i = _xpureApply1 "testBit" testbit o where + testbit o = case o of + OChar o -> xpure $ testBit (ord o) i + OInt o -> xpure $ testBit o i + OWord o -> xpure $ testBit o i + OLong o -> xpure $ testBit o i + OBytes o -> xpure $ bytesTestBit o (fromIntegral i) + _ -> mzero + bitSize = _xpureApply1 "bitSize" $ \o -> case o of + OInt o -> xmaybe $ bitSizeMaybe o + OWord o -> xmaybe $ bitSizeMaybe o + OBytes o -> xpure $ fromIntegral $ bytesBitSize o + _ -> mzero + bitSizeMaybe = _xpureMaybeApply1 $ \o -> case o of + OInt o -> xmaybe $ bitSizeMaybe o + OWord o -> xmaybe $ bitSizeMaybe o + OBytes o -> xpure $ fromIntegral $ bytesBitSize o + _ -> mzero + isSigned = _xpureApply1 "isSigned" $ \o -> case o of + OChar _ -> xpure False + OInt _ -> xpure True + OWord _ -> xpure False + OLong _ -> xpure True + OBytes _ -> xpure False + _ -> mzero + popCount = _xpureApply1 "popCount" $ \o -> case o of + OChar o -> xpure $ popCount (ord o) + OInt o -> xpure $ popCount o + OWord o -> xpure $ popCount o + OLong o -> xpure $ popCount o + OBytes o -> xpure $ fromIntegral $ bytesPopCount o + _ -> mzero + +_shiftOp :: (Int -> Int) -> Object -> Object -> XPure Object +_shiftOp neg a b = case b of + OInt b -> shift (xpure a) (neg b) + OWord b -> shift (xpure a) (neg $ fromIntegral b) + OLong b -> shift (xpure a) (neg $ fromIntegral b) + _ -> mzero + +-- | Evaluate the shift-left operator in the 'XPure' monad. +shiftLeft :: Object -> Object -> XPure Object +shiftLeft a b = _shiftOp id a b <|> eval_Infix_op SHL a b + +-- | Evaluate the shift-right operator in the 'XPure' monad. +shiftRight :: Object -> Object -> XPure Object +shiftRight a b = _shiftOp negate a b <|> eval_Infix_op SHR a b + +-- | Throw an error declaring that the two types cannot be used together because their types are +-- incompatible. Provide the a string describing the /what/ could not be done as a result of the +-- type mismatch, it will be placed in the message string: +-- > "could not the item of type with the item of type " +typeMismatchError :: InfixOp -> Object -> Object -> XPure ig +typeMismatchError op a b = throwError $ + newError{ execErrorSubtype = ExecInfixOpError (typeOfObj a) op (typeOfObj b) } + +eval_ADD :: Object -> Object -> XPure Object +eval_ADD a b = (xpure a + xpure b) <|> typeMismatchError ADD a b + +eval_SUB :: Object -> Object -> XPure Object +eval_SUB a b = (xpure a - xpure b) <|> typeMismatchError SUB a b + +eval_MULT :: Object -> Object -> XPure Object +eval_MULT a b = (xpure a * xpure b) <|> typeMismatchError MULT a b + +eval_DIV :: Object -> Object -> XPure Object +eval_DIV a b = do + let { xa = xpure a; xb = xpure b; } + (div xa xb <|> xa/xb) <|> typeMismatchError DIV a b + +eval_MOD :: Object -> Object -> XPure Object +eval_MOD a b = do + let { xa = xpure a; xb = xpure b; } + (mod xa xb) <|> typeMismatchError MOD a b + +eval_POW :: Object -> Object -> XPure Object +eval_POW a b = do + let { xa = xpure a; xb = xpure b; } + xa^^xb <|> xa**xb <|> typeMismatchError POW a b + +eval_ORB :: Object -> Object -> XPure Object +eval_ORB a b = do + let { xa = xpure a; xb = xpure b; } + (xa.|.xb) <|> typeMismatchError ORB a b + +eval_ANDB :: Object -> Object -> XPure Object +eval_ANDB a b = do + let { xa = xpure a; xb = xpure b; } + (xa.&.xb) <|> typeMismatchError ANDB a b + +eval_XORB :: Object -> Object -> XPure Object +eval_XORB a b = do + let { xa = xpure a; xb = xpure b; } + (xor xa xb) <|> typeMismatchError XORB a b + +eval_EQUL :: Object -> Object -> XPure Object +eval_EQUL a b = return $ obj $ xpure a == xpure b + +eval_NEQUL :: Object -> Object -> XPure Object +eval_NEQUL a b = return $ obj $ xpure a /= xpure b + +eval_GTN :: Object -> Object -> XPure Object +eval_GTN a b = return $ obj $ xpure a > xpure b + +eval_LTN :: Object -> Object -> XPure Object +eval_LTN a b = return $ obj $ xpure a < xpure b + +eval_GTEQ :: Object -> Object -> XPure Object +eval_GTEQ a b = return $ obj $ xpure a >= xpure b + +eval_LTEQ :: Object -> Object -> XPure Object +eval_LTEQ a b = return $ obj $ xpure a <= xpure b + +eval_SHR :: Object -> Object -> XPure Object +eval_SHR a b = shiftRight a b + +eval_SHL :: Object -> Object -> XPure Object +eval_SHL a b = shiftLeft a b + +eval_NEG :: Object -> XPure Object +eval_NEG = _evalNumOp1 negate + +eval_INVB :: Object -> XPure Object +eval_INVB = complement . xpure + +eval_NOT :: Object -> XPure Object +eval_NOT = fmap (obj . not) . objToBool + +objToBool :: Object -> XPure Bool +objToBool o = case o of + OHaskell (Hata ifc d) -> case objNullTest ifc of + Nothing -> throwBadTypeError "cannot be used as a boolean value" o [(assertFailed, o)] + Just test -> return (test d) + o -> return $ not $ testNull o + +-- | Traverse the entire object, returning a list of all 'OString' elements. +extractStringElems :: Object -> [UStr] +extractStringElems o = case o of + OString o -> [o] + OList o -> concatMap extractStringElems o + _ -> [] + +-- | Useful for building 'DaoFunc' objects, checks every parameter in a list of 'Object's to be a +-- string, and throws an exception if one of the 'Object's is not a string. +requireAllStringArgs :: String -> [Object] -> Exec [UStr] +requireAllStringArgs msg ox = case mapM check (zip [1..] ox) of + OK obj -> return obj + Backtrack -> fail msg + PFail err -> throwError err + where + check (i, o) = case o of + OString o -> return o + _ -> throwBadTypeError msg o [(argNum, OInt i)] + +---------------------------------------------------------------------------------------------------- + +_updateToInfixOp :: UpdateOp -> InfixOp +_updateToInfixOp = (arr!) where + arr :: Array UpdateOp InfixOp + arr = array (UADD, maxBound) $ + [ (UADD , ADD ) + , (USUB , SUB ) + , (UMULT , MULT) + , (UDIV , DIV ) + , (UMOD , MOD ) + , (UPOW , POW ) + , (UORB , ORB ) + , (UANDB , ANDB) + , (UXORB , XORB) + , (USHL , SHL ) + , (USHR , SHR ) + ] + +instance ToDaoStructClass UpdateOp where { toDaoStruct = putNullaryUsingShow } + +instance FromDaoStructClass UpdateOp where { fromDaoStruct = getNullaryWithRead } + +instance ObjectClass UpdateOp where { obj=new; fromObj=objFromHata; } + +instance HataClass UpdateOp where + haskellDataInterface = interface "UpdateOperator" $ do + autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass RefPfxOp where { toDaoStruct = putNullaryUsingShow } + +instance FromDaoStructClass RefPfxOp where { fromDaoStruct = getNullaryWithRead } + +instance ObjectClass RefPfxOp where { obj=new; fromObj=objFromHata; } + +instance HataClass RefPfxOp where + haskellDataInterface = interface "ReferenceOperator" $ do + autoDefEquality >> autoDefOrdering + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass ArithPfxOp where { toDaoStruct = putNullaryUsingShow } + +instance FromDaoStructClass ArithPfxOp where { fromDaoStruct = getNullaryWithRead } + +instance ObjectClass ArithPfxOp where { obj=new; fromObj=objFromHata; } + +instance HataClass ArithPfxOp where + haskellDataInterface = interface "ArithmeticPrefixOperator" $ do + autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass InfixOp where { toDaoStruct=putNullaryUsingShow; } + +instance FromDaoStructClass InfixOp where { fromDaoStruct = getNullaryWithRead } + +instance ObjectClass InfixOp where { obj=new; fromObj=objFromHata; } + +instance HataClass InfixOp where + haskellDataInterface = interface "ArithmeticInfixOperator" $ do + autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass TopLevelEventType where { toDaoStruct = putNullaryUsingShow } + +instance FromDaoStructClass TopLevelEventType where { fromDaoStruct = getNullaryWithRead } + +instance ObjectClass TopLevelEventType where { obj=new; fromObj=objFromHata; } + +instance HataClass TopLevelEventType where + haskellDataInterface = interface "TopLevelEventType" $ do + autoDefEquality >> autoDefOrdering + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +evalArithPrefixOp :: ArithPfxOp -> Object -> XPure Object +evalArithPrefixOp = (_arithPrefixOps!) + +_arithPrefixOps :: Array ArithPfxOp (Object -> XPure Object) +_arithPrefixOps = array (minBound, maxBound) $ defaults ++ + [ o NEGTIV eval_NEG + , o POSTIV return + , o INVB eval_INVB + , o NOT eval_NOT + ] + where + o = (,) + defaults = flip map [minBound..maxBound] $ \op -> + (op, \_ -> error $ "no builtin function for prefix "++show op++" operator") + +evalInfixOp :: InfixOp -> Object -> Object -> XPure Object +evalInfixOp op a b = msum $ f a ++ f b ++ [(_infixOps!op) a b] where + f = maybe [] return . (fromObj >=> getOp) + getOp (Hata ifc a) = (\f -> f op a b) <$> (objInfixOpTable ifc >>= (! op)) + +_infixOps :: Array InfixOp (Object -> Object -> XPure Object) +_infixOps = array (minBound, maxBound) $ defaults ++ + [ o ADD eval_ADD + , o SUB eval_SUB + , o MULT eval_MULT + , o DIV eval_DIV + , o MOD eval_MOD + , o POW eval_POW + , o SHL eval_SHL + , o SHR eval_SHR + , o ORB eval_ORB + , o ANDB eval_ANDB + , o XORB eval_XORB + , o OR (error (e "logical-OR" )) -- These probably wont be evaluated. Locgical and/or is a + , o AND (error (e "logical-AND")) -- special case to be evaluated in 'evalObjectExprWithLoc'. + , o EQUL eval_EQUL + , o NEQUL eval_NEQUL + , o GTN eval_GTN + , o LTN eval_LTN + , o GTEQ eval_GTEQ + , o LTEQ eval_LTEQ + , o ARROW (error (e "ARROW")) + ] + where + o = (,) + defaults = flip map [minBound..maxBound] $ \op -> + (op, \_ _ -> error $ "no builtin function for infix "++show op++" operator") + e msg = msg ++ + " operator should have been evaluated within the 'execute' function." + +-- | Evaluate an 'UpdateOp' operator. Provide an optional 'Reference' indicating the reference +-- location of the value being updated, then the 'UpdateOp' operator, the right-hand side 'Object' +-- value, and finally the current value stored at the 'Reference' location that needs to be updated. +-- If the 'UpdateOp' is 'UCONST', the current value may be 'Prelude.Nothing' as any current value +-- will be overwritten. If the 'UpdateOp' is not 'UCONST' and the current value is +-- 'Prelude.Nothing', this is an error. Otherwise the current value is removed from the +-- 'Prelude.Just' constructor and used as the left-hand operand with the right-hand operand of the +-- appropriate arithmetic function associated with the 'UpdateOp'. +evalUpdateOp :: Maybe Reference -> UpdateOp -> Object -> Maybe Object -> Exec (Maybe Object) +evalUpdateOp qref op newObj oldObj = case op of + UCONST -> return $ Just newObj + op -> case oldObj of + Nothing -> + execThrow "performed update on void value" (ExecUpdateOpError op) + (maybe [] (\qref -> [(errOfReference, obj qref)]) qref) + Just oldObj -> Just <$> execute (evalInfixOp (_updateToInfixOp op) oldObj newObj) + +_updatingOps :: Array UpdateOp (Object -> Object -> XPure Object) +_updatingOps = let o = (,) in array (minBound, maxBound) $ defaults ++ + [ o UCONST (\_ b -> return b) + , o UADD eval_ADD + , o USUB eval_SUB + , o UMULT eval_MULT + , o UDIV eval_DIV + , o UMOD eval_MOD + , o UORB eval_ORB + , o UANDB eval_ANDB + , o UXORB eval_XORB + , o USHL eval_SHL + , o USHR eval_SHR + ] + where + defaults = flip map [minBound..maxBound] $ \op -> + (op, \_ _ -> error $ "no builtin function for update operator "++show op) + +---------------------------------------------------------------------------------------------------- + +_strObjConcat :: [Object] -> String +_strObjConcat ox = ox >>= \o -> maybe [toUStr $ prettyShow o] return (fromObj o) >>= uchars + +makePrintFunc :: (typ -> String -> Exec ()) -> DaoFunc typ +makePrintFunc print = + daoFunc + { funcAutoDerefParams = True + , daoForeignFunc = \typ ox -> print typ (_strObjConcat ox) >> return (Nothing, typ) + } + +builtin_print :: DaoFunc () +builtin_print = makePrintFunc (\ () -> liftIO . (putStr >=> evaluate)) + +builtin_println :: DaoFunc () +builtin_println = makePrintFunc (\ () -> liftIO . (putStrLn >=> evaluate)) + +-- join string elements of a container, pretty prints non-strings and joins those as well. +builtin_join :: DaoFunc () +builtin_join = + daoFunc + { funcAutoDerefParams = True + , daoForeignFunc = \ () ox -> return $ flip (,) () $ Just $ obj $ case ox of + OString j : ox -> (>>=uchars) $ + intersperse j $ snd (objConcat ox) >>= \o -> + [maybe (ustr $ prettyShow o) id (fromObj o :: Maybe UStr)] + ox -> _strObjConcat ox + } + +builtin_str :: DaoFunc () +builtin_str = + daoFunc + { funcAutoDerefParams = True + , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . _strObjConcat + } + +builtin_quote :: DaoFunc () +builtin_quote = + daoFunc + { funcAutoDerefParams = True + , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . show . _strObjConcat + } + +builtin_concat :: DaoFunc () +builtin_concat = + daoFunc + { funcAutoDerefParams = True + , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . fix (\loop ox -> ox >>= \o -> maybe [o] loop (fromObj o)) + } + +builtin_concat1 :: DaoFunc () +builtin_concat1 = + daoFunc + { funcAutoDerefParams = True + , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . snd . objConcat + } + +builtin_reverse :: DaoFunc () +builtin_reverse = + daoFunc + { funcAutoDerefParams = True + , daoForeignFunc = \ () -> return . flip (,) () . Just . obj . reverse . snd . objConcat + } + +_castNumerical :: String -> (Object -> Exec Object) -> DaoFunc () +_castNumerical name f = let n = ustr name :: Name in + daoFunc + { funcAutoDerefParams = True + , daoForeignFunc = \ () ox -> case ox of + [o] -> (flip (,) () . Just <$> f o) <|> throwBadTypeError "cannot cast to numerical type" o [] + ox -> throwArityError "" 1 ox [(errInFunc, obj $ reference UNQUAL n)] + } + +builtin_int :: DaoFunc () +builtin_int = _castNumerical "int" $ + fmap OInt . (execute . castToCoreType IntType >=> xmaybe . fromObj) + +builtin_long :: DaoFunc () +builtin_long = _castNumerical "long" $ + fmap OLong . (execute . castToCoreType LongType >=> xmaybe . fromObj) + +builtin_ratio :: DaoFunc () +builtin_ratio = _castNumerical "ratio" $ + fmap ORatio . (execute . castToCoreType RatioType >=> xmaybe . fromObj) + +builtin_float :: DaoFunc () +builtin_float = _castNumerical "float" $ + fmap OFloat . (execute . castToCoreType FloatType >=> xmaybe . fromObj) + +builtin_complex :: DaoFunc () +builtin_complex = _castNumerical "complex" $ + fmap OComplex . (execute . castToCoreType ComplexType >=> xmaybe . fromObj) + +builtin_imag :: DaoFunc () +builtin_imag = _castNumerical "imag" $ + fmap (OFloat . imagPart) . (execute . castToCoreType ComplexType >=> xmaybe . fromObj) + +builtin_phase :: DaoFunc () +builtin_phase = _castNumerical "phase" $ + fmap (OFloat . phase) . (execute . castToCoreType ComplexType >=> xmaybe . fromObj) + +builtin_conj :: DaoFunc () +builtin_conj = _castNumerical "conj" $ + fmap (OComplex . conjugate) . (execute . castToCoreType ComplexType >=> xmaybe . fromObj) + +builtin_abs :: DaoFunc () +builtin_abs = _castNumerical "abs" $ execute . asPositive + +builtin_time :: DaoFunc () +builtin_time = _castNumerical "time" $ \o -> case o of + ORelTime _ -> return o + o -> (ORelTime . fromRational) <$> execute (asRational o) + +_funcWithoutParams :: String -> Exec (Maybe Object) -> DaoFunc () +_funcWithoutParams name f = + daoFunc + { daoForeignFunc = \ () ox -> case ox of + [] -> flip (,) () <$> f + ox -> throwArityError "function takes no parameters" 0 ox $ + [(errInFunc, obj $ reference UNQUAL (ustr name))] + } + +builtin_now :: DaoFunc () +builtin_now = _funcWithoutParams "now" $ (Just . obj) <$> liftIO getCurrentTime + +builtin_ref :: DaoFunc () +builtin_ref = + daoFunc + { daoForeignFunc = \ () -> fmap (flip (,) () . Just . ORef) . execute . mconcat . + fmap (\o -> (castToCoreType RefType o) <|> + (throwBadTypeError "could not convert to reference" o []) >>= + (castToCoreType RefType >=> xmaybe . fromObj) + ) + } + +builtin_check_if_defined :: DaoFunc () +builtin_check_if_defined = + daoFunc + { funcAutoDerefParams = False + , daoForeignFunc = \ () args -> fmap (flip (,) () . Just . obj . and) $ forM args $ \arg -> case arg of + ORef o -> catchError (referenceLookup o >> return True) $ \err -> case err of + ExecError{ execErrorSubtype=ExecUndefinedRef _ } -> return False + err -> throwError err + _ -> return True + } + +builtin_delete :: DaoFunc () +builtin_delete = + daoFunc + { funcAutoDerefParams = False + , daoForeignFunc = \ () args -> do + forM_ args $ \arg -> case arg of + ORef o -> void $ referenceUpdate o True (const $ return Nothing) + _ -> return () + return (Nothing, ()) + } + +builtin_typeof :: DaoFunc () +builtin_typeof = + daoFunc + { daoForeignFunc = \ () ox -> return $ flip (,) () $ case ox of + [] -> Nothing + [o] -> Just $ OType $ typeOfObj o + ox -> Just $ OList $ map (OType . typeOfObj) ox + } + +builtin_sizeof :: DaoFunc () +builtin_sizeof = + daoFunc + { daoForeignFunc = \ () ox -> case ox of + [o] -> flip (,) () . Just <$> getSizeOf o + ox -> throwArityError "" 1 ox [(errInFunc, obj $ reference UNQUAL (ustr "sizeof"))] + } + +builtin_call :: DaoFunc () +builtin_call = + daoFunc + { funcAutoDerefParams = False + , daoForeignFunc = \ () ox -> case ox of + [func, params] -> do + let nonlist_err = fail "second parameter to \"call()\" function is not a list of arguments" + params <- case params of + OList params -> return params + ORef params -> referenceLookup params >>= \ (_, params) -> case params of + Nothing -> fail "second parameter parameter to \"call()\" function evaluated to null" + Just params -> xmaybe (fromObj params) <|> nonlist_err + _ -> nonlist_err + qref <- xmaybe (fromObj func) + <|> fail "first parameter to \"call()\" function is not a reference to a function" + (qref, func) <- referenceLookup qref + case func of + Nothing -> fail "first parameter to \"call()\" function evaluated to null" + Just func -> fmap (const ()) <$> callObject qref func params + _ -> fail $ unwords $ + [ "the \"call()\" function was evaluated with incorrect arguments." + , "Expecting a reference to function as first parameter" + , "and a list of arguments as the second parameter." + ] + } + +builtin_toHash :: DaoFunc () +builtin_toHash = + daoFunc + { daoForeignFunc = \ () ox -> do + let qref = reference UNQUAL (ustr "toHash") + let err = throwArityError "" 1 ox [(errInFunc, obj qref)] + case ox of + [o] -> case o of + OTree _ -> return (Just o, ()) + OHaskell (Hata ifc d) -> case objToStruct ifc of + Just to -> flip (,) () . Just . OTree <$> toDaoStructExec to d + Nothing -> throwBadTypeError "data type is opaque, cannot do binary conversion for hash" o $ + [(errInFunc, obj qref)] + _ -> err + _ -> err + } + +builtin_fromHash :: DaoFunc () +builtin_fromHash = + daoFunc + { daoForeignFunc = \ () ox -> do + let qref = reference UNQUAL (ustr "fromHash") + case ox of + [o] -> do + let err = throwBadTypeError "hashed Struct parameter required" o [(errInFunc, obj qref)] + xmaybe (fromObj o) <|> err >>= fmap (flip (,) () . Just . obj) . fromDaoStructExec + ox -> throwArityError "" 1 ox [(errInFunc, obj qref)] + } + +builtin_tokenize :: DaoFunc () +builtin_tokenize = + daoFunc{ daoForeignFunc = \ () -> fmap (flip (,) () . Just . obj . map obj) . runTokenizer } + +---------------------------------------------------------------------------------------------------- + +-- binary 0x42 0x45 RefSuffixExpr-->RefSuffix +instance B.Binary (RefSuffixExpr Object) MTab where + put o = case o of + NullRefExpr -> B.putWord8 0x42 + DotRefExpr a b c -> B.prefixByte 0x43 $ B.put a >> B.put b >> B.put c + SubscriptExpr a b -> B.prefixByte 0x44 $ B.put a >> B.put b + FuncCallExpr a b -> B.prefixByte 0x45 $ B.put a >> B.put b + get = B.word8PrefixTable <|> fail "expecting RefSuffixExpr" + +instance B.HasPrefixTable (RefSuffixExpr Object) B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "RefSuffixExpr" 0x42 0x45 $ + [ return NullRefExpr + , return DotRefExpr <*> B.get <*> B.get <*> B.get + , return SubscriptExpr <*> B.get <*> B.get + , return FuncCallExpr <*> B.get <*> B.get + ] + +instance Executable (RefSuffixExpr Object) RefSuffix where + execute o = errLocation o $ case o of + NullRefExpr -> return NullRef + DotRefExpr name ref _ -> DotRef name <$> execute ref + SubscriptExpr args ref -> return Subscript <*> execute args <*> execute ref + FuncCallExpr args ref -> return FuncCall <*> execute args <*> execute ref + +---------------------------------------------------------------------------------------------------- + +-- | To evaluate an 'Object' value against a type expression, you can store the +-- 'Object' into a 'TyChkExpr' and 'execute' it. This instance of +-- 'execute' evaluates a type checking monad computing over the 'tyChkExpr' in +-- the 'TyChkExpr'. If the type check determines the 'Object' value does not match, this +-- function backtracks. If the type check is successful, the most general type value for the object +-- if that type value is less-general or as-general as the 'TyChkExpr' provided. +instance Executable (TyChkExpr Object Object) Object where + execute tc = case tc of + NotTypeChecked _ -> return OTrue -- TODO: this needs to return the 'AnyType', not 'OTrue'. + TypeChecked _ _ _ -> return OTrue -- TODO: evaluate the actual type checking algorithm here + DisableCheck _ _ rslt _ -> return rslt + +-- | Convert an 'ObjectExpr' to an 'Dao.Glob.Glob'. +paramsToGlobExpr :: ObjectExpr Object -> Exec (Glob UStr) +paramsToGlobExpr o = case o of + ObjLiteralExpr (LiteralExpr (OString str) _) -> return (read (uchars str)) + _ -> fail "does not evaluate to a \"glob\" pattern" + +-- | Called by 'callFunction' to match the list of 'Object's passed as arguments to the function. +-- Returns two 'T_dict's: the first is the 'T_dict' to be passed to 'execFuncPushStack', the second +-- is the dictionary of local variables passed by reference. Backtracks if any types do not match, +-- or if there are an incorrect number of parameters. Backtracking is important because of function +-- overloading. +matchFuncParams :: ParamListExpr Object -> [Object] -> Exec T_dict +matchFuncParams (ParamListExpr params _) ox = loop (0::Int) M.empty (tyChkItem params) ox where + loop i dict params ox = case ox of + [] | null params -> return dict + [] -> mzero -- not enough parameters passed to function + o:ox -> case params of + [] -> mzero -- too many parameters passed to function + ParamExpr passByRef tychk _ : params -> do + let name = tyChkItem tychk + execute $ fmapCheckedValueExpr (const o) tychk -- execute (TyChkExpr Object) + o <- if passByRef then (case o of { ORef _ -> return o; _ -> mzero }) else derefObject o + loop (i+1) (M.insert name o dict) params ox + +-- | A guard script is some Dao script that is executed before or after some event, for example, the +-- code found in the @BEGIN@ and @END@ blocks. +execGuardBlock :: [ScriptExpr Object] -> Exec () +execGuardBlock block = void $ + execFuncPushStack M.empty (mapM_ execute block >> return Nothing) >> return () + +-- | Takes two parameters: first is an error message parameter, the second is the 'Object' to be +-- called. The 'Object' to be called should be an 'OHaskell' constructed value containing a +-- 'Hata' where the 'interface' has defined 'defCallable'. If so, the 'CallableCode' objects +-- returned by 'objCallable' will be returned by this function. If not, +objToCallable :: Object -> Exec [CallableCode] +objToCallable o = case fromObj o >>= \ (Hata ifc o) -> fmap ($ o) (objCallable ifc) of + Nothing -> mzero + Just f -> f + +-- | 'CallableCode' objects are usually stored in lists because of function overloading: e.g. a +-- function with a single name but is defined with multiple parameter lists would have several +-- 'CallableCode' objects associated with that function mame. This function tries to perform a +-- function call with a list of parameters. The parameters are matched to each 'CallableCode' +-- object's 'argsPattern', the first 'argsPattern' that matches without backtracking will evaluate +-- the function body. The value returned is a pair containing the result of the function call as the +-- 'Prelude.fst', and update "this" value as 'Prelude.snd' +callCallables :: Maybe Object -> [CallableCode] -> [Object] -> Exec (Maybe Object, Maybe Object) +callCallables this funcs params = fmap (fmap (M.lookup (ustr "this"))) $ join $ + msum $ flip fmap funcs $ \call -> matchFuncParams (argsPattern call) params >>= + return . flip execFuncPushStack (execute $ codeSubroutine call) . M.alter (const this) (ustr "this") + +-- | This function assumes you have retrieved a callable function-like 'Object' using a 'Reference'. +-- This function evaluates 'callCallables', and extracts the 'CallableCode' from the 'Object' +-- provided as the second parameter using 'objToCallable'. The 'Reference' passed as the first +-- parameter should be the reference used to retrieve the function 'Object'. If the given object +-- provides a 'defCallable' callback, the object can be called with parameters as if it were a +-- function. +callObject :: Reference -> Object -> [Object] -> Exec (Maybe Object, Maybe Object) +callObject qref o params = case o of + OHaskell (Hata ifc d) -> case fromDynamic d of + Just func -> fmap (const Nothing) <$> executeDaoFunc func () params -- try calling an ordinary function + Nothing -> case objCallable ifc of + Just getFuncs -> getFuncs d >>= \func -> callCallables (Just o) func params + Nothing -> err + _ -> err + where { err = throwBadTypeError "not a callable object" o [(errInFunc, obj qref)] } + +-- | Evaluate to 'procErr' if the given 'Predicate' is 'Backtrack' or 'PFail'. You must pass a +-- 'Prelude.String' as the message to be used when the given 'Predicate' is 'Backtrack'. You can also +-- pass a list of 'Object's that you are checking, these objects will be included in the +-- 'procErr' value. +-- This function should be used for cases when you have converted 'Object' to a +-- Haskell value, because 'Backtrack' values indicate type exceptions, and 'PFail' values indicate a +-- value error (e.g. out of bounds, or some kind of assert exception), and the messages passed to +-- 'procErr' will indicate this. +checkPredicate :: String -> [Object] -> Exec a -> Exec a +checkPredicate altmsg tried f = do + pval <- catchPredicate f + let err = fail (altmsg++" evaulated to void expression") + case pval of + OK a -> return a + Backtrack -> err + PFail (ExecReturn Nothing) -> err + PFail err -> throwError $ + err{ execReturnValue = Just $ case execReturnValue err of + Just (OList ox) -> obj $ tried ++ ox + Just o -> obj $ tried ++ [o] + Nothing -> obj tried + } + +-- | 'evalObjectExprExpr' can return 'Data.Maybe.Nothing', and usually this happens when something has +-- failed (e.g. reference lookups), but it is not always an error (e.g. a void list of argument to +-- functions). If you want 'Data.Maybe.Nothing' to cause an error, evaluate your +-- @'Exec' ('Data.Maybe.Maybe' 'Object')@ as a parameter to this function. +checkVoid :: Location -> String -> Maybe a -> Exec a +checkVoid loc msg fn = case fn of + Nothing -> throwError $ + newError + { execErrorMessage = ustr (msg++" evaluated to void") + , execErrorLocation = loc + } + Just a -> return a + +instance ToDaoStructClass (AST_RefSuffix Object) where + toDaoStruct = ask >>= \o -> case o of + AST_RefNull -> makeNullary "Null" + AST_DotRef dot name ref loc -> renameConstructor "DotRef" $ do + "dot" .= dot >> "head" .= name >> "tail" .= ref >> putLocation loc + AST_Subscript args ref -> renameConstructor "Subscript" $ do + "args" .= args >> "tail" .= ref >> return () + AST_FuncCall args ref -> renameConstructor "FuncCall" $ do + "args" .= args >> "tail" .= ref >> return () + +instance FromDaoStructClass (AST_RefSuffix Object) where + fromDaoStruct = msum $ + [ constructor "Null" >> return AST_RefNull + , constructor "DotRef" >> return AST_DotRef <*> req "dot" <*> req "head" <*> req "tail" <*> location + , constructor "Subscript" >> return AST_Subscript <*> req "args" <*> req "tail" + , constructor "FuncCall" >> return AST_FuncCall <*> req "args" <*> req "tail" + ] + +instance ObjectClass (AST_RefSuffix Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_RefSuffix Object) where + haskellDataInterface = interface "RefSuffixExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- | If an expression is inside of a 'ParenExpr', like it usually is after being parsed as part of +-- an @if@ or @while@ statement, this function evaluates the expression to a 'Prelude.Bool' value +-- used to determine if the conditional expression should be 'execute'd. +evalConditional :: ParenExpr Object -> Exec Bool +evalConditional o = + (execute o :: Exec (Maybe Object)) >>= + checkVoid (getLocation o) "conditional expression to if statement" >>= derefObject >>= + execHandleIO [fmap (const False) execIOHandler] . return . not . testNull + +-- binary 0x59 +instance B.Binary (ParenExpr Object) MTab where + put (ParenExpr a b) = B.prefixByte 0x59 $ B.put a >> B.put b + get = B.word8PrefixTable <|> fail "expecting ParenExpr" + +instance B.HasPrefixTable (ParenExpr Object) B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "ParenExpr" 0x59 0x59 $ + [return ParenExpr <*> B.get <*> B.get] + +instance Executable (ParenExpr Object) (Maybe Object) where { execute (ParenExpr a _) = execute a } + +instance ObjectClass (ParenExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (ParenExpr Object) where + haskellDataInterface = interface "Parentheses" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt + -- autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_Paren Object) where + toDaoStruct = renameConstructor "Paren" $ ask >>= \o -> case o of + AST_Paren paren loc -> "inside" .= paren >> putLocation loc + +instance FromDaoStructClass (AST_Paren Object) where + fromDaoStruct = constructor "Paren" >> return AST_Paren <*> req "inside" <*> location + +instance ObjectClass (AST_Paren Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_Paren Object) where + haskellDataInterface = interface "ParenthesesExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +instance B.Binary (IfExpr Object) MTab where + put (IfExpr a b c) = B.put a >> B.put b >> B.put c + get = return IfExpr <*> B.get <*> B.get <*> B.get + +instance Executable (IfExpr Object) Bool where + execute (IfExpr ifn thn _) = execNested_ M.empty $ + evalConditional ifn >>= \test -> when test (execute thn) >> return test + +instance ObjectClass (IfExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (IfExpr Object) where + haskellDataInterface = interface "Conditional" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_If Object) where + toDaoStruct = renameConstructor "Conditional" $ ask >>= \o -> case o of + AST_If ifn thn loc -> "condition" .= ifn >> "action" .= thn >> putLocation loc + +instance FromDaoStructClass (AST_If Object) where + fromDaoStruct = constructor "Conditional" >> + return AST_If <*> req "condition" <*> req "action" <*> location + +instance ObjectClass (AST_If Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_If Object) where + haskellDataInterface = interface "ConditionalExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0xB6 +instance B.Binary (ElseExpr Object) MTab where + put (ElseExpr a b) = B.prefixByte 0xB6 $ B.put a >> B.put b + get = (B.tryWord8 0xB6 $ return ElseExpr <*> B.get <*> B.get) <|> fail "expecting ElseExpr" + +instance Executable (ElseExpr Object) Bool where { execute (ElseExpr ifn _) = execute ifn } + +instance ObjectClass (ElseExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (ElseExpr Object) where + haskellDataInterface = interface "Else" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_Else Object) where + toDaoStruct = ask >>= \o -> case o of + AST_Else coms ifn loc -> renameConstructor "ElseIf" $ do + "comments" .= coms >> "elseIf" .= ifn >> putLocation loc + +instance FromDaoStructClass (AST_Else Object) where + fromDaoStruct = constructor "ElseIf" >> + return AST_Else <*> req "comments" <*> req "elseIf" <*> location + +instance ObjectClass (AST_Else Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_Else Object) where + haskellDataInterface = interface "ElseExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0xBA +instance B.Binary (IfElseExpr Object) MTab where + put (IfElseExpr a b c d) = B.prefixByte 0xBA $ B.put a >> B.put b >> B.put c >> B.put d + get = B.word8PrefixTable <|> fail "expecting IfElseExpr" + +instance B.HasPrefixTable (IfElseExpr Object) B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "IfElseExpr" 0xBA 0xBA $ + [return IfElseExpr <*> B.get <*> B.get <*> B.get <*> B.get] + +instance Executable (IfElseExpr Object) () where + execute (IfElseExpr ifn elsx final _loc) = do + let tryEach elsx = case elsx of + [] -> return False + els:elsx -> execute els >>= \ok -> if ok then return ok else tryEach elsx + (execute ifn >>= \ok -> + if ok then return Nothing + else tryEach elsx >>= \ok -> + if ok then return Nothing + else return final) >>= maybe (return ()) execute + +instance ObjectClass (IfElseExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (IfElseExpr Object) where + haskellDataInterface = interface "IfElse" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_IfElse Object) where + toDaoStruct = ask >>= \o -> case o of + AST_IfElse ifn els block loc -> renameConstructor "If" $ do + "test" .= ifn >> "alt" .= listToObj els + maybe (return ()) (void . defObjField "finalElse") block + putLocation loc + +instance FromDaoStructClass (AST_IfElse Object) where + fromDaoStruct = constructor "If" >> + return AST_IfElse + <*> req "test" + <*> reqList "alt" + <*> opt "finalElse" + <*> location + +instance ObjectClass (AST_IfElse Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_IfElse Object) where + haskellDataInterface = interface "IfElseExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary (not prefixed, always occurs within a list) +instance B.Binary (LastElseExpr Object) MTab where + put (LastElseExpr a loc) = B.put a >> B.put loc + get = (return LastElseExpr <*> B.get <*> B.get) <|> fail "expecting LastElseExpr" + +instance Executable (LastElseExpr Object) () where { execute (LastElseExpr code _) = execute code } + +instance ObjectClass (LastElseExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (LastElseExpr Object) where + haskellDataInterface = interface "FinalElse" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_LastElse Object) where + toDaoStruct = renameConstructor "LastElse" $ do + (AST_LastElse coms code loc) <- ask + "comments" .= coms >> "action" .= code >> putLocation loc + +instance FromDaoStructClass (AST_LastElse Object) where + fromDaoStruct = constructor "LastElse" >> + return AST_LastElse <*> req "comments" <*> req "action" <*> location + +instance ObjectClass (AST_LastElse Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_LastElse Object) where + haskellDataInterface = interface "FinalElseExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary (not prefixed, always occurs within a list) +instance B.Binary (CatchExpr Object) MTab where + put (CatchExpr a b loc) = B.put a >> B.put b >> B.put loc + get = return CatchExpr <*> B.get <*> B.get <*> B.get + +instance ObjectClass (CatchExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (CatchExpr Object) where + haskellDataInterface = interface "CatchExpr" $ do + autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt + +-- | Returns the 'Exec' function to be evaluated if the 'ExecControl' matches the 'CatchExpr' type +-- constraint. If the type constraint does not match, this function evaluates to +-- 'Control.Monad.mzero'. +executeCatchExpr :: ExecControl -> CatchExpr Object -> Exec (Exec ()) +executeCatchExpr err (CatchExpr (ParamExpr _refd param _) catch _loc) = case param of -- TODO: do something with _refd + NotTypeChecked name -> ex name catch + TypeChecked name _check _loc -> ex name catch -- TODO: do something with _check + DisableCheck name _ _ _ -> ex name catch + where + ex name catch = return $ execNested_ M.empty $ localVarDefine name (new err) >> execute catch + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_Catch Object) where + toDaoStruct = ask >>= \ (AST_Catch coms param action loc) -> renameConstructor "Catch" $ do + "comments" .= coms >> "test" .= param >> "action" .= action >> putLocation loc + +instance FromDaoStructClass (AST_Catch Object) where + fromDaoStruct = constructor "Catch" >> + return AST_Catch <*> req "comments" <*> req "test" <*> req "action" <*> location + +instance ObjectClass (AST_Catch Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_Catch Object) where + haskellDataInterface = interface "CatchExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0x85 +instance B.Binary (WhileExpr Object) MTab where + put (WhileExpr o) = B.prefixByte 0x85 $ B.put o + get = B.word8PrefixTable <|> fail "expecting WhileExpr" + +instance B.HasPrefixTable (WhileExpr Object) B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "WhileExpr" 0x85 0x85 [WhileExpr <$> B.get] + +instance Executable (WhileExpr Object) () where + execute (WhileExpr ifn) = fix $ \loop -> catchLoopCtrl (execute ifn) return >>= flip when loop + +instance ObjectClass (WhileExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (WhileExpr Object) where + haskellDataInterface = interface "While" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_While Object) where + toDaoStruct = renameConstructor "While" $ ask >>= \ (AST_While o) -> innerToStruct o + +instance FromDaoStructClass (AST_While Object) where + fromDaoStruct = constructor "While" >> AST_While <$> innerFromStruct "Conditional" + +instance ObjectClass (AST_While Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_While Object) where + haskellDataInterface = interface "WhileExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0xA8 0xAF +instance B.Binary (ScriptExpr Object) MTab where + put o = case o of + IfThenElse a -> B.put a + WhileLoop a -> B.put a + RuleFuncExpr a -> B.put a + EvalObject a z -> B.prefixByte 0xA8 $ B.put a >> B.put z + TryCatch a b c z -> B.prefixByte 0xA9 $ B.put a >> B.put b >> B.put c >> B.put z + ForLoop a b c z -> B.prefixByte 0xAA $ B.put a >> B.put b >> B.put c >> B.put z + ContinueExpr True b z -> B.prefixByte 0xAB $ B.put b >> B.put z + ContinueExpr False b z -> B.prefixByte 0xAC $ B.put b >> B.put z + ReturnExpr True b z -> B.prefixByte 0xAD $ B.put b >> B.put z + ReturnExpr False b z -> B.prefixByte 0xAE $ B.put b >> B.put z + WithDoc a b z -> B.prefixByte 0xAF $ B.put a >> B.put b >> B.put z + get = B.word8PrefixTable <|> fail "expecting ScriptExpr" + +instance B.HasPrefixTable (ScriptExpr Object) B.Byte MTab where + prefixTable = mconcat $ + [ fmap IfThenElse B.prefixTable + , fmap WhileLoop B.prefixTable + , fmap RuleFuncExpr B.prefixTable + , B.mkPrefixTableWord8 "ScriptExpr" 0xA8 0xAF $ -- 0x89 0x8A 0x8B 0x8C 0x8D 0x8E 0x8F 0x90 + [ return EvalObject <*> B.get <*> B.get + , return TryCatch <*> B.get <*> B.get <*> B.get <*> B.get + , return ForLoop <*> B.get <*> B.get <*> B.get <*> B.get + , return (ContinueExpr True ) <*> B.get <*> B.get + , return (ContinueExpr False) <*> B.get <*> B.get + , return (ReturnExpr True ) <*> B.get <*> B.get + , return (ReturnExpr False) <*> B.get <*> B.get + , return WithDoc <*> B.get <*> B.get <*> B.get + ] + ] + +-- | Convert a single 'ScriptExpr' into a function of value @'Exec' 'Object'@. +instance Executable (ScriptExpr Object) () where + execute script = errCurrentModule $ errLocation script $ case script of + IfThenElse ifn -> execute ifn + WhileLoop ifn -> execute ifn + EvalObject o _loc -> execute (DerefAssignExpr o) >>= return . maybe () (`seq` ()) + RuleFuncExpr rulfn -> do + o <- execute rulfn -- this 'execute' handles function expressions + let dyn o = case o of + OHaskell (Hata _ h) -> fromDynamic h + _ -> Nothing + let getObj :: (ObjectClass o, Typeable o) => Exec o + getObj = mplus (xmaybe $ o >>= dyn) $ case o of + Nothing -> fail "RuleFuncExpr evaluated to void" + Just o -> throwBadTypeError "RuleFuncExpr evaluated to object of incorrect data type" o [] + let fsub sub = modify $ \xunit -> xunit{currentCodeBlock=Just sub} + sub <- gets currentCodeBlock + case sub of + Nothing -> case rulfn of + LambdaExpr{} -> getObj >>= \o -> + modify $ \xunit -> xunit{ lambdaSet = lambdaSet xunit ++ o } + RuleExpr{} -> do + newtree <- getObj >>= \p -> execute (p::PatternRule) + modify $ \xunit -> xunit{ ruleSet=T.unionWith (++) (ruleSet xunit) newtree } + FuncExpr{} -> return () + -- function expressions are placed in the correct store by the above 'execute' + Just sub -> case rulfn of + LambdaExpr{} -> getObj >>= \o -> fsub $ sub{ staticLambdas = staticLambdas sub ++ o } + RuleExpr{} -> do + newtree <- getObj >>= \p -> execute (p::PatternRule) + fsub $ sub{ staticRules=T.unionWith (++) (staticRules sub) newtree } + FuncExpr{} -> return () + -- function expressions are placed in the correct store by the above 'execute' + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + TryCatch try els catchers _loc -> do + ce <- catchPredicate $ execNested_ M.empty (execute try) <|> msum (fmap execute els) + case ce of + OK () -> return () + Backtrack -> mzero + PFail err -> case err of + ExecReturn{} -> predicate ce + ExecError{execErrorSubtype=ExecLoopCtrl{}} -> predicate ce + ExecError{} -> join $ msum $ fmap (executeCatchExpr err) catchers + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + ForLoop varName inObj thn _loc -> do + let run = void $ execute thn + let readIter o = execNested_ (M.singleton varName o) run + let updateIter o = M.lookup varName . snd <$> execNested (maybe M.empty (M.singleton varName) o) run + let readLoop o = void $ readForLoop o readIter + let updateLoop qref o = void $ fmap snd $ + updateForLoop o updateIter >>= referenceUpdate qref False . const . return . Just + errLocation inObj $ execute inObj >>= maybeDerefObject >>= \ (qref, iter) -> case iter of + Nothing -> fail "iterator of for-loop expression evaluated to void" + Just iter -> case qref of + Nothing -> void $ readLoop iter + Just qref -> case iter of + OHaskell (Hata ifc _) -> case objUpdateIterable ifc of + Just _ -> void $ updateLoop qref iter + Nothing -> case objReadIterable ifc of + Just _ -> void $ readLoop iter + Nothing -> throwBadTypeError "data type not iterable" iter [(errOfReference, obj qref)] + _ -> void $ updateLoop qref iter + -- NOTE: the for loop iterator IS NOT passed to the 'referenceUpdate' function to be + -- evaluated. This is to avoid introducing deadlocks in data types that may store their values + -- in an MVar. The 'referenceLookup' function first evaluates the reference, creating a copy + -- in the current thread, the for loop is evaluated, and THEN the 'referenceUpdate' function + -- is evaluated, in those three discrete steps. It is not possible to evaluate a for loop in + -- the dao programming language as an atomic action, so race conditions may occur when + -- updating MVars -- but deadlocks will not occur. + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + ContinueExpr a test _loc -> do + test <- execute test + let signal = execThrow "" (loopCtrl a) [] + case test of + Nothing -> signal + Just o -> derefObject o >>= execute . objToBool >>= flip when signal + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + ReturnExpr returnStmt o _loc -> do + o <- (execute o :: Exec (Maybe Object)) >>= maybe (return Nothing) (fmap Just . derefObject) + if returnStmt then throwError (ExecReturn o) else maybe mzero (flip (execThrow "") [] . ExecThrow) o + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + WithDoc expr thn _loc -> execute expr >>= + checkVoid (getLocation expr) "target of \"with\" statement" >>= + flip execWithWithRefStore (execute thn) + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +instance ObjectClass (ScriptExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (ScriptExpr Object) where + haskellDataInterface = interface "Script" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt + +localVarDefine :: Name -> Object -> Exec (Maybe Object) +localVarDefine name o = fmap (snd . fst) $ + runObjectFocus (updateLocal name NullRef $ modify (const $ Just o) >> get) False (reference UNQUAL name) () + +localVarUpdate :: Name -> (Maybe Object -> Maybe Object) -> Exec (Maybe Object) +localVarUpdate name f = fmap (snd . fst) $ + runObjectFocus (updateLocal name NullRef $ modify f >> get) False (reference UNQUAL name) () + +localVarLookup :: Name -> Exec Object +localVarLookup name = + (snd . fst) <$> runObjectFocus (updateLocal name NullRef get) True (reference UNQUAL name) () >>= + maybe mzero return + +-- | Like evaluating 'execute' on a value of 'Reference', except the you are evaluating an +-- 'Object' type. If the value of the 'Object' is not constructed with +-- 'ORef', the object value is returned unmodified. +derefObject :: Object -> Exec Object +derefObject = fmap snd . derefObjectGetReference + +-- | Like 'derefObject' but also returns the 'Reference' value that was stored in the 'Object' that +-- was dereferenced, along with the dereferenced value. If the 'Object' is not constructed with +-- 'ORef', 'Prelude.Nothing' is returned instead of a 'Reference'. +derefObjectGetReference :: Object -> Exec (Maybe Reference, Object) +derefObjectGetReference o = maybeDerefObject (Just o) >>= \ (r, derefd) -> case derefd of + Nothing -> case r of + Nothing -> throwBadTypeError "dereferenced a non-reference value" o [] + Just r -> execThrow "reference evaluated to void" r [(errOfReference, o)] + Just derefd -> return (r, derefd) + +-- | Tries to dereference an 'Object'. If the 'Object' is an 'ORef' constructed 'Reference', the +-- reference is de-referenced, which may evaluate to 'Prelude.Nothing'. The dereferenced value is +-- returned in the 'Prelude.snd' of the pair. If the given 'Object' is an 'ORef', regardless of the +-- dereferenced value, the 'Reference' is returned in the 'Prelude.fst' of the pair. If the given +-- 'Object' is not an 'ORef' constructed 'Object', it is returned unmodified along with +-- 'Prelude.Nothing' in the 'Prelude.fst' of the pair. +maybeDerefObject :: Maybe Object -> Exec (Maybe Reference, Maybe Object) +maybeDerefObject = maybe (return (Nothing, Nothing)) $ \o -> case o of + ORef r -> referenceLookup r >>= \ (r, o) -> case o of + Nothing -> return (Just r, Nothing) + Just o -> return (Just r, Just o) + o -> return (Nothing, Just o) + +---------------------------------------------------------------------------------------------------- + +-- | This data type instantates the 'execute' function for use in for-loop expressions. +data ForLoopBlock = ForLoopBlock Name Object (CodeBlock Object) + +instance Executable ForLoopBlock (Bool, Maybe Object) where + execute (ForLoopBlock name o block) = + execNested_ (M.singleton name o) $ loop (codeBlock block) where + done cont = do + ref <- gets execStack + newValue <- return $ M.lookup name $ head $ mapList ref + return (cont, newValue) + loop ex = case ex of + [] -> done True + e:ex -> case e of + ContinueExpr a cond _loc -> case cond of + EvalExpr (ObjArithExpr (ObjectExpr VoidExpr)) -> done a + cond -> execute cond >>= maybe err (execute . objToBool) >>= done . (if a then id else not) where + err = fail "expression does not evaluate to boolean" + e -> execute e >> loop ex + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_Script Object) where + toDaoStruct = let nm = renameConstructor in ask >>= \o -> case o of + AST_Comment a -> nm "Comment" $ putComments a + AST_IfThenElse a -> innerToStruct a + AST_WhileLoop a -> innerToStruct a + AST_RuleFunc a -> innerToStruct a + AST_EvalObject a b loc -> nm "ObjectExpr" $ "expr" .= a >> putComments b >> putLocation loc + AST_TryCatch a b c d loc -> nm "TryCatch" $ do + "comments" .= a >> "tryBlock" .= b >> "elseBlocks" .= listToObj c + "catchBlocks" .= listToObj d >> putLocation loc + AST_ForLoop a b c loc -> nm "ForLoop" $ do + "varName" .= a >> "iterate" .= b >> "block" .= c >> putLocation loc + AST_ContinueExpr a b c loc -> nm (if a then "Continue" else "Break") $ do + putComments b >> "condition" .= c >> putLocation loc + AST_ReturnExpr a b loc -> nm (if a then "Return" else "Throw") $ do + "expr" .= b >> putLocation loc + AST_WithDoc a b loc -> nm "WithDoc" $ "expr" .= a >> "block" .= b >> putLocation loc + +instance FromDaoStructClass (AST_Script Object) where + fromDaoStruct = msum $ + [ constructor "Comment" >> AST_Comment <$> comments + , AST_IfThenElse <$> fromDaoStruct + , AST_WhileLoop <$> fromDaoStruct + , AST_RuleFunc <$> fromDaoStruct + , constructor "ObjectExpr" >> return AST_EvalObject <*> req "expr" <*> comments <*> location + , constructor "TryCatch" >> + return AST_TryCatch + <*> comments + <*> req "tryBlock" + <*> reqList "elseBlocks" + <*> reqList "catchBlocks" + <*> location + , constructor "ForLoop" >> + return AST_ForLoop <*> req "varName" <*> req "iterate" <*> req "block" <*> location + , constructor "Continue" >> + return (AST_ContinueExpr True ) <*> comments <*> req "condition" <*> location + , constructor "Break" >> + return (AST_ContinueExpr False) <*> comments <*> req "condition" <*> location + , constructor "Return" >> return (AST_ReturnExpr True ) <*> req "expr" <*> location + , constructor "Throw" >> return (AST_ReturnExpr False) <*> req "expr" <*> location + , constructor "WithDoc" >> return AST_WithDoc <*> req "expr" <*> req "block" <*> location + ] + +instance ObjectClass [AST_Script Object] where { obj=listToObj; fromObj=listFromObj; } + +instance ObjectClass (AST_Script Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_Script Object) where + haskellDataInterface = interface "ScriptExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0x86 +instance B.Binary (ObjListExpr Object) MTab where + put (ObjListExpr lst loc) = B.prefixByte 0x86 $ B.putUnwrapped lst >> B.put loc + get = (B.tryWord8 0x86 $ return ObjListExpr <*> B.getUnwrapped <*> B.get) <|> fail "expecting ObjListExpr" + +instance Executable (ObjListExpr Object) [Object] where + execute (ObjListExpr exprs _) = forM (zip exprs [1..]) $ \ (a, i) -> execute a >>= maybe (err i) return where + err i = execThrow "item in list literal expression evaluates to void" ExecErrorUntyped [(argNum, obj (i::Int))] + +instance PPrintable (ObjListExpr Object) where { pPrint = pPrintInterm } + +instance ObjectClass (ObjListExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (ObjListExpr Object) where + haskellDataInterface = interface "ListLiteral" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter >> autoDefBinaryFmt + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_ObjList Object) where + toDaoStruct = ask >>= \o -> case o of + AST_ObjList coms lst loc -> renameConstructor "ListLiteralExpression" $ do + putComments coms >> defObjField "items" (listToObj lst) >> putLocation loc + +instance FromDaoStructClass (AST_ObjList Object) where + fromDaoStruct = constructor "ListLiteralExpression" >> + return AST_ObjList <*> comments <*> reqList "items" <*> location + +instance ObjectClass (AST_ObjList Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_ObjList Object) where + haskellDataInterface = interface "ListLiteralExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +instance B.Binary (OptObjListExpr Object) MTab where + put (OptObjListExpr o) = B.put o + get = OptObjListExpr <$> B.get + +instance Executable (OptObjListExpr Object) [Object] where + execute (OptObjListExpr lst) = maybe (return []) execute lst + +instance ObjectClass (OptObjListExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (OptObjListExpr Object) where + haskellDataInterface = interface "OptionalListLiteral" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt + +-- | Evaluate an 'Exec', but if it throws an exception, set record an 'ObjectExpr' where +-- the exception occurred in the exception information. +updateExecError :: (ExecControl -> ExecControl) -> Exec a -> Exec a +updateExecError upd fn = catchError fn (\err -> throwError (upd err)) + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_OptObjList Object) where + toDaoStruct = ask >>= \o -> case o of + AST_OptObjList coms o -> renameConstructor "OptObjList" $ "params" .=? o >> putComments coms + +instance FromDaoStructClass (AST_OptObjList Object) where + fromDaoStruct = constructor "OptObjList" >> return AST_OptObjList <*> comments <*> opt "params" + +instance ObjectClass (AST_OptObjList Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_OptObjList Object) where + haskellDataInterface = interface "OptionalListLiteralExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +instance B.Binary (LiteralExpr Object) MTab where + put (LiteralExpr a loc) = B.put a >> B.put loc + get = B.word8PrefixTable <|> fail "expecting LiteralExpr" + +instance B.HasPrefixTable (LiteralExpr Object) B.Byte MTab where + prefixTable = B.bindPrefixTable B.prefixTable $ \o -> LiteralExpr o <$> B.get + +instance Executable (LiteralExpr Object) (Maybe Object) where { execute (LiteralExpr o _) = return (Just o) } + +instance ObjectClass (LiteralExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (LiteralExpr Object) where + haskellDataInterface = interface "Literal" $ do + autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt >> defDeref execute + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_Literal Object) where + toDaoStruct = ask >>= \o -> case o of + AST_Literal o loc -> renameConstructor "Literal" $ "obj" .= o >> putLocation loc + +instance FromDaoStructClass (AST_Literal Object) where + fromDaoStruct = constructor "Literal" >> return AST_Literal <*> req "obj" <*> location + +instance ObjectClass (AST_Literal Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_Literal Object) where + haskellDataInterface = interface "LiteralExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0x3C 0x42 ReferenceExpr-->Reference +instance B.Binary (ReferenceExpr Object) MTab where + put qref = case qref of + ReferenceExpr q n r loc -> prefix q $ B.put n >> B.put r >> B.put loc where + prefix q = B.prefixByte $ case q of + { UNQUAL -> 0x48; LOCAL -> 0x49; CONST -> 0x4A; STATIC -> 0x4B; GLOBAL -> 0x4C; GLODOT -> 0x4D; } + RefObjectExpr o r loc -> B.putWord8 0x4E >> B.put o >> B.put r >> B.put loc + get = B.word8PrefixTable <|> fail "expecting Reference" + +instance B.HasPrefixTable (ReferenceExpr Object) Word8 MTab where + prefixTable = B.mkPrefixTableWord8 "ReferenceExpr" 0x48 0x4E $ + [ f UNQUAL, f LOCAL, f CONST, f STATIC, f GLOBAL, f GLODOT + , return RefObjectExpr <*> B.get <*> B.get <*> B.get + ] where { f q = return (ReferenceExpr q) <*> B.get <*> B.get <*> B.get } + +instance Executable (ReferenceExpr Object) (Maybe Object) where + execute qref = errLocation qref $ case qref of + RefObjectExpr o NullRefExpr _ -> execute o + RefObjectExpr o suf _ -> do + o <- execute o >>= + checkVoid (getLocation o) "function call on item in parentheses which evaluated to a void value" + suf <- execute suf + return $ Just $ obj $ RefObject o suf + ReferenceExpr q ref suf _loc -> execute suf >>= return . Just . ORef . Reference q ref + +instance ObjectClass (ReferenceExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (ReferenceExpr Object) where + haskellDataInterface = interface "ReferenceLiteral" $ do + autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt + defDeref (execute >=> fmap snd . maybeDerefObject) + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_Reference Object) where + toDaoStruct = ask >>= \o -> case o of + AST_RefObject o ref loc -> renameConstructor "ParenExpr" $ do + "paren" .= o >> "suffix" .= ref >> putLocation loc + AST_Reference q coms name ref loc -> renameConstructor "Reference" $ do + "qualifier" .= q >> putComments coms >> "name" .= name >> "suffix" .= ref >> putLocation loc + +instance FromDaoStructClass (AST_Reference Object) where + fromDaoStruct = msum $ + [ constructor "ParenExpr" >> + return AST_RefObject <*> req "paren" <*> req "suffix" <*> location + , constructor "Reference" >> + return AST_Reference <*> req "qualifier" + <*> comments <*> req "name" <*> req "suffix" <*> location + ] + +instance ObjectClass (AST_Reference Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_Reference Object) where + haskellDataInterface = interface "ReferenceExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + defDeref (msum . map (execute >=> fmap snd . maybeDerefObject) . toInterm) + +---------------------------------------------------------------------------------------------------- + +-- binary 0x52 0x53 +instance B.Binary (RefPrefixExpr Object) MTab where + put o = case o of + PlainRefExpr a -> B.put a + RefPrefixExpr a b z -> let f = B.put b >> B.put z in case a of + REF -> B.prefixByte 0x52 f + DEREF -> B.prefixByte 0x53 f + get = B.word8PrefixTable <|> fail "expecting RefPrefixExpr" + +instance B.HasPrefixTable (RefPrefixExpr Object) B.Byte MTab where + prefixTable = fmap PlainRefExpr B.prefixTable <> + (B.mkPrefixTableWord8 "RefPrefixExpr" 0x52 0x53 $ + let f q = return (RefPrefixExpr q) <*> B.get <*> B.get in [f REF, f DEREF]) + +instance Executable (RefPrefixExpr Object) (Maybe Object) where + execute ref = errLocation ref $ case ref of + PlainRefExpr ref -> execute ref + RefPrefixExpr op ref loc -> case op of + REF -> do + ref <- execute ref >>= checkVoid loc "operand of referencing operator ($)" + case ref of + ORef ref -> return $ Just $ ORef $ RefWrapper ref + ref -> return $ Just $ ORef $ RefObject ref NullRef + DEREF -> execute ref >>= checkVoid loc "operand of dereferencing operator (@)" >>= + fmap Just . derefObject + +instance ObjectClass (RefPrefixExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (RefPrefixExpr Object) where + haskellDataInterface = interface "RefPrefixLiteral" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefBinaryFmt + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_RefPrefix Object) where + toDaoStruct = ask >>= \o -> case o of + AST_PlainRef a -> renameConstructor "PlainRef" $ "ref" .= a >> return () + AST_RefPrefix a b c loc -> renameConstructor "RefPrefix" $ do + "op" .= a >> putComments b >> "expr" .= c >> putLocation loc + +instance FromDaoStructClass (AST_RefPrefix Object) where + fromDaoStruct = msum $ + [ constructor "RefPrefix" >> + return AST_RefPrefix <*> req "op" <*> req "expr" <*> req "expr" <*> location + , constructor "PlainRef" >> AST_PlainRef <$> req "ref" + ] + +instance ObjectClass (AST_RefPrefix Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_RefPrefix Object) where + haskellDataInterface = interface "ReferencePrefixExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0x74 0x76 +instance B.Binary (RuleFuncExpr Object) MTab where + put o = case o of + LambdaExpr a b z -> B.prefixByte 0x74 $ B.put a >> B.put b >> B.put z + FuncExpr a b c z -> B.prefixByte 0x75 $ B.put a >> B.put b >> B.put c >> B.put z + RuleExpr a b z -> B.prefixByte 0x76 $ B.put a >> B.put b >> B.put z + get = B.word8PrefixTable <|> fail "expecting RuleFuncExpr" + +instance B.HasPrefixTable (RuleFuncExpr Object) B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "RuleFuncExpr" 0x74 0x76 $ + [ return LambdaExpr <*> B.get <*> B.get <*> B.get + , return FuncExpr <*> B.get <*> B.get <*> B.get <*> B.get + , return RuleExpr <*> B.get <*> B.get <*> B.get + ] + +instance Executable (RuleFuncExpr Object) (Maybe Object) where + execute o = case o of + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + LambdaExpr params script _ -> do + let exec = setupCodeBlock script + return $ Just $ new $ + [CallableCode{argsPattern=params, codeSubroutine=exec, returnType=nullValue}] + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + FuncExpr name params script _ -> do + let exec = setupCodeBlock script + let callableCode = CallableCode{argsPattern=params, codeSubroutine=exec, returnType=nullValue} + localVarUpdate name $ \o -> case o>>=fromObj of + Nothing -> Just $ obj [callableCode] + Just cc -> Just $ obj $ cc++[callableCode] + return (Just $ obj [callableCode]) + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + RuleExpr rs script _ -> do + let sub = setupCodeBlock script + pats <- execute rs + return $ Just $ obj $ PatternRule{ rulePatterns=pats, ruleAction=sub } + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +instance ObjectClass (RuleFuncExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (RuleFuncExpr Object) where + haskellDataInterface = interface "FunctionLiteral" $ do + autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt >> autoDefPPrinter + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_RuleFunc Object) where + toDaoStruct = let nm = renameConstructor in ask >>= \o -> case o of + AST_Lambda a b loc -> nm "Lambda" $ "params" .= a >> "block" .= b >> putLocation loc + AST_Func a b c d loc -> nm "Function" $ + putComments a >> "name" .= b >> "params" .= c >> "block" .= d >> putLocation loc + AST_Rule a b loc -> nm "Rule" $ "params" .= a >> "block" .= b >> putLocation loc + +instance FromDaoStructClass (AST_RuleFunc Object) where + fromDaoStruct = msum $ + [ constructor "Lambda" >> return AST_Lambda <*> req "params" <*> req "block" <*> location + , constructor "Function" >> + return AST_Func <*> comments <*> req "name" <*> req "params" <*> req "block" <*> location + , constructor "Rule" >> return AST_Rule <*> req "params" <*> req "block" <*> location + ] + +instance ObjectClass (AST_RuleFunc Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_RuleFunc Object) where + haskellDataInterface = interface "FunctionLiteralExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0x60 0x65 +instance B.Binary (ObjectExpr Object) MTab where + put o = case o of + ObjSingleExpr a -> B.put a + ObjLiteralExpr a -> B.put a + VoidExpr -> B.putWord8 0x60 + ArithPfxExpr a b z -> B.prefixByte 0x61 $ B.put a >> B.put b >> B.put z + InitExpr a b c z -> B.prefixByte 0x62 $ B.put a >> B.put b >> B.put c >> B.put z + StructExpr a b z -> B.prefixByte 0x63 $ B.put a >> B.put b >> B.put z + MetaEvalExpr a z -> B.prefixByte 0x64 $ B.put a >> B.put z + get = B.word8PrefixTable <|> fail "expecting ObjectExpr" + +instance B.HasPrefixTable (ObjectExpr Object) B.Byte MTab where + prefixTable = mconcat $ + [ ObjLiteralExpr <$> B.prefixTable + , ObjSingleExpr <$> B.prefixTable + , B.mkPrefixTableWord8 "ObjectExpr" 0x60 0x64 $ + [ return VoidExpr + , return ArithPfxExpr <*> B.get <*> B.get <*> B.get + , return InitExpr <*> B.get <*> B.get <*> B.get <*> B.get + , return StructExpr <*> B.get <*> B.get <*> B.get + , return MetaEvalExpr <*> B.get <*> B.get + ] + ] + +instance Executable (ObjectExpr Object) (Maybe Object) where + execute o = errLocation o $ case o of + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + VoidExpr -> return Nothing + -- 'VoidExpr's only occur in return statements. Returning 'ONull' where nothing exists is + -- probably the most intuitive thing to do on an empty return statement. + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + ObjLiteralExpr o -> execute o + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + ObjSingleExpr o -> execute o + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + ArithPfxExpr op expr loc -> do + expr <- execute expr >>= fmap snd . maybeDerefObject >>= + checkVoid loc ("operand to prefix operator "++show op) + execute $ fmap Just (evalArithPrefixOp op expr) + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + InitExpr ref bnds initMap _ -> Just <$> _evalInit (dotLabelToRefExpr ref) bnds initMap + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + StructExpr name (OptObjListExpr items) _ -> case items of + Nothing -> return (Just $ OTree $ Nullary{ structName=name }) + Just (ObjListExpr items _) -> execNested_ M.empty $ do + forM_ items $ \item -> case item of + AssignExpr{} -> execute item -- fill the local stack by executing each assignment + _ -> fail "struct initializer is not an assignment expression" + stack <- gets execStack + let items = head $ mapList stack + return $ Just $ OTree $ + if M.null items + then Nullary{ structName=name } + else Struct{ fieldMap=items, structName=name } + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + MetaEvalExpr expr _ -> return $ Just $ new expr + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +_evalInit :: ReferenceExpr Object -> OptObjListExpr Object -> ObjListExpr Object -> Exec Object +_evalInit ref bnds initMap = do + ref <- execute ref >>= checkVoid (getLocation ref) "initializer label" + ref <- case ref of + ORef (Reference UNQUAL name NullRef) -> pure name + ref -> throwBadTypeError "cannot use reference as initalizer" ref [] + bnds <- execute bnds >>= mapM derefObject + let cantUseBounds msg = + execThrow ("initializer "++msg++" must be defined without bounding parameters") + ExecErrorUntyped [(assertFailed, OList bnds)] + let list = case bnds of + [] -> execNested_ M.empty $ fmap OList $ execute initMap >>= mapM derefObject + _ -> cantUseBounds "for list constructor" + let (ObjListExpr items _) = initMap + let dict = case bnds of + [] -> (ODict . snd) <$> execNested M.empty (mapM_ assignUnqualifiedOnly items) + _ -> cantUseBounds "for dict constructor" + case uchars ref of + "list" -> list + "List" -> list + "dict" -> dict + "Dict" -> dict + "Dictionary" -> dict + _ -> do + tab <- execGetObjTable ref + let qref = Reference UNQUAL ref NullRef + case tab of + Nothing -> execThrow "unknown object constructor" qref [] + Just tab -> execNested_ M.empty $ case objInitializer tab of + Nothing -> execThrow "cannot declare constant object of type" qref [] + Just (init, fold) -> do + o <- init bnds + items <- forM items $ \item -> case item of + AssignExpr a op b _ -> do + a <- execute a >>= checkVoid (getLocation a) "left-hand side of initializer assignemt" + b <- execute b >>= checkVoid (getLocation b) "right-hand side of initializer assignment" >>= derefObject + return $ InitAssign a op b + EvalExpr arith -> fmap InitSingle $ + execute arith >>= checkVoid (getLocation arith) "initializer item" + OHaskell . Hata tab <$> fold o items + +instance ObjectClass (ObjectExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (ObjectExpr Object) where + haskellDataInterface = interface "ObjectLiteral" $ do + autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt + defDeref execute >> autoDefPPrinter + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_Object Object) where + toDaoStruct = let nm = renameConstructor in ask >>= \o -> case o of + AST_Void -> makeNullary "Void" + AST_ObjLiteral a -> innerToStruct a + AST_ObjSingle a -> innerToStruct a + AST_ArithPfx a b c loc -> nm "ArithPrefix" $ do + "op" .= a >> putComments b >> "expr" .= c >> putLocation loc + AST_Init a b c loc -> nm "Init" $ do + "name" .= a >> "params" .= b >> "initList" .= c >> putLocation loc + AST_Struct a b loc -> nm "Struct" $ "name" .= a >> "initList" .= b >> putLocation loc + AST_MetaEval a loc -> nm "MetaEval" $ "block" .= a >> putLocation loc + +instance FromDaoStructClass (AST_Object Object) where + fromDaoStruct = msum $ + [ nullary "Void" >> return AST_Void + , AST_ObjLiteral <$> fromDaoStruct + , AST_ObjSingle <$> fromDaoStruct + , constructor "ArithPrefix" >> + pure AST_ArithPfx <*> req "op" <*> comments <*> req "expr" <*> location + , constructor "Init" >> + pure AST_Init <*> req "name" <*> req "params" <*> req "initList" <*> location + , constructor "Struct" >> pure AST_Struct <*> req "name" <*> req "initList" <*> location + , constructor "MetaEval" >> pure AST_MetaEval <*> req "block" <*> location + ] + +instance ObjectClass (AST_Object Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_Object Object) where + haskellDataInterface = interface "ObjectLiteralExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0x6A +instance B.Binary (ArithExpr Object) MTab where + put o = case o of + ObjectExpr a -> B.put a + ArithExpr a b c z -> B.prefixByte 0x6A $ B.put a >> B.put b >> B.put c >> B.put z + get = B.word8PrefixTable <|> fail "expecting arithmetic expression" + +instance B.HasPrefixTable (ArithExpr Object) B.Byte MTab where + prefixTable = mappend (ObjectExpr <$> B.prefixTable) $ + B.mkPrefixTableWord8 "ArithExpr" 0x6A 0x6A $ + [pure ArithExpr <*> B.get <*> B.get <*> B.get <*> B.get] + +instance Executable (ArithExpr Object) (Maybe Object) where + execute o = case o of + ObjectExpr o -> execute o + ArithExpr left' op right' loc -> do + let err1 msg = msg++"-hand operand of "++show op++ "operator " + evalLeft = execute left' >>= checkVoid loc (err1 "left" ) + evalRight = execute right' >>= checkVoid loc (err1 "right") + derefLeft = evalLeft >>= derefObject + derefRight = evalRight >>= derefObject + logical isAndOp = fmap Just $ do + left <- derefLeft >>= execute . objToBool + if left + then if isAndOp then derefRight else return OTrue + else if isAndOp then return ONull else derefRight + case op of + AND -> logical True + OR -> logical False + op -> do + (left, right) <- case op of + ARROW -> liftM2 (,) derefLeft evalRight + _ -> liftM2 (,) derefLeft derefRight + execute (fmap Just $ evalInfixOp op left right) + +instance ObjectClass (ArithExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (ArithExpr Object) where + haskellDataInterface = interface "Arithmetic" $ do + autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt + defDeref execute >> autoDefPPrinter + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_Arith Object) where + toDaoStruct = ask >>= \o -> case o of + AST_Object a -> innerToStruct a + AST_Arith a b c loc -> renameConstructor "Arithmetic" $ do + "left" .= a >> "op" .= b >> "right" .= c >> putLocation loc + +instance FromDaoStructClass (AST_Arith Object) where + fromDaoStruct = msum $ + [ AST_Object <$> fromDaoStruct + , constructor "Arithmetic" >> + pure AST_Arith <*> req "left" <*> req "op" <*> req "right" <*> location + ] + +instance ObjectClass (AST_Arith Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_Arith Object) where + haskellDataInterface = interface "ArithmeticExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +newtype DerefAssignExpr = DerefAssignExpr (AssignExpr Object) +-- ^ This data type instantiates 'Executable' such that the result is always dereference once. This +-- is necessary because an 'AssignExpr' always evaluates to an 'Object' literal expression, meaning +-- if the 'AssignExpr' contains 'ReferenceExpr', it will evaluate to an 'Object' constructing a +-- literal 'Reference' (using the 'ORef' constructor). Sometimes this is desirable, sometimes it is +-- not. It is desirable when evaluating arguments for a function call that requests it's arguments +-- not be dereferenced. It is not desirable when evaluating an arithmetic equation and the integer +-- value stored at a 'Reference' variable is required, and not the 'Reference' value itself. +-- The calling context cannot know what the result will be, or whether or not it is necessary to +-- call 'derefObject' on the result unless the calling context inspects the 'AssignExpr' value with +-- a case statement. By wrapping the 'AssignExpr' in this data type first and then evaluating +-- 'execute', you are guranteed that any 'ReferenceExpr' will evaluate to the value stored at the +-- resulting 'Reference' literal, and not the 'Reference' literal itself. + +instance Executable DerefAssignExpr (Maybe Object) where + execute (DerefAssignExpr o) = case o of + EvalExpr{} -> execute o >>= fmap snd . maybeDerefObject + AssignExpr{} -> execute o + +_executeAssignExpr + :: (Reference -> UpdateOp -> Object -> Exec (Maybe Object)) + -> AssignExpr Object -> Exec (Maybe Object) +_executeAssignExpr update o = case o of + EvalExpr expr -> execute expr + AssignExpr qref op expr loc -> do + qref <- execute qref >>= + checkVoid (getLocation qref) "left-hand side of assignment expression evaluated to void" + case qref of + ORef qref -> do + newObj <- execute expr >>= checkVoid loc "right-hand side of assignment" >>= derefObject + update qref op newObj + _ -> fail "left-hand side of assignment expression is not a reference value" + +-- binary 0x6F +instance B.Binary (AssignExpr Object) MTab where + put o = case o of + EvalExpr a -> B.put a + AssignExpr a b c z -> B.prefixByte 0x6F $ B.put a >> B.put b >> B.put c >> B.put z + get = B.word8PrefixTable <|> fail "expecting AssignExpr" + +instance B.HasPrefixTable (AssignExpr Object) B.Byte MTab where + prefixTable = mappend (EvalExpr <$> B.prefixTable) $ + B.mkPrefixTableWord8 "AssignExpr" 0x6F 0x6F $ + [pure AssignExpr <*> B.get <*> B.get <*> B.get <*> B.get] + +instance Executable (AssignExpr Object) (Maybe Object) where + execute = _executeAssignExpr $ \qref op newObj -> + snd <$> referenceUpdate qref (op/=UCONST) (evalUpdateOp (Just qref) op newObj) + +-- | This function works a bit like how 'execute' works on an 'AssignExpr' data type, but every +-- assignment is checked to make sure it is local or unqualified. Furthurmore, all assignments are +-- forced into the top of the local variable stack, already-defined vairables at higher points in +-- the local variable stack are not updated in place. This function is used to define items in +-- is one important difference: it is specifically modified to work for evaluation of 'InitExpr' +-- data types, for example in the Dao language expression: @a = dict {a=1, b=2};@ Using this +-- function instead of 'execute' will always assign variables in the top of the local variable +-- stack, regardless of whether the variable has been defined before. This makes it possible to +-- write Dao language statements like this: @a=1; a = dict {a=a, b=2};@ which would create a +-- dictionary @a = dict {a=1, b=2};@, because before the "dict{}" expression, "a" had a value of 1. +assignUnqualifiedOnly :: AssignExpr Object -> Exec (Maybe Object) +assignUnqualifiedOnly = _executeAssignExpr $ \qref op newObj -> case qref of + Reference UNQUAL r NullRef -> do + store <- gets execStack + let oldObj = stackLookup r store + newObj <- evalUpdateOp (Just qref) op newObj oldObj + (result, store) <- pure $ stackUpdateTop (const (newObj, newObj)) r store + modify $ \xunit -> xunit{ execStack = store } + return result + _ -> execThrow "assignment must be unqualified" ExecErrorUntyped [(errOfReference, obj qref)] + +instance ObjectClass (AssignExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AssignExpr Object) where + haskellDataInterface = interface "Assignment" $ do + autoDefNullTest >> autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt + defDeref execute >> autoDefPPrinter + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_Assign Object) where + toDaoStruct = ask >>= \o -> case o of + AST_Eval o -> innerToStruct o + AST_Assign to op from loc -> renameConstructor "Assign" $ do + "to" .= to >> "op" .= op >> "from" .= from >> putLocation loc + +instance FromDaoStructClass (AST_Assign Object) where + fromDaoStruct = msum $ + [ AST_Eval <$> fromDaoStruct + , pure AST_Assign <*> req "to" <*> req "op" <*> req "from" <*> location + ] + +instance ObjectClass (AST_Assign Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_Assign Object) where + haskellDataInterface = interface "AssignmentExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +instance B.Binary (ObjTestExpr Object) MTab where + put o = case o of + ObjArithExpr a -> B.put a + ObjTestExpr a b c d -> B.prefixByte 0x73 $ B.put a >> B.put b >> B.put c >> B.put d + ObjRuleFuncExpr a -> B.put a + get = B.word8PrefixTable <|> fail "expecting ObjTestExpr" + +instance B.HasPrefixTable (ObjTestExpr Object) Word8 MTab where + prefixTable = mconcat $ + [ ObjArithExpr <$> B.prefixTable + , ObjRuleFuncExpr <$> B.prefixTable + , B.mkPrefixTableWord8 "ObjTestExpr" 0x73 0x73 $ + [return ObjTestExpr <*> B.get <*> B.get <*> B.get <*> B.get] + ] + +instance Executable (ObjTestExpr Object) (Maybe Object) where + execute o = errCurrentModule $ case o of + ObjArithExpr a -> execute a + ObjTestExpr a b c _ -> + execute a >>= checkVoid (getLocation a) "conditional expression evaluates to void" >>= derefObject >>= + execute . objToBool >>= \ok -> if ok then execute b else execute c + ObjRuleFuncExpr o -> execute o + +instance ObjectClass (ObjTestExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (ObjTestExpr Object) where + haskellDataInterface = interface "ObjectTest" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_ObjTest Object) where + toDaoStruct = ask >>= \o -> case o of + AST_ObjArith a -> innerToStruct a + AST_ObjTest a b c d e f -> renameConstructor "ObjTest" $ do + "condition" .= a + "quesMarkComs" .= b >> "action" .= c + "colonComs" .= d >> "alt" .= e + putLocation f + AST_ObjRuleFunc a -> innerToStruct a + +instance FromDaoStructClass (AST_ObjTest Object) where + fromDaoStruct = msum $ + [ AST_ObjArith <$> fromDaoStruct + , do constructor "ObjTest" + return AST_ObjTest + <*> req "condition" + <*> (maybe (Com ()) id <$> opt "quesMarkComs") <*> req "action" + <*> (maybe (Com ()) id <$> opt "colonComs" ) <*> req "alt" + <*> location + , AST_ObjRuleFunc <$> fromDaoStruct + ] + +instance ObjectClass (AST_ObjTest Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_ObjTest Object) where + haskellDataInterface = interface "ObjectTestExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass AST_Namespace where + toDaoStruct = ask >>= \a -> case a of + AST_NoNamespace -> makeNullary "NoNamespace" + AST_Namespace n loc -> renameConstructor "Namespace" $ "name" .= n >> putLocation loc + +instance FromDaoStructClass AST_Namespace where + fromDaoStruct = msum $ + [ nullary "NoNamespace" >> return AST_NoNamespace + , constructor "Namespace" >> return AST_Namespace <*> req "name" <*> location + ] + +instance ObjectClass AST_Namespace where { obj=new; fromObj=objFromHata; } + +instance HataClass AST_Namespace where + haskellDataInterface = interface "NamespaceExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- binary 0x81 0x82 -- placed next to with 'DotNameExpr' +instance B.Binary AttributeExpr MTab where + put o = case o of + AttribDotNameExpr a -> B.put a + AttribStringExpr a loc -> B.prefixByte 0x82 $ B.put a >> B.put loc + get = B.word8PrefixTable <|> fail "expecting AttributeExpr" + +instance B.HasPrefixTable AttributeExpr Word8 MTab where + prefixTable = (AttribDotNameExpr <$> B.prefixTable) <> + B.mkPrefixTableWord8 "AttributeExpr" 0x82 0x82 [return AttribStringExpr <*> B.get <*> B.get] + +-- binary 0xE9 0xEE +instance B.Binary (TopLevelExpr Object) MTab where + put o = case o of + RequireExpr a z -> B.prefixByte 0xE9 $ B.put a >> B.put z + ImportExpr a b z -> B.prefixByte 0xEA $ B.put a >> B.put b >> B.put z + TopScript a z -> B.prefixByte 0xEB $ B.put a >> B.put z + EventExpr BeginExprType b z -> B.prefixByte 0xEC $ B.put b >> B.put z + EventExpr ExitExprType b z -> B.prefixByte 0xED $ B.put b >> B.put z + EventExpr EndExprType b z -> B.prefixByte 0xEE $ B.put b >> B.put z + get = B.word8PrefixTable <|> fail "expecting TopLevelExpr" + +instance B.HasPrefixTable (TopLevelExpr Object) B.Byte MTab where + prefixTable = B.mkPrefixTableWord8 "TopLevelExpr" 0xE9 0xEE $ + [ return RequireExpr <*> B.get <*> B.get + , return ImportExpr <*> B.get <*> B.get <*> B.get + , return TopScript <*> B.get <*> B.get + , return (EventExpr BeginExprType) <*> B.get <*> B.get + , return (EventExpr ExitExprType ) <*> B.get <*> B.get + , return (EventExpr EndExprType ) <*> B.get <*> B.get + ] + +instance Executable (TopLevelExpr Object) () where + execute o = errCurrentModule $ case o of + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + RequireExpr{} -> attrib "require" + ImportExpr{} -> attrib "import" + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + TopScript script _ -> do + ((), dict) <- execNested mempty $ catchPredicate (execute script) >>= \pval -> case pval of + OK _ -> return () + PFail (ExecReturn _) -> return () + PFail err -> throwError err + Backtrack -> return () -- do not backtrack at the top-level + let addIfFuncs a b = maybe b id $ do -- overwrite previously declared variables... + (a, b) <- Just (,) <*> fromObj a <*> fromObj b + Just $ obj ((a++b)::[CallableCode]) -- ...unless both variables are [CallableCode] + modify $ \xunit -> xunit{ globalData = M.unionWith addIfFuncs (globalData xunit) dict } + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + EventExpr typ script _ -> do + let exec = setupCodeBlock script + let f = (++[exec]) + modify $ \xunit -> case typ of + BeginExprType -> xunit{ preExec = f (preExec xunit) } + EndExprType -> xunit{ postExec = f (postExec xunit) } + ExitExprType -> xunit{ quittingTime = f (quittingTime xunit) } + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + where + attrib a = fail $ a++" expression must occur only at the top of a dao script file" + +instance ObjectClass (TopLevelExpr Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (TopLevelExpr Object) where + haskellDataInterface = interface "TopLevel" $ do + autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt >> autoDefPPrinter + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass AST_Attribute where + toDaoStruct = ask >>= \o -> case o of + AST_AttribDotName str -> renameConstructor "AttributeDotName" $ innerToStruct str + AST_AttribString str loc -> + renameConstructor "AttributeString" $ "value" .= str >> putLocation loc + +instance FromDaoStructClass AST_Attribute where + fromDaoStruct = msum $ + [ constructor "AttributeDotName" >> AST_AttribDotName <$> innerFromStruct "DotLabel" + , constructor "AttributeString" >> return AST_AttribString <*> req "value" <*> location + ] + +instance ObjectClass AST_Attribute where { obj=new; fromObj=objFromHata; } + +instance HataClass AST_Attribute where + haskellDataInterface = interface "AttributeExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +instance ToDaoStructClass (AST_TopLevel Object) where + toDaoStruct = let nm = renameConstructor in ask >>= \o -> case o of + AST_Require a loc -> nm "Require" $ "attribute" .= a >> putLocation loc + AST_Import a b loc -> nm "Import" $ "attribute" .= a >> "namespace" .= b >> putLocation loc + AST_TopScript a loc -> nm "TopLevel" $ "script" .= a >> putLocation loc + AST_TopComment a -> nm "Comment" $ putComments a + AST_Event a b c loc -> + nm "Event" $ "type" .= a >> "block" .= c >> putComments b >> putLocation loc + +instance FromDaoStructClass (AST_TopLevel Object) where + fromDaoStruct = msum $ + [ constructor "Import" >> return AST_Import <*> req "attribute" <*> req "namespace" <*> location + , constructor "Require" >> return AST_Require <*> req "attribute" <*> location + , constructor "TopLevel" >> return AST_TopScript <*> req "script" <*> location + , constructor "Event" >> return AST_Event <*> req "type" <*> comments <*> req "block" <*> location + , constructor "Comment" >> AST_TopComment <$> comments + ] + +instance ObjectClass (AST_TopLevel Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_TopLevel Object) where + haskellDataInterface = interface "TopLevelExpression" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +-- the number is encoded by the ASCII encoded string "DaoProg\0" +program_magic_number :: Word64 +program_magic_number = 0x44616f50726f6700 + +instance B.Binary (Program Object) MTab where + put o = do + -- place a magic number first, + B.putWord64be program_magic_number + mapM_ B.put $ topLevelExprs o + get = do + magic <- B.lookAhead B.getWord64be + guard (magic == program_magic_number) + B.getWord64be >> fmap Program B.get + +-- | Initialized the current 'ExecUnit' by evaluating all of the 'TopLevel' data in a +-- 'AST.AST_SourceCode'. +instance Executable (Program Object) () where + execute (Program ast) = do + ((), localVars) <- execNested mempty $ mapM_ execute (dropWhile isAttribute ast) + -- Now, the local variables that were defined in the top level need to be moved to the global + -- variable store. + modify $ \xunit -> xunit{ globalData = M.union localVars (globalData xunit) } + +instance ObjectClass (Program Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (Program Object) where + haskellDataInterface = interface "ProgramData" $ do + autoDefEquality >> autoDefNullTest >> autoDefBinaryFmt + +---------------------------------------------------------------------------------------------------- + +_withGlobalKey :: Object -> (H.Index Object -> RefMonad Object Dynamic a) -> Exec a +_withGlobalKey idx f = gets globalMethodTable >>= \mt -> + gets runtimeRefTable >>= liftIO . runReaderT (f $ H.hashNewIndex (H.deriveHash128_DaoBinary mt) idx) + +-- | Some objects may refer to an object that serves as a unique identifier created by the system, +-- for example objects refereing to file handles. These unique identifying objects should always be +-- stored in this table. The Dao 'Object' wrapper should be used as the index to retrieve the Object +-- in the table. This function takes the object to be stored, a destructor function to be called on +-- releasing the object, and an indexing object used to identify the stored object in the table. +initializeGlobalKey :: Typeable o => o -> (o -> IO ()) -> Object -> Exec (H.Index Object) +initializeGlobalKey o destructor idx = _withGlobalKey idx $ \key -> + initializeWithKey (toDyn o) (destructor o) key >> return key + +-- | Destroy an object that was stored into the global key table using 'initializeGlobalKey'. The +-- destructor function passed to the 'initializeGlobalKey' will be evaluated, and the object will +-- be removed from the table. This function takes an indexing object used to select the stored +-- object from the table. +destroyGlobalKey :: Object -> Exec () +destroyGlobalKey = flip _withGlobalKey destroyWithKey + +---------------------------------------------------------------------------------------------------- + +instance ToDaoStructClass (AST_SourceCode Object) where + toDaoStruct = renameConstructor "SourceCode" $ do + "modified" .=@ sourceModified + "path" .=@ sourceFullPath + asks directives >>= define "code" . listToObj + +instance FromDaoStructClass (AST_SourceCode Object) where + fromDaoStruct = constructor "SourceCode" >> + return AST_SourceCode <*> req "modified" <*> req "path" <*> reqList "code" + +instance ObjectClass (AST_SourceCode Object) where { obj=new; fromObj=objFromHata; } + +instance HataClass (AST_SourceCode Object) where + haskellDataInterface = interface "SourceCode" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +-- | Simply converts an 'Dao.Interpreter.AST_SourceCode' directly to a list of +-- 'Dao.Interpreter.TopLevelExpr's. +evalTopLevelAST :: AST_SourceCode Object -> Exec (Program Object) +evalTopLevelAST ast = case toInterm ast of + [o] -> return o + [] -> fail "converting AST_SourceCode to Program by 'toInterm' returned null value" + _ -> fail "convertnig AST_SourceCode to Program by 'toInterm' returned ambiguous value" + +---------------------------------------------------------------------------------------------------- +-- $Builtin_object_interfaces +-- The following functions provide object interfaces for essential data types. + +instance HataClass () where { haskellDataInterface = interface "HaskellNullValue" (return ()) } + +type Get a = B.GGet MethodTable a +type Put = B.GPut MethodTable + +-- This is only necessary to shorten the name 'MethodTable' because it is used throughout so many +-- instance declarations and type contexts. +type MTab = MethodTable + +---------------------------------------------------------------------------------------------------- + +newtype MethodTable = MethodTable (M.Map Name (Interface Dynamic)) + +instance Monoid MethodTable where + mempty = MethodTable mempty + mappend (MethodTable a) (MethodTable b) = let dups = M.intersection a b in + if M.null dups + then MethodTable (M.union b a) + else error ("Namespace conflict when installing built-in data type interfaces: "++show (M.keys dups)) + +-- | Lookup an 'Interface' by it's name from within the 'Exec' monad. +execGetObjTable :: Name -> Exec (Maybe (Interface Dynamic)) +execGetObjTable nm = gets (lookupMethodTable nm . globalMethodTable) + +lookupMethodTable :: Name -> MethodTable -> Maybe (Interface Dynamic) +lookupMethodTable nm (MethodTable tab) = M.lookup nm tab + +-- not for export, use 'daoClass' +_insertMethodTable :: (Typeable o, HataClass o) => o -> Interface o -> MethodTable -> MethodTable +_insertMethodTable _ ifc = flip mappend $ + MethodTable (M.singleton (objInterfaceName ifc) (interfaceToDynamic ifc)) + +instance B.HasCoderTable MethodTable where + getEncoderForType nm mtab = fmap fst $ lookupMethodTable nm mtab >>= objBinaryFormat + getDecoderForType nm mtab = fmap snd $ lookupMethodTable nm mtab >>= objBinaryFormat + +---------------------------------------------------------------------------------------------------- + +-- | Implements a "for" loop using a 'ReadIterable' item. This function should receive the +-- 'iter' object produced by 'initReadIter' that can be used by this function to extract each +-- 'val' and a function that is evaluated using a 'val' on every iteration of the loop. +-- 'readForLoop' should be defined call the given function as many times as necessary to +-- exaust the 'val's in the 'iter'. +-- +-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly +-- handle "break" and "catch" statements. +class ReadIterable iter val | iter -> val where + readForLoop :: iter -> (val -> Exec ()) -> Exec () + +instance ReadIterable [Object] Object where { readForLoop iter = execForM_ iter } + +instance ReadIterable Hata Object where + readForLoop h@(Hata ifc d) f = case objReadIterable ifc of + Nothing -> throwBadTypeError "cannot iterate over object" (obj h) [] + Just for -> for d f + +instance ReadIterable Object Object where + readForLoop o f = case o of + OList o -> readForLoop o f + OHaskell o -> readForLoop o f + _ -> throwBadTypeError "cannot iterate over object" o [] + +---------------------------------------------------------------------------------------------------- + +-- | A class that provides the 'updateForLoop' function, which is a function that will iterate over +-- types which can be read sequentially and modified as they are read. +-- +-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly +-- handle "break" and "catch" statements. +class UpdateIterable iter val | iter -> val where + updateForLoop :: iter -> (val -> Exec val) -> Exec iter + +instance UpdateIterable [Object] (Maybe Object) where + updateForLoop iter f = + fmap (concatMap $ \o -> maybe [] id $ (o>>=fromObj) <|> fmap return o) (execForM iter $ f . Just) + +instance UpdateIterable Hata (Maybe Object) where + updateForLoop h@(Hata ifc d) f = case objUpdateIterable ifc of + Nothing -> throwBadTypeError "cannot iterate over object" (obj h) [] + Just for -> Hata ifc <$> for d f + +instance UpdateIterable T_dict (Maybe Object) where + updateForLoop m f = fmap (M.fromList . concat) $ execForM (M.assocs m) $ \ (i, o) -> do + p <- f (Just $ obj $ Pair (obj i, o)) + case p of + Nothing -> return [] + Just p -> case fromObj p of + Just (Pair (ref, o)) -> case fromObj ref of + Just ref -> return [(ref, o)] + Nothing -> throwBadTypeError "iterator cannot updte dictionary item" ref [] + Nothing -> throwBadTypeError "a dictionary iterator must store Pair objects" p [] + +instance UpdateIterable Object (Maybe Object) where + updateForLoop o f = case o of + OList o -> OList <$> updateForLoop o f + ODict o -> ODict <$> updateForLoop o f + OHaskell o -> OHaskell <$> updateForLoop o f + o -> throwBadTypeError "cannot iterae over object" o [] + +---------------------------------------------------------------------------------------------------- + +-- | This class only exists to allow many different Haskell data types to declare their +-- 'Interface' under the same funcion name: 'haskellDataInterface'. Instantiate this function with +-- the help of the 'interface' function. +class HataClass typ where { haskellDataInterface :: Interface typ } + +instance HataClass Location where + haskellDataInterface = interface "Location" $ do + autoDefEquality >> autoDefOrdering + autoDefToStruct >> autoDefFromStruct + autoDefPPrinter + +instance HataClass Comment where + haskellDataInterface = interface "Comment" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest >> autoDefPPrinter + autoDefToStruct >> autoDefFromStruct + +instance HataClass DotNameExpr where + haskellDataInterface = interface "DotName" $ do + autoDefEquality >> autoDefBinaryFmt >> autoDefPPrinter + +instance HataClass AST_DotName where + haskellDataInterface = interface "DotNameExpression" $ do + autoDefEquality >> autoDefPPrinter >> autoDefToStruct >> autoDefFromStruct + +instance HataClass DotLabelExpr where + haskellDataInterface = interface "DotLabel" $ do + autoDefEquality >> autoDefBinaryFmt >> autoDefPPrinter + +instance HataClass AST_DotLabel where + haskellDataInterface = interface "DotLabelExpression" $ do + autoDefEquality >> autoDefPPrinter >> autoDefToStruct >> autoDefFromStruct + +---------------------------------------------------------------------------------------------------- + +instance UpdateIterable (H.HashMap Object Object) (Maybe Object) where + updateForLoop hm f = fmap (H.fromList . concat) $ execForM (H.assocs hm) $ \ (ix, o) -> do + hash128 <- getObjectHash128 + p <- f (Just $ obj $ Pair (H.indexKey ix, o)) + case p of + Nothing -> return [] + Just p -> do + let badtype = throwBadTypeError "cannot update hash map in iterator with item" p [] + maybe badtype (\ (Pair(a,b)) -> return [(H.hashNewIndex hash128 a, b)]) (fromObj p) + +instance ObjectClass (H.HashMap Object Object) where { obj=new; fromObj=objFromHata; } + +-- | The hash function for 'Object's relies on the binary serialization of the object, which +-- requires access to the 'MethodTable' of the current 'ExecUnit'. Therefore the hash function must +-- be derived from the 'Exec' monad, the 'Object' data type unfortunately cannot simply derive the +-- 'Data.HashMap.Int128Hashable' class. +getObjectHash128 :: Exec (Object -> H.Hash128) +getObjectHash128 = gets globalMethodTable >>= \mt -> return (H.deriveHash128_DaoBinary mt) + +instance HataClass (H.HashMap Object Object) where + haskellDataInterface = interface "HashMap" $ do + autoDefEquality >> autoDefOrdering >> autoDefBinaryFmt >> autoDefPPrinter + autoDefSizeable >> autoDefUpdateIterable + let un _ a b = xmaybe (fromObj b) >>= \b -> return $ new $ H.union b a + defInfixOp ADD un + defInfixOp ORB un + defInfixOp ANDB $ \ _ a b -> xmaybe (fromObj b) >>= \b -> return $ new $ (H.intersection b a :: H.HashMap Object Object) + defInfixOp SUB $ \ _ a b -> xmaybe (fromObj b) >>= \b -> return $ new $ (H.difference b a :: H.HashMap Object Object) + let initItems hmap ox = do + hash128 <- getObjectHash128 + let f hmap o = case o of + InitSingle o -> do + let idx = H.hashNewIndex hash128 o + return $ H.hashInsert idx o hmap + InitAssign i op o -> do + i <- derefObject i + let idx = H.hashNewIndex hash128 i + let ref = Just (RefObject i NullRef) <|> fromObj i + o <- evalUpdateOp ref op o (H.hashLookup idx hmap) + return $ case o of + Nothing -> H.hashDelete idx hmap + Just o -> H.hashInsert idx o hmap + foldM f hmap ox + defInitializer hashMapFromList initItems + let single_index :: Monad m => (Object -> m a) -> [Object] -> m a + single_index f ix = case ix of + [i] -> f i + [] -> fail "no index value provided in subscript to HashMap data type" + _ -> fail "HashMap is a one-dimensional data type, indexed with multi-dimesional subscript" + defIndexer $ \hm -> single_index $ \i -> do + hash128 <- getObjectHash128 + i <- derefObject i + xmaybe (H.hashLookup (H.hashNewIndex hash128 i) hm) + defIndexUpdater $ \ix upd -> flip single_index ix $ \i -> do + hash128 <- focusLiftExec getObjectHash128 + i <- focusLiftExec $ derefObject i + i <- pure (H.hashNewIndex hash128 i) + hm <- get + (result, (changed, o)) <- withInnerLens (H.hashLookup i hm) upd + when changed (put $ H.hashAlter (const o) i hm) + return result + +hashMapFromList :: [Object] -> Exec (H.HashMap Object Object) +hashMapFromList ox = do + hash128 <- getObjectHash128 + let fromDict = fmap (\ (i, o) -> (H.hashNewIndex hash128 (obj i), o)) . M.assocs + f (a, o) = case o of + OList ox -> case mapM (\ (i, o) -> maybe (Left (i, o)) Right (fromObj o)) (zip [0..] ox) of + Left (i, t) -> throwBadTypeError "list item in hash map initializer" t $ + [(errInInitzr, OInt a), (ustr "listIndex", OInt i)] + Right ox -> return $ fmap (\ (Pair(a,b)) -> (H.hashNewIndex hash128 a, b)) ox + OTree (Struct{fieldMap=ox}) -> return $ fromDict ox + ODict ox -> return $ fromDict ox + o -> do + let badtype = throwBadTypeError "hash map initializer from list" o [(errInInitzr, OInt a)] + maybe badtype return $ msum $ + [ fromObj o >>= \ (Pair(a,b)) -> Just [(H.hashNewIndex hash128 a, b)] + , H.assocs <$> fromObj o + ] + H.fromList . concat <$> mapM f (zip [1..] ox) + +builtin_HashMap :: DaoFunc () +builtin_HashMap = + daoFunc{ daoForeignFunc = \ () -> fmap (flip (,) () . Just . obj) . hashMapFromList } + +---------------------------------------------------------------------------------------------------- + +-- | When defining the function used by the Dao interpreter to construct your object from an +-- initializer statement, a statement which looks like the following code: +-- > MyObj(0, a) { item = 1, item += 3, x, y }; +-- you will need to receive the list of items expressed in curly-brackets, which could be an +-- assignment operation, or a single object value expression. This data type provides the necessary +-- data to your initializer function. +data InitItem + = InitSingle Object + | InitAssign Object UpdateOp Object + deriving (Eq, Ord, Typeable) + +---------------------------------------------------------------------------------------------------- + +-- | This is all of the functions used by the "Dao.Evaluator" when manipulating objects in a Dao +-- program. Behavior of objects when they are used in "for" statements or "with" statements, or when +-- they are dereferenced using the "@" operator, or when they are used in equations are all defined +-- here. +-- +-- So this table is the reason you instantiate 'HataClass'. +-- +-- @obj@ specifies the container type that will wrap-up data of type @typ@. @obj@ is the type used +-- throughout the runtime system to symbolize the basic unit of information operated on by +-- computations. +-- +-- @typ@ specifies the type that you want to wrap-up into an @obj@ constructor. When you want to, +-- for example, check for equality between object of type @typ@, you can define a function for +-- 'objEquality'. All of the other polymorphic types are bound to the @typ@ types by the functional +-- dependencies mechanism of the Haskell language. +-- +-- @exec@ specifies a monad in which to evaluate functions which may need to cause side-effects. +-- This should usually be a 'Control.Monad.Monad'ic type like @IO@ or 'Exec'. +data Interface typ = + Interface + { objInterfaceName :: Name + , objHaskellType :: TypeRep -- ^ this type is deduced from the initial value provided to the 'interface'. + , objCastFrom :: Maybe (Object -> typ) -- ^ defined by 'defCastFrom' + , objEquality :: Maybe (typ -> typ -> Bool) -- ^ defined by 'defEquality' + , objOrdering :: Maybe (typ -> typ -> Ordering) -- ^ defined by 'defOrdering' + , objBinaryFormat :: Maybe (typ -> Put, Get typ) -- ^ defined by 'defBinaryFmt' + , objNullTest :: Maybe (typ -> Bool) -- ^ defined by 'defNullTest' + , objPPrinter :: Maybe (typ -> PPrint) -- ^ defined by 'defPPrinter' + , objReadIterable :: Maybe (typ -> (Object -> Exec ()) -> Exec ()) -- ^ defined by 'defReadIterator' + , objUpdateIterable :: Maybe (typ -> (Maybe Object -> Exec (Maybe Object)) -> Exec typ) -- ^ defined by 'defUpdateIterator' + , objIndexer :: Maybe (typ -> [Object] -> Exec Object) -- ^ defined by 'defIndexer' + , objIndexUpdater :: Maybe (ObjectUpdate typ [Object]) -- ^ defined by 'defIndexUpdater' + , objSizer :: Maybe (typ -> Exec Object) -- ^ defined by 'defSizer' + , objToStruct :: Maybe (ToDaoStruct typ ()) -- ^ defined by 'defStructFormat' + , objFromStruct :: Maybe (FromDaoStruct typ) -- ^ defined by 'defStructFormat' + , objInitializer :: Maybe ([Object] -> Exec typ, typ -> [InitItem] -> Exec typ) -- ^ defined by 'defDictInit' + , objTraverse :: Maybe (ObjectTraverse typ [Object]) -- ^ defined by 'defTraverse' + , objInfixOpTable :: Maybe (Array InfixOp (Maybe (InfixOp -> typ -> Object -> XPure Object))) -- ^ defined by 'defInfixOp' + , objArithPfxOpTable :: Maybe (Array ArithPfxOp (Maybe (ArithPfxOp -> typ -> XPure Object))) -- ^ defined by 'defPrefixOp' + , objCallable :: Maybe (typ -> Exec [CallableCode]) -- ^ defined by 'defCallable' + , objDereferencer :: Maybe (typ -> Exec (Maybe Object)) + , objMethodTable :: M.Map Name (DaoFunc typ) + } + deriving Typeable + +instance Eq (Interface typ) where { a==b = objHaskellType a == objHaskellType b } + +instance Ord (Interface typ) where { compare a b = compare (objHaskellType a) (objHaskellType b) } + +-- | This function works a bit like 'Data.Functor.fmap', but maps an 'Interface' from one type +-- to another. This requires two functions: one that can cast from the given type to the adapted +-- type (to convert outputs of functions), and one that can cast back from the adapted type to the +-- original type (to convert inputs of functions). Each coversion function takes a string as it's +-- first parameter, this is a string containing the name of the function that is currently making +-- use of the conversion operation. Should you need to use 'Prelude.error' or 'newError', this +-- string will allow you to throw more informative error messages. WARNING: this function leaves +-- 'objHaskellType' unchanged because the original type value should usually be preserved. +interfaceAdapter + :: (Typeable typ_a, Typeable typ_b) + => (String -> typ_a -> typ_b) + -> (String -> typ_b -> typ_a) + -> Interface typ_a + -> Interface typ_b +interfaceAdapter a2b b2a ifc = + ifc + { objCastFrom = let n="objCastFrom" in fmap (fmap (a2b n)) (objCastFrom ifc) + , objEquality = let n="objEquality" in fmap (\eq a b -> eq (b2a n a) (b2a n b)) (objEquality ifc) + , objOrdering = let n="objOrdering" in fmap (\ord a b -> ord (b2a n a) (b2a n b)) (objOrdering ifc) + , objBinaryFormat = let n="objBinaryFormat" in fmap (\ (toBin , fromBin) -> (toBin . b2a n, fmap (a2b n) fromBin)) (objBinaryFormat ifc) + , objNullTest = let n="objNullTest" in fmap (\null b -> null (b2a n b)) (objNullTest ifc) + , objPPrinter = let n="objPPrinter" in fmap (\eval -> eval . b2a n) (objPPrinter ifc) + , objReadIterable = let n="objReadIterable" in fmap (\for t -> for (b2a n t)) (objReadIterable ifc) + , objUpdateIterable = let n="objUpdateIterable" in fmap (\for t -> fmap (a2b n) . for (b2a n t)) (objUpdateIterable ifc) + , objIndexer = let n="objIndexer" in fmap (\f i -> f (b2a n i)) (objIndexer ifc) + , objIndexUpdater = let n="objIndexUpdater" in fmap (\upd i f -> convertFocus (a2b n) (b2a n) (upd i f)) (objIndexUpdater ifc) + , objSizer = let n="objSizer" in fmap (\f o -> f (b2a n o)) (objSizer ifc) + , objToStruct = let n="objToStruct" in fmap (fmapHaskDataToStruct (a2b n) (b2a n)) (objToStruct ifc) + , objFromStruct = let n="objFromStruct" in fmap (fmap (a2b n)) (objFromStruct ifc) + , objInitializer = let n="objInitializer" in fmap (\ (init, eval) -> (\ox -> fmap (a2b n) (init ox), \typ ox -> fmap (a2b n) (eval (b2a n typ) ox))) (objInitializer ifc) + , objTraverse = let n="objTraverse" in fmap (\focus f -> convertFocus (a2b n) (b2a n) (focus f)) (objTraverse ifc) + , objInfixOpTable = let n="objInfixOpTable" in fmap (fmap (fmap (\infx op b -> infx op (b2a n b)))) (objInfixOpTable ifc) + , objArithPfxOpTable = let n="objPrefixOpTable" in fmap (fmap (fmap (\prfx op b -> prfx op (b2a n b)))) (objArithPfxOpTable ifc) + , objMethodTable = let n="objMethodTable" in fmap (\func -> func{ daoForeignFunc = \t -> fmap (fmap (a2b n)) . daoForeignFunc func (b2a n t) }) (objMethodTable ifc) + , objCallable = let n="objCallable" in fmap (\eval -> eval . b2a n) (objCallable ifc) + , objDereferencer = let n="objDerferencer" in fmap (\eval -> eval . b2a n) (objDereferencer ifc) + } + +interfaceToDynamic :: Typeable typ => Interface typ -> Interface Dynamic +interfaceToDynamic oi = interfaceAdapter (\ _ -> toDyn) (from oi) oi where + from :: Typeable typ => Interface typ -> String -> Dynamic -> typ + from oi msg dyn = fromDyn dyn (dynErr oi msg dyn) + dynErr :: Typeable typ => Interface typ -> String -> Dynamic -> typ + dynErr oi msg dyn = error $ concat $ + [ "The '", msg + , "' function defined for objects of type ", show (objHaskellType oi) + , " was evaluated on an object of type ", show (dynTypeRep dyn) + ] + +-- Used to construct an 'Interface' in a "Control.Monad.State"-ful way. Instantiates +-- 'Data.Monoid.Monoid' to provide 'Data.Monoid.mempty' an allows multiple inheritence by use of the +-- 'Data.Monoid.mappend' function in the same way as +data HDIfcBuilder typ = + HDIfcBuilder + { objIfcHaskellType :: TypeRep + , objIfcCastFrom :: Maybe (Object -> typ) + , objIfcEquality :: Maybe (typ -> typ -> Bool) + , objIfcOrdering :: Maybe (typ -> typ -> Ordering) + , objIfcBinaryFormat :: Maybe (typ -> Put, Get typ) + , objIfcNullTest :: Maybe (typ -> Bool) + , objIfcPPrinter :: Maybe (typ -> PPrint) + , objIfcReadIterable :: Maybe (typ -> (Object -> Exec ()) -> Exec ()) + , objIfcUpdateIterable :: Maybe (typ -> (Maybe Object -> Exec (Maybe Object)) -> Exec typ) + , objIfcIndexer :: Maybe (typ -> [Object] -> Exec Object) + , objIfcIndexUpdater :: Maybe (ObjectUpdate typ [Object]) + , objIfcSizer :: Maybe (typ -> Exec Object) + , objIfcToStruct :: Maybe (ToDaoStruct typ ()) + , objIfcFromStruct :: Maybe (FromDaoStruct typ) + , objIfcInitializer :: Maybe ([Object] -> Exec typ, typ -> [InitItem] -> Exec typ) + , objIfcTraverse :: Maybe (ObjectTraverse typ [Object]) + , objIfcInfixOpTable :: [(InfixOp , InfixOp -> typ -> Object -> XPure Object)] + , objIfcPrefixOpTable :: [(ArithPfxOp, ArithPfxOp -> typ -> XPure Object)] + , objIfcMethodTable :: M.Map Name (DaoFunc typ) + , objIfcCallable :: Maybe (typ -> Exec [CallableCode]) + , objIfcDerefer :: Maybe (typ -> Exec (Maybe Object)) + } + +initHDIfcBuilder :: TypeRep -> HDIfcBuilder typ +initHDIfcBuilder typ = + HDIfcBuilder + { objIfcHaskellType = typ + , objIfcCastFrom = Nothing + , objIfcEquality = Nothing + , objIfcOrdering = Nothing + , objIfcBinaryFormat = Nothing + , objIfcNullTest = Nothing + , objIfcPPrinter = Nothing + , objIfcReadIterable = Nothing + , objIfcUpdateIterable = Nothing + , objIfcIndexer = Nothing + , objIfcIndexUpdater = Nothing + , objIfcSizer = Nothing + , objIfcToStruct = Nothing + , objIfcFromStruct = Nothing + , objIfcInitializer = Nothing + , objIfcTraverse = Nothing + , objIfcInfixOpTable = [] + , objIfcPrefixOpTable = [] + , objIfcMethodTable = mempty + , objIfcCallable = Nothing + , objIfcDerefer = Nothing + } + +-- | A handy monadic interface for defining an 'Interface' using nice, clean procedural +-- syntax. +type DaoClassDef typ = DaoClassDefM typ () +newtype DaoClassDefM typ a = DaoClassDefM { daoClassDefState :: State (HDIfcBuilder typ) a } +instance Typeable typ => Functor (DaoClassDefM typ) where + fmap f (DaoClassDefM m) = DaoClassDefM (fmap f m) +instance Typeable typ => Monad (DaoClassDefM typ) where + return = DaoClassDefM . return + (DaoClassDefM m) >>= f = DaoClassDefM (m >>= daoClassDefState . f) +instance Typeable typ => Applicative (DaoClassDefM typ) where { pure=return; (<*>)=ap; } + +_updHDIfcBuilder :: Typeable typ => (HDIfcBuilder typ -> HDIfcBuilder typ) -> DaoClassDefM typ () +_updHDIfcBuilder = DaoClassDefM . modify + +-- | The callback function defined here is used when objects of your @typ@ can be constructed from +-- some other 'Object'. This function is used to convert an 'Object' of another types to an data +-- type of your @typ@ when it is necessary to do so (for example, evaluating the @==@ or @!=@ +-- operator). +defCastFrom :: Typeable typ => (Object -> typ) -> DaoClassDefM typ () +defCastFrom fn = _updHDIfcBuilder(\st->st{objIfcCastFrom=Just fn}) + +-- | The callback function defined here is used where objects of your @typ@ might be compared to +-- other objects using the @==@ and @!=@ operators in Dao programs. However using this is slightly +-- different than simply overriding the @==@ or @!=@ operators. Defining an equality reliation with +-- this function also allows Haskell language programs to compare your object to other objects +-- without unwrapping them from the 'Object' wrapper. +-- +-- This function automatically define an equality operation over your @typ@ using the +-- instantiation of 'Prelude.Eq' and the function you have provided to the 'defCastFrom' function. +-- The 'defCastFrom' function is used to cast 'Object's to a value of your @typ@, and then the +-- @Prelude.==@ function is evaluated. If you eventually never define a type casting funcion using +-- 'defCastFrom', this function will fail, but it will fail lazily and at runtime, perhaps when you +-- least expect it, so be sure to define 'defCastFrom' at some point. +autoDefEquality :: (Typeable typ, Eq typ) => DaoClassDefM typ () +autoDefEquality = defEquality (==) + +-- | The callback function defined here is used where objects of your @typ@ might be compared to +-- other objects using the @==@ and @!=@ operators in Dao programs. However using this is slightly +-- different than simply overriding the @==@ or @!=@ operators. Defining an equality relation with +-- this function also allows Haskell language programs to compare your object to other objects +-- without unwrapping them from the 'Object' wrapper. +-- +-- This function differs from 'autoDefEquality' because you must provide a customized equality +-- relation for your @typ@, if the 'autoDefEquality' and 'defCastFrom' functions are to be avoided +-- for some reason. +defEquality :: (Typeable typ, Eq typ) => (typ -> typ -> Bool) -> DaoClassDefM typ () +defEquality fn = _updHDIfcBuilder(\st->st{objIfcEquality=Just fn}) + +-- | The callback function defined here is used where objects of your @typ@ might be compared to +-- other objects using the @<@, @>@, @<=@, and @>=@ operators in Dao programs. However using this is +-- slightly different than simply overriding the @<@, @>@, @<=@, or @>=@ operators. Defining an +-- equality relation with this function also allows Haskell language programs to compare your obejct +-- to other objects without unwrapping them from the 'Object' wrapper. +-- +-- Automatically define an ordering for your @typ@ using the instantiation of +-- 'Prelude.Eq' and the function you have provided to the 'defCastFrom' function. The 'defCastFrom' +-- function is used to cast 'Object's to a value of your @typ@, and then the @Prelude.==@ function +-- is evaluated. If you eventually never define a type casting funcion using 'defCastFrom', this +-- function will fail, but it will fail lazily and at runtime, perhaps when you least expect it, so +-- be sure to define 'defCastFrom' at some point. +autoDefOrdering :: (Typeable typ, Ord typ) => DaoClassDefM typ () +autoDefOrdering = defOrdering compare + +-- | The callback function defined here is used where objects of your @typ@ might be compared to +-- other objects using the @<@, @>@, @<=@, and @>=@ operators in Dao programs. However using this is +-- slightly different than simply overriding the @<@, @>@, @<=@, or @>=@ operators. Defining an +-- equality relation with this function also allows Haskell language programs to compare your obejct +-- to other objects without unwrapping them from the 'Object' wrapper. +-- +-- Define a customized ordering for your @typ@, if the 'autoDefEquality' and 'defCastFrom' +-- functions are to be avoided for some reason. +defOrdering :: (Typeable typ) => (typ -> typ -> Ordering) -> DaoClassDefM typ () +defOrdering fn = _updHDIfcBuilder(\st->st{objIfcOrdering=Just fn}) + +-- | The callback function defined here is used if an object of your @typ@ should ever need to be +-- stored into a binary file in persistent storage (like your filesystem) or sent across a channel +-- (like a UNIX pipe or a socket). +-- +-- It automatically define the binary encoder and decoder using the 'Data.Binary.Binary' class +-- instantiation for this @typ@. +autoDefBinaryFmt :: (Typeable typ, B.Binary typ MethodTable) => DaoClassDefM typ () +autoDefBinaryFmt = defBinaryFmt B.put B.get + +-- | This function is used if an object of your @typ@ should ever need to be stored into a binary +-- file in persistent storage (like your filesystem) or sent across a channel (like a UNIX pipe or a +-- socket). +-- +-- If you have binary coding and decoding methods for your @typ@ but for some silly reason not +-- instantiated your @typ@ into the 'Data.Binary.Binary' class, your @typ@ can still be used as a +-- binary formatted object by the Dao system if you define the encoder and decoder using this +-- function. However, it would be better if you instantiated 'Data.Binary.Binary' and used +-- 'autoDefBinaryFmt' instead. +defBinaryFmt :: (Typeable typ) => (typ -> Put) -> Get typ -> DaoClassDefM typ () +defBinaryFmt put get = _updHDIfcBuilder(\st->st{objIfcBinaryFormat=Just(put,get)}) + +autoDefNullTest :: (Typeable typ, HasNullValue typ) => DaoClassDefM typ () +autoDefNullTest = defNullTest testNull + +-- | The callback function defined here is used if an object of your @typ@ is ever used in an @if@ +-- or @while@ statement in a Dao program. This function will return @Prelude.True@ if the object is +-- of a null value, which will cause the @if@ or @while@ test to fail and execution of the Dao +-- program will branch accordingly. There is no default method for this function so it must be +-- defined by this function, otherwise your object cannot be tested by @if@ or @while@ statements. +defNullTest :: Typeable typ => (typ -> Bool) -> DaoClassDefM typ () +defNullTest fn = _updHDIfcBuilder(\st->st{objIfcNullTest=Just fn}) + +-- | The callback function to be called when the "print" built-in function is used. +defPPrinter :: Typeable typ => (typ -> PPrint) -> DaoClassDefM typ () +defPPrinter fn = _updHDIfcBuilder(\st->st{objIfcPPrinter=Just fn}) + +-- | The callback function to be called when the "print" built-in function is used. +autoDefPPrinter :: (Typeable typ, PPrintable typ) => DaoClassDefM typ () +autoDefPPrinter = defPPrinter pPrint + +-- | The callback function defined here is used if an object of your @typ@ is ever used in a @for@ +-- statement in a Dao program. However it is much better to instantiate your @typ@ into the +-- 'ReadIterable' class and use 'autoDefIterator' instead. If 'defUpdateIterator' is also defined, +-- the function defined here will never be used. +-- +-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly +-- handle "break" and "catch" statements. +defReadIterable :: Typeable typ => (typ -> (Object -> Exec ()) -> Exec ()) -> DaoClassDefM typ () +defReadIterable iter = _updHDIfcBuilder $ \st -> st{ objIfcReadIterable=Just iter } + +-- | Define 'defReadIterable' automatically using the instance of @typ@ in the 'ReadIterable' class. +-- +-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly +-- handle "break" and "catch" statements. +autoDefReadIterable :: (Typeable typ, ReadIterable typ Object) => DaoClassDefM typ () +autoDefReadIterable = defReadIterable readForLoop + +-- | The callback function defined here is used if an object of your @typ@ is ever used in a @for@ +-- statement in a Dao program. However it is much better to instantiate your @typ@ into the +-- 'UpdateIterable' class and use 'autoDefIterator' instead. If 'defReadIterator' is also defined, +-- the read iterator is always ignored in favor of this function. +-- +-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly +-- handle "break" and "catch" statements. +defUpdateIterable :: Typeable typ => (typ -> (Maybe Object -> Exec (Maybe Object)) -> Exec typ) -> DaoClassDefM typ () +defUpdateIterable iter = _updHDIfcBuilder(\st->st{objIfcUpdateIterable=Just iter}) + +-- | Define 'defUpdateIterable' automatically using the instance of @typ@ in the 'ReadIterable' +-- class. +-- +-- /NOTE:/ When defining iterators, it is important to use 'execForM' or 'execForM_' to properly +-- handle "break" and "catch" statements. +autoDefUpdateIterable :: (Typeable typ, UpdateIterable typ (Maybe Object)) => DaoClassDefM typ () +autoDefUpdateIterable = defUpdateIterable updateForLoop + +-- | The callback function defined here is used at any point in a Dao program where an expression +-- containing your object typ is subscripted with square brackets, for example in the statement: +-- @x = t[0][A][B];@ The object passed to your callback function is the object containing the +-- subscript value. So in the above example, if the local variable @t@ is a value of +-- your @typ@, this callback function will be evaluated three times: +-- 1. with the given 'Object' parameter being @('OInt' 0)@ and the @typ@ parameter as the value +-- stored in the local variable @y@. +-- 2. once with the 'Object' parameter being the result of dereferencing the local varaible @A@ and +-- the @typ@ parameter as the value stored in the local variable @y@. +-- 3. once the given 'Object' parameter being the result of dereferencing the local variable @B@ and +-- the @typ@ parameter as the value stored in the local variable @y@. +-- +-- Statements like this: +-- > ... = a[0,1,2] +-- access a single multi-dimensional index, in this case 3-dimensions with the tuple [0,1,2]. +-- > ... = a[0][1][2] +-- accesses a sequence of single-dimensional elements, each element being accessed by the next +-- snigle-dimensional index in the sequence. Although this is one method of programming +-- multi-dimensional data types, it is evaluated differently than an index expressed as a tuple. +defIndexer :: Typeable typ => (typ -> [Object] -> Exec Object) -> DaoClassDefM typ () +defIndexer fn = _updHDIfcBuilder(\st->st{objIfcIndexer=Just fn}) + +-- | The callback function defined here is used at any point in a Dao program where an expression +-- containing your object typ is subscripted with square brackets on the left-hand side of an +-- assignment expression: +-- @x[0][A][B] = t;@ +-- This function must take the original object of your @typ@ and return the updated object along +-- with the value used to updated it. The object passed to your callback function is the object +-- containing the subscript value. So in the above example, if the local variables @x@ is a value of +-- your @typ@, this callback function will be evaluated three times: +-- 1. with the given 'Object' parameter being @('OInt' 0)@ and the @typ@ parameter as the value +-- stored in the local variable @y@. +-- 2. once with the 'Object' parameter being the result of dereferencing the local varaible @A@ and +-- the @typ@ parameter as the value stored in the local variable @y@. +-- 3. once the given 'Object' parameter being the result of dereferencing the local variable @B@ and +-- the @typ@ parameter as the value stored in the local variable @y@. +-- +-- Statements like this: +-- > a[0,1,2] = ... +-- access a single multi-dimensional index, in this case 3-dimensions with the tuple [0,1,2]. +-- > a[0][1][2] = ... +-- accesses a sequence of single-dimensional elements, each element being accessed by the next +-- snigle-dimensional index in the sequence. Although this is one method of programming +-- multi-dimensional data types, it is evaluated differently than an index expressed as a tuple. +defIndexUpdater :: Typeable typ => ObjectUpdate typ [Object] -> DaoClassDefM typ () +defIndexUpdater fn = _updHDIfcBuilder(\st->st{ objIfcIndexUpdater=Just fn }) + +-- | Define a function used by the built-in "size()" function to return an value indicating the size +-- of your @typ@ object. +defSizer :: Typeable typ => (typ -> Exec Object) -> DaoClassDefM typ () +defSizer fn = _updHDIfcBuilder(\st->st{objIfcSizer=Just fn}) + +autoDefSizeable :: (Typeable typ, Sizeable typ) => DaoClassDefM typ () +autoDefSizeable = defSizer getSizeOf + +-- | Use your data type's instantiation of 'ToDaoStructClass' to call 'defToStruct'. +autoDefToStruct :: forall typ . (Typeable typ, ToDaoStructClass typ) => DaoClassDefM typ () +autoDefToStruct = defToStruct toDaoStruct + +-- | When a label referencing your object has a field record accessed, for example: +-- > c = a.b; +-- if your object is referenced by @a@ and the script expression wants to access a record called @b@ +-- from within it, then function defined here will be used. +defToStruct :: Typeable typ => ToDaoStruct typ () -> DaoClassDefM typ () +defToStruct encode = _updHDIfcBuilder (\st -> st{ objIfcToStruct=Just encode }) + +-- | When a label referencing your object has a field record updated, for example: +-- > a.b = c; +-- if your object is referenced by @a@ and the script expression wants to update a record called @b@ +-- within it by assigning it the value referenced by @c@, then the function defined here will be +-- used. +autoDefFromStruct :: (Typeable typ, FromDaoStructClass typ) => DaoClassDefM typ () +autoDefFromStruct = defFromStruct fromDaoStruct + +-- | If for some reason you need to define a tree encoder and decoder for the 'Interface' of your +-- @typ@ without instnatiating 'ToDaoStructClass' or 'FromDaoStructClass', use +-- this function to define the tree encoder an decoder directly +defFromStruct :: Typeable typ => FromDaoStruct typ -> DaoClassDefM typ () +defFromStruct decode = _updHDIfcBuilder (\st -> st{ objIfcFromStruct=Just decode }) + +-- | The callback defined here is used when a Dao program makes use of the static initialization +-- syntax of the Dao programming language, which are expression of this form: +-- > a = MyType { paramA=initA, paramB=initB, .... }; +-- > a = MyType(param1, param2, ...., paramN) { paramA=initA, paramB=initB, .... }; +-- When the interpreter sees this form of expression, it looks up the 'Interface' for your +-- @typ@ and checks if a callback has been defined by 'defDictInit'. If so, then the callback is +-- evaluated with a list of object values passed as the first parameter which contain the object +-- values written in the parentheses, and a list of 'InitItem's as the second parameter containing +-- the contents of the curly-brackets. +defInitializer :: Typeable typ => ([Object] -> Exec typ) -> (typ -> [InitItem] -> Exec typ) -> DaoClassDefM typ () +defInitializer fa fb = _updHDIfcBuilder(\st->st{objIfcInitializer=Just (fa, fb)}) + +-- | Data structures in the Dao programming language can be traversed if you provide a function that +-- can update every 'Object' contained wihtin the data structure. +defTraverse :: Typeable typ => (([Object] -> Object -> ObjectFocus [([Object], Object)] ()) -> ObjectFocus typ ()) -> DaoClassDefM typ () +defTraverse f = _updHDIfcBuilder(\st->st{objIfcTraverse=Just f}) + +-- | Define the 'defTraverse' function using the instance of 'objectFMap' for your @typ@ in the +-- @('ObjectFunctor' ['Object'] typ)@ class. +autoDefTraverse :: (Typeable typ, ObjectFunctor typ [Object]) => DaoClassDefM typ () +autoDefTraverse = defTraverse objectFMap + +-- | Overload infix operators in the Dao programming language, for example @+@, @*@, or @<<@. +-- +-- Like with C++, the operator prescedence and associativity is permanently defined by the parser +-- and cannot be changed by the overloading mechanism. You can only change how the operator behaves +-- based on the type of it's left and right hand parameters. +-- +-- If you define two callbacks for the same 'UpdateOp', this will result in a runtime error, +-- hopefully the error will occur during the Dao runtime's object loading phase, and not while +-- actually executing a program. +defInfixOp :: Typeable typ => InfixOp -> (InfixOp -> typ -> Object -> XPure Object) -> DaoClassDefM typ () +defInfixOp op fn = _updHDIfcBuilder $ \st -> st{objIfcInfixOpTable = objIfcInfixOpTable st ++ [(op, fn)] } + +-- | Overload prefix operators in the Dao programming language, for example @!@, @~@, @-@, and @+@. +-- +-- Like with C++, the operator prescedence and associativity is permanently defined by the parser +-- and cannot be changed by the overloading mechanism. You can only change how the operator behaves +-- based on the type of it's left and right hand parameters. +-- +-- If you define two callbacks for the same 'UpdateOp', this will result in a runtime error, +-- hopefully the error will occur during the Dao runtime's object loading phase, and not while +-- actually executing a program. +defPrefixOp :: Typeable typ => ArithPfxOp -> (ArithPfxOp -> typ -> XPure Object) -> DaoClassDefM typ () +defPrefixOp op fn = _updHDIfcBuilder $ \st -> st{objIfcPrefixOpTable = objIfcPrefixOpTable st ++ [(op, fn)] } + +defCallable :: Typeable typ => (typ -> Exec [CallableCode]) -> DaoClassDefM typ () +defCallable fn = _updHDIfcBuilder (\st -> st{objIfcCallable=Just fn}) + +defDeref :: Typeable typ => (typ -> Exec (Maybe Object)) -> DaoClassDefM typ () +defDeref fn = _updHDIfcBuilder (\st -> st{objIfcDerefer=Just fn}) + +defMethod :: (UStrType name, Typeable typ) => name -> DaoFunc typ -> DaoClassDefM typ () +defMethod inname infn = do + let name = fromUStr $ toUStr inname + let fn = infn{ daoFuncName=name } + let dupname st _ = error $ concat $ + [ "Internal error: duplicate method name \"", show name + , "\" for data type ", show (objIfcHaskellType st) + ] + _updHDIfcBuilder $ \st -> + st{ objIfcMethodTable = M.alter (maybe (Just fn) (dupname st)) name $ objIfcMethodTable st } + +-- | Like 'detMethod' but creates a function that takes no parameters. +defMethod0 :: (UStrType name, Typeable this) => name -> (this -> Exec (Maybe Object, this)) -> DaoClassDefM this () +defMethod0 name f = defMethod name $ + daoFunc + { funcAutoDerefParams = False + , daoForeignFunc = \this ox -> case ox of + [] -> f this + ox -> throwArityError "" 0 ox [(errInFunc, obj $ reference UNQUAL (fromUStr $ toUStr name))] + } + +-- | Rocket. Yeah. Sail away with you. +defLeppard :: Typeable typ => rocket -> yeah -> DaoClassDefM typ () +defLeppard _ _ = return () + +-- | This is the Dao 'Object' interface to the Haskell language. Every function in this data type +-- allows you to customize the behavior of the Dao evaluator for a particular Haskell data type +-- @typ@. In order for your type to be useful, it must be possible to pass your data type to the +-- 'OHaskell' constructor, which requires a data type of 'Data.Dynamic.Dynamic', which means your +-- @typ@ must derive a class instance for 'Data.Typeable.Typeable'. The first parameter of type +-- @typ@ is not used except to retrieve it's 'Data.Typeable.TypeRep' using the +-- 'Data.Typealble.typeOf' function, it is safe to pass any data constructor with all of it's fields +-- 'Prelude.undefined', just the constructor itself must not be 'Prelude.undefined'. +-- +-- The @'DaoClassDefM'@ parameter you pass to this function is a monadic function so you can simply +-- declare the functionality you would like to include in this object one line at a time using +-- the procedural coding style. Each line in the "procedure" will be one of the @def*@ functions, +-- for example 'autoDefEquality' or 'autoDefOrdering'. +interface :: (UStrType name, Typeable typ) => name -> DaoClassDefM typ ig -> Interface typ +interface nm defIfc = let name = toUStr nm in case maybeFromUStr name of + Nothing -> error $ + "Failed to install built-in data type interface, invalid type name provided: "++uchars nm + Just name -> + Interface + { objHaskellType = typ + , objInterfaceName = name + , objCastFrom = objIfcCastFrom ifc + , objEquality = objIfcEquality ifc + , objOrdering = objIfcOrdering ifc + , objBinaryFormat = objIfcBinaryFormat ifc + , objNullTest = objIfcNullTest ifc + , objPPrinter = objIfcPPrinter ifc + , objReadIterable = objIfcReadIterable ifc + , objUpdateIterable = objIfcUpdateIterable ifc + , objIndexer = objIfcIndexer ifc + , objIndexUpdater = objIfcIndexUpdater ifc + , objSizer = objIfcSizer ifc + , objToStruct = objIfcToStruct ifc + , objFromStruct = objIfcFromStruct ifc + , objInitializer = objIfcInitializer ifc + , objTraverse = objIfcTraverse ifc + , objCallable = objIfcCallable ifc + , objDereferencer = objIfcDerefer ifc + , objInfixOpTable = mkArray "defInfixOp" $ objIfcInfixOpTable ifc + , objArithPfxOpTable = mkArray "defPrefixOp" $ objIfcPrefixOpTable ifc + , objMethodTable = objIfcMethodTable ifc + } + where + mktyp :: Typeable typ => DaoClassDefM typ ig -> typ -> TypeRep + mktyp _ undefd = typeOf undefd + typ = mktyp defIfc $ + error "'Dao.Interpreter.interface' evaluated 'Data.Typeable.typeOf' on undefined value" + ifc = execState (daoClassDefState defIfc) (initHDIfcBuilder typ) + mkArray oiName elems = + minAccumArray (onlyOnce oiName) Nothing $ map (\ (i, e) -> (i, (i, Just e))) elems + onlyOnce oiName a (i, b) = case a of + Nothing -> b + Just _ -> conflict oiName ("the "++show i++" operator") + conflict oiName funcName = error $ concat $ + [ "'", oiName + , "' has conflicting functions for ", funcName + , " for the 'HataClass' instantiation of the '", show typ + , "' Haskell data type." + ] + diff --git a/src/Dao/Interpreter/AST.hs b/src/Dao/Interpreter/AST.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Interpreter/AST.hs @@ -0,0 +1,3135 @@ +-- "src/Dao/Interpreter/AST.hs" defines the data types for the Dao +-- programming language abstract syntax tree and related type classes. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +module Dao.Interpreter.AST + ( Intermediate(toInterm, fromInterm), Canonical(canonicalize), + Comment(InlineComment, EndlineComment), + Com(Com, ComBefore, ComAfter, ComAround), + NamespaceExpr(NamespaceExpr), AST_Namespace(AST_NoNamespace, AST_Namespace), + setCommentBefore, setCommentAfter, unComment, getComment, + pPrintInterm, putAST, getAST, commentString, pPrintComWith, + pListOfComsWith, pListOfComs, randComWith, appendComments, com, + DotNameExpr(DotNameExpr), AST_DotName(AST_DotName), getDotNameAST, undotNameExpr, + DotLabelExpr(DotLabelExpr), AST_DotLabel(AST_DotLabel), + dotLabelToNameList, dotLabelToRefExpr, refToDotLabelExpr, dotLabelToRefAST, refToDotLabelAST, + RefSuffixExpr(NullRefExpr, DotRefExpr, SubscriptExpr, FuncCallExpr), + ReferenceExpr(ReferenceExpr, RefObjectExpr), + RefPfxOp(REF, DEREF), + RefQualifier(UNQUAL, LOCAL, CONST, STATIC, GLOBAL, GLODOT), + UpdateOp(UCONST, UADD, USUB, UMULT, UDIV, UMOD, UPOW, UORB, UANDB, UXORB, USHL, USHR), + ArithPfxOp(INVB, NOT, NEGTIV, POSTIV), + InfixOp( + ADD, SUB, MULT, DIV, MOD, POW, ORB, ANDB, XORB, SHL, SHR, OR, AND, + EQUL, NEQUL, GTN, LTN, GTEQ, LTEQ, ARROW + ), infixOpCommutativity, + allUpdateOpStrs, allPrefixOpChars, allPrefixOpStrs, allInfixOpChars, allInfixOpStrs, + AST_RefSuffix(AST_RefNull, AST_DotRef, AST_Subscript, AST_FuncCall), + AST_Reference(AST_Reference, AST_RefObject), + ObjListExpr(ObjListExpr), AST_ObjList(AST_ObjList), + OptObjListExpr(OptObjListExpr), AST_OptObjList(AST_OptObjList), + LiteralExpr(LiteralExpr), AST_Literal(AST_Literal), + ParenExpr(ParenExpr), AST_Paren(AST_Paren), + AssignExpr(EvalExpr, AssignExpr), AST_Assign(AST_Eval, AST_Assign), + ObjTestExpr(ObjArithExpr, ObjTestExpr, ObjRuleFuncExpr), + AST_ObjTest(AST_ObjArith, AST_ObjTest, AST_ObjRuleFunc), + ArithExpr(ObjectExpr, ArithExpr), AST_Arith(AST_Object, AST_Arith), + RuleFuncExpr(LambdaExpr, FuncExpr, RuleExpr), AST_RuleFunc(AST_Lambda, AST_Func, AST_Rule), + TyChkExpr(NotTypeChecked, TypeChecked, DisableCheck), fmapCheckedValueExpr, + tyChkItem, tyChkExpr, tyChkLoc, typChkResult, checkedExpr, + AST_TyChk(AST_NotChecked, AST_Checked), checkedAST, fmapCheckedValueAST, + ParamExpr(ParamExpr), AST_Param(AST_NoParams, AST_Param), + ParamListExpr(ParamListExpr), getTypeCheckList, + AST_ParamList(AST_ParamList), + RuleHeadExpr(RuleStringExpr, RuleHeadExpr), + AST_RuleHeader(AST_NullRules, AST_RuleString, AST_RuleHeader), + CodeBlock(CodeBlock), codeBlock, + AST_CodeBlock(AST_CodeBlock), getAST_CodeBlock, + RefPrefixExpr(PlainRefExpr, RefPrefixExpr), cleanupRefPrefixExpr, + AST_RefPrefix(AST_RefPrefix, AST_PlainRef), + ObjectExpr( + VoidExpr, ObjLiteralExpr, ObjSingleExpr, + ArithPfxExpr, InitExpr, StructExpr, MetaEvalExpr + ), + AST_Object( + AST_Void, AST_ObjLiteral, AST_ObjSingle, + AST_ArithPfx, AST_Init, AST_Struct, AST_MetaEval + ), + ScriptExpr( + IfThenElse, WhileLoop, RuleFuncExpr, EvalObject, + TryCatch, ForLoop, ContinueExpr, ReturnExpr, WithDoc + ), + IfExpr(IfExpr), AST_If(AST_If), + ElseExpr(ElseExpr), AST_Else(AST_Else), + IfElseExpr(IfElseExpr), AST_IfElse(AST_IfElse), + LastElseExpr(LastElseExpr), AST_LastElse(AST_LastElse), + CatchExpr(CatchExpr), AST_Catch(AST_Catch), + WhileExpr(WhileExpr), AST_While(AST_While), + AST_Script( + AST_Comment, AST_IfThenElse, AST_WhileLoop, AST_RuleFunc, AST_EvalObject, + AST_TryCatch, AST_ForLoop, AST_ContinueExpr, AST_ReturnExpr, AST_WithDoc + ), + TopLevelEventType(BeginExprType, EndExprType, ExitExprType), + TopLevelExpr(RequireExpr, ImportExpr, TopScript, EventExpr), isAttribute, + AST_TopLevel(AST_Require, AST_Import, AST_TopScript, AST_Event, AST_TopComment), + isAST_Attribute, getRequiresAndImports, + AttributeExpr(AttribDotNameExpr, AttribStringExpr), + AST_Attribute(AST_AttribDotName, AST_AttribString), + Program(Program), topLevelExprs, + AST_SourceCode(AST_SourceCode), sourceModified, sourceFullPath, directives, + ) + where + +import qualified Dao.Binary as B +import Dao.String +import Dao.PPrint +import Dao.Random +import Dao.Token + +import Data.Array.IArray +import Data.List (intersperse) +import Data.Monoid +import Data.Typeable +import Data.Word + +import Control.Applicative +import Control.DeepSeq +import Control.Monad + +---------------------------------------------------------------------------------------------------- + +-- | Elements of the symantic data structures that instantiate 'Executable' and do not instantiate +-- 'Dao.PPrint.PPrintable', 'Dao.Struct.Structured', or any parsers. Elements of the abstract syntax +-- tree (AST) instantiate 'Dao.PPrint.PPrintable', 'Dao.Struct.Structured', and all of the parsers, +-- but are not executable and do not instantiate 'Executable'. This separates concerns pretty well, +-- but leaves us with the problem of having to convert back and forth between these various data +-- types. +-- +-- The 'Intermediate' class allows us to declare a one-to-one relationship between AST types and +-- executable types. For example, 'ObjectExpr' is the intermediate representation of +-- 'AST_Object', so our instance for this relationship is @instane 'Intermediate' +-- 'ObjectExpr' 'AST_Object'@. +class Intermediate obj ast | obj -> ast, ast -> obj where + toInterm :: ast -> [obj] + fromInterm :: obj -> [ast] + +-- | This class is used to classify data types that can be generated at random by +-- 'Dao.Random.HasRandGen' and parsed from source code, which might generate data types with +-- identical functionality, identical pretty-printed forms, identical 'Executable' semantics but may +-- have differences in the recursive structure that the 'Prelude.Eq' class would compute as not +-- identical. The job of the 'canonicalize' function is to eliminate these discrepancies by reducing +-- the data structure to a canonical form. +class Canonical a where { canonicalize :: a -> a } + +instance Intermediate Name Name where { toInterm = return; fromInterm = return; } + +-- Not for export: here are a bunch of shortcuts to converting the AST to the intermediate data +-- type. Sinec 'toInterm' returns a single item in a list to indicate success and an empty list to +-- indicate failure, all of these items have their evaluated type wrapped in a list type. This is to +-- allow the 'toInterm' instances use the 'Control.Monad.liftM' family of functions. +ti :: Intermediate obj ast => ast -> [obj] +ti = toInterm +uc :: Com a -> [a] +uc = return . unComment +uc0 :: Intermediate obj ast => Com ast -> [obj] +uc0 = toInterm . unComment +um1 :: Intermediate obj ast => Maybe ast -> [Maybe obj] +um1 = maybe [Nothing] (fmap Just . toInterm) + +fi :: Intermediate obj ast => obj -> [ast] +fi = fromInterm +nc :: a -> [Com a] +nc = return . Com +nc0 :: Intermediate obj ast => obj -> [Com ast] +nc0 = fmap Com . fromInterm +nm1 :: Intermediate obj ast => Maybe obj -> [Maybe ast] +nm1 = maybe [Nothing] (fmap Just . fromInterm) + +-- not for export +no :: RandO Location +no = return LocationUnknown + +-- | If there is a type that instantiates 'Intermediate', it can be converted to and from a type +-- that is pretty-printable ('Dao.PPrint.PPrintable'). +pPrintInterm :: (Intermediate o ast, PPrintable ast) => o -> PPrint +pPrintInterm = mapM_ pPrint . fromInterm + +-- | If there is a type that instantiates 'Intermediate', it can be converted to and from a type +-- that is 'Dao.Binary.GPut'. +putAST :: (Intermediate obj ast, B.Binary obj mtab) => ast -> B.GPut mtab +putAST ast = case toInterm ast of + [obj] -> B.put obj + _ -> fail "binary encoder could not convert AST to intermediate expression" + +-- | If there is a type that instantiates 'Intermediate', it can be converted to and from a type +-- that is 'Dao.Binary.GGet'. +getAST :: (Intermediate obj ast, B.Binary obj mtab) => B.GGet mtab ast +getAST = B.get >>= \obj -> case fromInterm obj of + [ast] -> return ast + _ -> fail "binary decoder constructed object that could not be converted to an AST representation" + +---------------------------------------------------------------------------------------------------- + +-- | Comments in the Dao language are not interpreted, but they are not disgarded either. Dao is +-- intended to manipulate natural language, and itself, so that it can "learn" new semantic +-- structures. Dao scripts can manipulate the syntax tree of other Dao scripts, and so it might be +-- helpful if the syntax tree included comments. +data Comment + = InlineComment UStr + | EndlineComment UStr + deriving (Eq, Ord, Typeable, Show) + +commentString :: Comment -> UStr +commentString com = case com of + InlineComment a -> a + EndlineComment a -> a + +instance NFData Comment where + rnf (InlineComment a) = seq a () + rnf (EndlineComment a) = seq a () + +instance HasNullValue Comment where + nullValue = EndlineComment nil + testNull (EndlineComment c) = c==nil + testNull (InlineComment c) = c==nil + +instance PPrintable Comment where + pPrint com = do + case com of + EndlineComment c -> pString ("//"++uchars c) >> pForceNewLine + InlineComment c -> pGroup True $ pInline $ + concat [[pString " /*"], map pString (lines (uchars c)), [pString "*/ "]] + +instance PrecedeWithSpace a => PrecedeWithSpace (Com a) where + precedeWithSpace o = case o of + Com b -> precedeWithSpace b + ComBefore a b -> precedeWithSpace a || precedeWithSpace b + ComAfter b _ -> precedeWithSpace b + ComAround a b _ -> precedeWithSpace a || precedeWithSpace b + -- there should always be a space before a comment. + +instance PPrintable [Comment] where { pPrint = mapM_ pPrint } + +instance PrecedeWithSpace [Comment] where { precedeWithSpace = not . null } + +instance HasRandGen [Comment] where { randO = return []; defaultO = return []; } +-- randO = do +-- i0 <- randInt +-- let (i1, many) = divMod i0 4 +-- (i2, typn) = divMod i1 16 +-- typx = take many (randToBase 2 typn ++ replicate 4 0) +-- lenx = map (+1) (randToBase 29 i2) +-- com typ = if typ==0 then EndlineComment else InlineComment +-- forM (zip typx lenx) $ \ (typ, len) -> +-- fmap (com typ . ustr . unwords . map (B.unpack . getRandomWord)) (replicateM len randInt) + +---------------------------------------------------------------------------------------------------- + +-- | Symbols in the Dao syntax tree that can actually be manipulated can be surrounded by comments. +-- The 'Com' structure represents a space-efficient means to surround each syntactic element with +-- comments that can be ignored without disgarding them. +data Com a = Com a | ComBefore [Comment] a | ComAfter a [Comment] | ComAround [Comment] a [Comment] + deriving (Eq, Ord, Typeable, Show) + +instance Functor Com where + fmap fn c = case c of + Com a -> Com (fn a) + ComBefore c1 a -> ComBefore c1 (fn a) + ComAfter a c2 -> ComAfter (fn a) c2 + ComAround c1 a c2 -> ComAround c1 (fn a) c2 + +instance NFData a => NFData (Com a) where + rnf (Com a ) = deepseq a () + rnf (ComBefore a b ) = deepseq a $! deepseq b () + rnf (ComAfter a b) = deepseq a $! deepseq b () + rnf (ComAround a b c) = deepseq a $! deepseq b $! deepseq c () + +instance HasNullValue a => HasNullValue (Com a) where + nullValue = Com nullValue + testNull (Com a) = testNull a + testNull _ = False + +instance HasLocation a => HasLocation (Com a) where + getLocation = getLocation . unComment + setLocation com loc = fmap (\a -> setLocation a loc) com + delLocation = fmap delLocation + +instance HasRandGen a => HasRandGen (Com a) where + randO = Com <$> randO + defaultO = Com <$> defaultO + +instance PPrintable a => PPrintable (Com a) where { pPrint = pPrintComWith pPrint } + +pPrintComWith :: (a -> PPrint) -> Com a -> PPrint +pPrintComWith prin com = case com of + Com c -> prin c + ComBefore ax c -> pcom ax >> prin c + ComAfter c bx -> prin c >> pcom bx + ComAround ax c bx -> pcom ax >> prin c >> pcom bx + where { pcom = pInline . map pPrint } + +pListOfComsWith :: (a -> PPrint) -> [Com a] -> PPrint +pListOfComsWith prin = sequence_ . map (pPrintComWith prin) + +pListOfComs :: PPrintable a => [Com a] -> PPrint +pListOfComs = pListOfComsWith pPrint + +randComWith :: RandO a -> RandO (Com a) +randComWith rand = fmap Com rand +-- randComWith :: RandO a -> RandO (Com a) +-- randComWith rand = do +-- typ <- fmap (flip mod 24 . unsign) randInt +-- a <- rand +-- case typ of +-- 0 -> do +-- before <- randO +-- after <- randO +-- return (ComAround before a after) +-- 1 -> do +-- before <- randO +-- return (ComBefore before a) +-- 2 -> do +-- after <- randO +-- return (ComAfter a after) +-- _ -> return (Com a) + +appendComments :: Com a -> [Comment] -> Com a +appendComments com cx = case com of + Com a -> ComAfter a cx + ComAfter a ax -> ComAfter a (ax++cx) + ComBefore ax a -> ComAround ax a cx + ComAround ax a bx -> ComAround ax a (bx++cx) + +com :: [Comment] -> a -> [Comment] -> Com a +com before a after = case before of + [] -> case after of + [] -> Com a + dx -> ComAfter a dx + cx -> case after of + [] -> ComBefore cx a + dx -> ComAround cx a dx + +setCommentBefore :: [Comment] -> Com a -> Com a +setCommentBefore cx com = case com of + Com a -> ComBefore cx a + ComBefore _ a -> ComBefore cx a + ComAfter a dx -> ComAround cx a dx + ComAround _ a dx -> ComAround cx a dx + +setCommentAfter :: [Comment] -> Com a -> Com a +setCommentAfter cx com = case com of + Com a -> ComAfter a cx + ComBefore dx a -> ComAround dx a cx + ComAfter a _ -> ComAfter a cx + ComAround dx a _ -> ComAround dx a cx + +unComment :: Com a -> a +unComment com = case com of + Com a -> a + ComBefore _ a -> a + ComAfter a _ -> a + ComAround _ a _ -> a + +getComment :: Com a -> ([Comment], [Comment]) +getComment com = case com of + Com _ -> ([], []) + ComBefore a _ -> (a, []) + ComAfter _ b -> ([], b) + ComAround a _ b -> (a, b) + +---------------------------------------------------------------------------------------------------- + +-- | Direct a reference at a particular tree in the runtime. +data RefQualifier + = UNQUAL -- ^ unqualified + | LOCAL -- ^ refers to the current local variable stack + | CONST -- ^ refers to a built-in constant + | STATIC -- ^ a local variable stack specific to a 'Subroutine' that lives on even after the + -- subroutine has completed. + | GLOBAL -- ^ the global variable space for the current module. + | GLODOT -- ^ a relative reference, gets it's name because it begins with a dot (".") character. + -- Similar to the "this" keyword in C++ and Java, refers to the object of the current + -- context set by the "with" statement, but defaults to the global variable space when + -- not within a "with" statement. This is necessary to differentiate between local + -- variables and references to the "with" context. + deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read) + +instance NFData RefQualifier where { rnf a = seq a () } + +instance PPrintable RefQualifier where { pPrint = pUStr . toUStr } + +instance PrecedeWithSpace RefQualifier where + precedeWithSpace o = case o of + LOCAL -> True + CONST -> True + STATIC -> True + GLOBAL -> True + _ -> False + +instance UStrType RefQualifier where + toUStr a = ustr $ case a of + UNQUAL -> "" + LOCAL -> "local" + CONST -> "const" + STATIC -> "static" + GLOBAL -> "global" + GLODOT -> "." + maybeFromUStr str = case uchars str of + "local" -> Just LOCAL + "const" -> Just CONST + "static" -> Just STATIC + "global" -> Just GLOBAL + "." -> Just GLODOT + "" -> Just UNQUAL + _ -> Nothing + fromUStr str = maybe (error (show str++" is not a reference qualifier")) id (maybeFromUStr str) + +instance HasRandGen RefQualifier where + randO = fmap toEnum (nextInt (1+fromEnum (minBound::RefQualifier))) + defaultO = randO + +---------------------------------------------------------------------------------------------------- + +-- | Binary operators. +data InfixOp + = ADD | SUB | MULT + | DIV | MOD | POW + | ORB | ANDB | XORB + | SHL | SHR + | OR | AND + | EQUL | NEQUL + | GTN | LTN + | GTEQ | LTEQ + | ARROW + deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read) + +instance UStrType InfixOp where + toUStr a = ustr $ case a of + { ADD -> "+" ; SUB -> "-" ; MULT -> "*" + ; DIV -> "/" ; MOD -> "%" ; POW -> "**" + ; ORB -> "|" ; ANDB -> "&" ; XORB -> "^" + ; SHL -> "<<"; SHR -> ">>" + ; OR -> "||"; AND -> "&&" + ; EQUL -> "=="; NEQUL-> "!=" + ; LTN -> "<" ; GTN -> ">" + ; LTEQ -> "<="; GTEQ -> ">=" + ; ARROW -> "->"; + } + maybeFromUStr str = case uchars str of + { "+" -> Just ADD ; "-" -> Just SUB ; "*" -> Just MULT + ; "/" -> Just DIV ; "%" -> Just MOD ; "**" -> Just POW + ; "|" -> Just ORB ; "&" -> Just ANDB ; "^" -> Just XORB + ; "<<" -> Just SHL ; ">>" -> Just SHR + ; "||" -> Just OR ; "&&" -> Just AND + ; "==" -> Just EQUL ; "!=" -> Just NEQUL + ; "<" -> Just LTN ; ">" -> Just GTN + ; "<=" -> Just LTEQ ; ">=" -> Just GTEQ + ; "->" -> Just ARROW; + ; _ -> Nothing + } + fromUStr str = maybe (error (show str++" is not an infix operator")) id (maybeFromUStr str) + +instance NFData InfixOp where { rnf a = seq a () } + +instance PPrintable InfixOp where { pPrint = pUStr . toUStr } + +infixOpCommutativity :: InfixOp -> Bool +infixOpCommutativity = (arr !) where + arr :: Array InfixOp Bool + arr = array (minBound, maxBound) $ + [ (ADD, True), (SUB, False), (MULT, True), (DIV, False), (MOD, False), (POW, False) + , (ORB, True), (ANDB, True), (XORB, True), (SHL, False), (SHR, False), (OR, False), (AND, False) + , (EQUL, True), (NEQUL, True), (LTN, False), (GTN, False), (LTEQ, False), (GTEQ, False) + , (ARROW, False) + ] + +-- binary 0x8D 0xA0 +instance B.Binary InfixOp mtab where + put o = B.putWord8 $ case o of + { EQUL -> 0x8D; NEQUL -> 0x8E; GTN -> 0x8F; LTN -> 0x90; GTEQ -> 0x91; LTEQ -> 0x92 + ; ADD -> 0x93; SUB -> 0x94; MULT -> 0x95; DIV -> 0x96 + ; MOD -> 0x97; POW -> 0x98; ORB -> 0x99; ANDB -> 0x9A + ; XORB -> 0x9B; SHL -> 0x9C; SHR -> 0x9D; ARROW -> 0x9E + ; OR -> 0x9F; AND -> 0xA0 } + get = B.word8PrefixTable <|> fail "expecting InfixOp" + +-- The byte prefixes overlap with the update operators of similar function to +-- the operators, except for the comparison opeators (EQUL, NEQUL, GTN, LTN, +-- GTEQ, LTEQ) which overlap with the prefix operators (INVB, NOT, NEGTIV, POSTIV, REF, DEREF) +instance B.HasPrefixTable InfixOp B.Byte mtab where + prefixTable = B.mkPrefixTableWord8 "InfixOp" 0x8D 0xA0 $ let {r=return} in + [ r EQUL , r NEQUL, r GTN , r LTN, r GTEQ , r LTEQ -- 0x8D,0x8E,0x8F,0x90,0x91,0x92 + , r ADD , r SUB , r MULT, r DIV, r MOD , r POW , r ORB -- 0x93,0x94,0x95,0x96,0x97,0x98,0x99 + , r ANDB , r XORB , r SHL , r SHR, r ARROW, r OR , r AND -- 0x9A,0x9B,0x9C,0x9D,0x9E,0x9F,0xA0 + ] + +instance HasRandGen InfixOp where + randO = fmap toEnum (nextInt (1+fromEnum (maxBound::InfixOp))) + defaultO = randO + +allPrefixOpChars :: String +allPrefixOpChars = "$@~!-+" + +allPrefixOpStrs :: String +allPrefixOpStrs = " $ @ ~ - + ! " + +---------------------------------------------------------------------------------------------------- + +-- | Unary operators. +data ArithPfxOp = INVB | NOT | NEGTIV | POSTIV + deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read) + +instance NFData ArithPfxOp where { rnf a = seq a () } + +instance UStrType ArithPfxOp where + toUStr op = ustr $ case op of + INVB -> "~" + NOT -> "!" + NEGTIV -> "-" + POSTIV -> "+" + maybeFromUStr str = case uchars str of + "~" -> Just INVB + "!" -> Just NOT + "-" -> Just NEGTIV + "+" -> Just POSTIV + _ -> Nothing + fromUStr str = maybe (error (show str++" is not a prefix opretor")) id (maybeFromUStr str) + +instance PPrintable ArithPfxOp where { pPrint = pUStr . toUStr } + +-- binary 0x8E 0x9B +instance B.Binary ArithPfxOp mtab where + put o = B.putWord8 $ case o of { INVB -> 0x9B; NOT -> 0x8E; NEGTIV -> 0x94; POSTIV -> 0x93 } + get = B.word8PrefixTable <|> fail "expecting ArithPfxOp" + +instance B.HasPrefixTable ArithPfxOp B.Byte mtab where + prefixTable = B.mkPrefixTableWord8 "ArithPfxOp" 0x8E 0x9F $ let {r=return;z=mzero} in + [ r NOT -- 0x8E + , z, z, z, z -- 0x8F,0x90,0x91,0x92 + , r POSTIV, r NEGTIV -- 0x93,0x94 + , z, z, z, z, z, z -- 0x95,0x96,0x97,0x98,0x99,0x9A + , r INVB -- 0x9B + ] + +instance HasRandGen ArithPfxOp where + randO = fmap toEnum (nextInt (1+fromEnum (maxBound::ArithPfxOp))) + defaultO = randO + +allInfixOpChars :: String +allInfixOpChars = "+-*/%<>^&|.?:" + +allInfixOpStrs :: String +allInfixOpStrs = " + - * / % ** -> . || && == != | & ^ << >> < > <= >= . -> <- ? : :: " + +---------------------------------------------------------------------------------------------------- + +newtype DotNameExpr = DotNameExpr{ undotNameExpr :: Name } deriving (Eq, Ord, Show, Typeable) + +instance NFData DotNameExpr where { rnf (DotNameExpr n) = deepseq n () } + +instance B.Binary DotNameExpr mtab where { put (DotNameExpr n) = B.put n; get = DotNameExpr <$> B.get; } + +instance PPrintable DotNameExpr where { pPrint (DotNameExpr n) = pPrint n } + +-- | A 'DotName' is simply a ".name" expression in the Dao language. It is a component of the +-- 'DotLabelExpr' and 'AST_DotLabel' data types. +data AST_DotName = AST_DotName (Com ()) Name deriving (Eq, Ord, Show, Typeable) + +getDotNameAST :: AST_DotName -> Name +getDotNameAST (AST_DotName _ n) = n + +instance NFData AST_DotName where { rnf (AST_DotName a b) = deepseq a $! deepseq b () } + +instance PPrintable AST_DotName where + pPrint (AST_DotName c n) = pInline [pPrintComWith (\ () -> pString ".") c, pPrint n] + +instance Intermediate DotNameExpr AST_DotName where + toInterm (AST_DotName _ n) = [DotNameExpr n] + fromInterm (DotNameExpr n) = [AST_DotName (Com ()) n] + +---------------------------------------------------------------------------------------------------- + +data NamespaceExpr = NamespaceExpr (Maybe Name) Location deriving (Eq, Ord, Show, Typeable) + +instance NFData NamespaceExpr where { rnf (NamespaceExpr a b) = deepseq a $! deepseq b () } + +instance HasNullValue NamespaceExpr where + nullValue = NamespaceExpr Nothing LocationUnknown + testNull (NamespaceExpr Nothing _) = True + testNull _ = False + +instance HasLocation NamespaceExpr where + getLocation (NamespaceExpr _ loc) = loc + setLocation (NamespaceExpr a _ ) loc = NamespaceExpr a loc + delLocation (NamespaceExpr a _ ) = NamespaceExpr a LocationUnknown + +instance PPrintable NamespaceExpr where { pPrint = pPrintInterm } + +instance B.Binary NamespaceExpr mtab where + put (NamespaceExpr a loc) = B.put a >> B.put loc + get = return NamespaceExpr <*> B.get <*> B.get + +---------------------------------------------------------------------------------------------------- + +data AST_Namespace + = AST_NoNamespace + | AST_Namespace (Com Name) Location + deriving (Eq, Ord, Show, Typeable) + +instance NFData AST_Namespace where + rnf AST_NoNamespace = () + rnf (AST_Namespace a b) = deepseq a $! deepseq b () + +instance HasNullValue AST_Namespace where + nullValue = AST_NoNamespace + testNull AST_NoNamespace = True + testNull _ = False + +instance HasLocation AST_Namespace where + getLocation o = case o of + AST_NoNamespace -> LocationUnknown + AST_Namespace _ loc -> loc + setLocation o loc = case o of + AST_NoNamespace -> AST_NoNamespace + AST_Namespace a _ -> AST_Namespace a loc + delLocation o = case o of + AST_NoNamespace -> AST_NoNamespace + AST_Namespace a _ -> AST_Namespace a LocationUnknown + +instance PPrintable AST_Namespace where + pPrint o = case o of { AST_NoNamespace -> return (); AST_Namespace a _ -> pPrint a; } + +instance HasRandGen AST_Namespace where + randO = countNode $ runRandChoice + randChoice = randChoiceList [return AST_NoNamespace, return AST_Namespace <*> randO <*> no] + defaultO = randO + defaultChoice = randChoiceList [defaultO] + +instance Intermediate NamespaceExpr AST_Namespace where + toInterm o = case o of + AST_NoNamespace -> [nullValue] + AST_Namespace n loc -> [NamespaceExpr (Just $ unComment n) loc] + fromInterm (NamespaceExpr n loc) = case n of + Nothing -> [nullValue] + Just n -> [AST_Namespace (Com n) loc] + +---------------------------------------------------------------------------------------------------- + +-- | The intermediate form of 'AST_DotLabel'. +data DotLabelExpr = DotLabelExpr DotNameExpr [DotNameExpr] Location + deriving (Eq, Ord, Show, Typeable) + +instance NFData DotLabelExpr where + rnf (DotLabelExpr n nm loc) = deepseq n $! deepseq nm $! deepseq loc () + +instance HasLocation DotLabelExpr where + getLocation (DotLabelExpr _ _ loc) = loc + setLocation (DotLabelExpr n nx _ ) loc = DotLabelExpr n nx loc + delLocation (DotLabelExpr n nx _ ) = DotLabelExpr n nx LocationUnknown + +instance B.Binary DotLabelExpr mtab where + put (DotLabelExpr n nx loc) = B.prefixByte 0x81 $ B.put n >> B.put nx >> B.put loc + get = B.word8PrefixTable <|> fail "expecting DotLabelExpr" + +instance B.HasPrefixTable DotLabelExpr Word8 mtab where + prefixTable = B.mkPrefixTableWord8 "DotLabelExpr" 0x81 0x81 $ + [return DotLabelExpr <*> B.get <*> B.get <*> B.get] + +instance PPrintable DotLabelExpr where { pPrint = pPrintInterm } + +dotLabelToNameList :: DotLabelExpr -> [Name] +dotLabelToNameList (DotLabelExpr n nx _) = map undotNameExpr (n:nx) + +---------------------------------------------------------------------------------------------------- + +-- | This is a list of 'Dao.String.Name's separated by dots. It is a pseudo-reference used to denote +-- things like constructor names in 'InitExpr', or setting the logical names of "import" modules +-- statements. It is basically a list of 'Dao.String.Name's that always has at least one element. +data AST_DotLabel = AST_DotLabel Name [AST_DotName] Location deriving (Eq, Ord, Show, Typeable) + +instance NFData AST_DotLabel where + rnf (AST_DotLabel n nx loc) = deepseq n $! deepseq nx $! deepseq loc () + +instance HasLocation AST_DotLabel where + getLocation (AST_DotLabel _ _ loc) = loc + setLocation (AST_DotLabel n nx _ ) loc = AST_DotLabel n nx loc + delLocation (AST_DotLabel n nx _ ) = AST_DotLabel n nx LocationUnknown + +instance PPrintable AST_DotLabel where + pPrint (AST_DotLabel n nx _) = pWrapIndent $ pPrint n : map pPrint nx + +instance HasRandGen AST_DotLabel where + randO = return AST_DotLabel <*> randO <*> randListOf 0 3 (return AST_DotName <*> randO <*> randO) <*> no + defaultO = randO + +instance Intermediate DotLabelExpr AST_DotLabel where + toInterm (AST_DotLabel n nx loc) = [DotLabelExpr] <*> [DotNameExpr n] <*> [nx >>= ti] <*> [loc] + fromInterm (DotLabelExpr (DotNameExpr n) nx loc) = [AST_DotLabel] <*> [n] <*> [nx >>= fi] <*> [loc] + +dotLabelToRefExpr :: DotLabelExpr -> ReferenceExpr o +dotLabelToRefExpr (DotLabelExpr (DotNameExpr n) nx loc) = + ReferenceExpr UNQUAL n (loop nx) loc where + loop nx = case nx of + [] -> NullRefExpr + (DotNameExpr n):nx -> DotRefExpr n (loop nx) LocationUnknown + +refToDotLabelExpr :: ReferenceExpr o -> Maybe (DotLabelExpr, Maybe (ObjListExpr o)) +refToDotLabelExpr o = case o of + ReferenceExpr UNQUAL n suf loc -> + loop (\nx loc ol -> (DotLabelExpr (DotNameExpr n) nx loc, ol)) [] loc suf + _ -> mzero + where + loop f nx loc suf = case suf of + NullRefExpr -> return (f nx loc Nothing) + DotRefExpr n suf loc' -> loop f (nx++[DotNameExpr n]) (loc<>loc') suf + FuncCallExpr ol NullRefExpr -> return (f nx loc (Just ol)) + _ -> mzero + +dotLabelToRefAST :: AST_DotLabel -> AST_Reference o +dotLabelToRefAST (AST_DotLabel n nx loc) = AST_Reference UNQUAL [] n (loop nx) loc where + loop nx = case nx of + [] -> AST_RefNull + (AST_DotName c n):nx -> AST_DotRef c n (loop nx) LocationUnknown + +refToDotLabelAST :: AST_Reference o -> Maybe (AST_DotLabel, Maybe (AST_ObjList o)) +refToDotLabelAST o = case o of + AST_Reference UNQUAL _ n suf loc -> loop (\nx loc ol -> (AST_DotLabel n nx loc, ol)) [] loc suf + _ -> mzero + where + loop f nx loc suf = case suf of + AST_RefNull -> return (f nx loc Nothing) + AST_DotRef c n suf loc' -> loop f (nx++[AST_DotName c n]) (loc<>loc') suf + AST_FuncCall ol AST_RefNull -> return (f nx loc (Just ol)) + _ -> mzero + +---------------------------------------------------------------------------------------------------- + +data RefSuffixExpr o + = NullRefExpr + | DotRefExpr Name (RefSuffixExpr o) Location + | SubscriptExpr (ObjListExpr o) (RefSuffixExpr o) + | FuncCallExpr (ObjListExpr o) (RefSuffixExpr o) + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (RefSuffixExpr o) where + rnf NullRefExpr = () + rnf (DotRefExpr a b c) = deepseq a $! deepseq b $! deepseq c () + rnf (SubscriptExpr a b ) = deepseq a $! deepseq b () + rnf (FuncCallExpr a b ) = deepseq a $! deepseq b () + +instance HasNullValue (RefSuffixExpr o) where + nullValue = NullRefExpr + testNull NullRefExpr = True + testNull _ = False + +instance HasLocation (RefSuffixExpr o) where + getLocation o = case o of + NullRefExpr -> LocationUnknown + DotRefExpr _ _ loc -> loc + SubscriptExpr a _ -> getLocation a + FuncCallExpr a _ -> getLocation a + setLocation o loc = case o of + NullRefExpr -> NullRefExpr + DotRefExpr a b _ -> DotRefExpr a b loc + SubscriptExpr a b -> SubscriptExpr (setLocation a loc) b + FuncCallExpr a b -> FuncCallExpr (setLocation a loc) b + delLocation o = case o of + NullRefExpr -> NullRefExpr + DotRefExpr a b _ -> DotRefExpr a (delLocation b) LocationUnknown + SubscriptExpr a b -> SubscriptExpr a (delLocation b) + FuncCallExpr a b -> FuncCallExpr a (delLocation b) + +---------------------------------------------------------------------------------------------------- + +-- | Anything that follows a reference, which could be square-bracketed indecies, function +-- parameters, or a dot and another reference. This is actually only a partial reference. The +-- 'Reference' is the full reference. The item selected by the 'Reference' is then further inspected +-- using a 'RefSuffix'; a 'RefSuffix' may be null, but a 'Reference' is never null. +data AST_RefSuffix o + = AST_RefNull + | AST_DotRef (Com ()) Name (AST_RefSuffix o) Location + | AST_Subscript (AST_ObjList o) (AST_RefSuffix o) + | AST_FuncCall (AST_ObjList o) (AST_RefSuffix o) + deriving (Eq, Ord, Typeable, Show, Functor) + +instance HasNullValue (AST_RefSuffix o) where + nullValue = AST_RefNull + testNull AST_RefNull = True + testNull _ = False + +instance HasLocation (AST_RefSuffix o) where + getLocation o = case o of + AST_RefNull -> LocationUnknown + AST_DotRef _ _ _ loc -> loc + AST_Subscript a _ -> getLocation a + AST_FuncCall a _ -> getLocation a + setLocation o loc = case o of + AST_RefNull -> AST_RefNull + AST_DotRef a b c _ -> AST_DotRef a b c loc + AST_Subscript a b -> AST_Subscript (setLocation a loc) b + AST_FuncCall a b -> AST_FuncCall (setLocation a loc) b + delLocation o = case o of + AST_RefNull -> AST_RefNull + AST_DotRef a b c _ -> AST_DotRef a b (delLocation c) LocationUnknown + AST_Subscript a b -> AST_Subscript (delLocation a) (delLocation b) + AST_FuncCall a b -> AST_FuncCall (delLocation a) (delLocation b) + +instance PPrintable o => PPrintable (AST_RefSuffix o) where + pPrint = pWrapIndent . loop where + loop ref = case ref of + AST_RefNull -> [] + AST_DotRef dot name ref _ -> pPrintComWith (\ () -> pString ".") dot : pUStr (toUStr name) : loop ref + AST_Subscript args ref -> pArgs "[]" args ++ loop ref + AST_FuncCall args ref -> pArgs "()" args ++ loop ref + where + pArgs str args = case str of + (open:close:_) -> [pString [open], pPrint args, pString [close]] + _ -> error "INTERNAL: bad instance definition of PPrintable AST_RefSuffix" + +instance NFData o => NFData (AST_RefSuffix o) where + rnf AST_RefNull = () + rnf (AST_DotRef a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + rnf (AST_Subscript a b ) = deepseq a $! deepseq b () + rnf (AST_FuncCall a b ) = deepseq a $! deepseq b () + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_RefSuffix o) where + randO = recurse $ countNode $ runRandChoice + randChoice = randChoiceList $ + [ return AST_RefNull + , scramble $ return AST_DotRef <*> randO <*> randO <*> randO <*> no + , scramble $ return AST_Subscript <*> randO <*> randO + , scramble $ return AST_FuncCall <*> randO <*> randO + ] + defaultO = runDefaultChoice + defaultChoice = randChoiceList $ + [ return AST_RefNull + , return AST_DotRef <*> defaultO <*> randO <*> pure AST_RefNull <*> no + , return AST_Subscript <*> pure nullValue <*> pure AST_RefNull + , return AST_FuncCall <*> pure nullValue <*> pure AST_RefNull + ] + +instance Intermediate (RefSuffixExpr o) (AST_RefSuffix o) where + toInterm ast = case ast of + AST_RefNull -> [NullRefExpr] + AST_DotRef _ name ref loc -> [DotRefExpr] <*> [name] <*> toInterm ref <*> [loc] + AST_Subscript args ref -> [SubscriptExpr] <*> toInterm args <*> toInterm ref + AST_FuncCall args ref -> [FuncCallExpr] <*> toInterm args <*> toInterm ref + fromInterm obj = case obj of + NullRefExpr -> [AST_RefNull] + DotRefExpr name ref loc -> [AST_DotRef] <*> [Com ()] <*> [name] <*> fromInterm ref <*> [loc] + SubscriptExpr args ref -> [AST_Subscript] <*> fromInterm args <*> fromInterm ref + FuncCallExpr args ref -> [AST_FuncCall] <*> fromInterm args <*> fromInterm ref + +---------------------------------------------------------------------------------------------------- + +data ReferenceExpr o + = RefObjectExpr (ParenExpr o) (RefSuffixExpr o) Location + | ReferenceExpr RefQualifier Name (RefSuffixExpr o) Location + -- ^ reference suffixed by square brackets or round brackets. If the 3rd parameter is False, it + -- is suffixed by square brackets, and True means suffixed by round brackets. Square brackets + -- indicates an indexing expression, round brackets indicates a function call. + deriving (Eq, Ord, Show, Typeable, Functor) + +instance NFData o => NFData (ReferenceExpr o) where + rnf (RefObjectExpr a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (ReferenceExpr a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + +instance HasNullValue (ReferenceExpr o) where + nullValue = RefObjectExpr nullValue NullRefExpr LocationUnknown + testNull (RefObjectExpr a NullRefExpr LocationUnknown) = testNull a + testNull _ = False + +instance HasLocation (ReferenceExpr o) where + getLocation o = case o of + RefObjectExpr _ _ loc -> loc + ReferenceExpr _ _ _ loc -> loc + setLocation o loc = case o of + RefObjectExpr a b _ -> RefObjectExpr a b loc + ReferenceExpr a b c loc -> ReferenceExpr a b c loc + delLocation o = case o of + RefObjectExpr a b _ -> RefObjectExpr (delLocation a) b LocationUnknown + ReferenceExpr a b c _ -> ReferenceExpr a b c LocationUnknown + +instance PPrintable o => PPrintable (ReferenceExpr o) where { pPrint = pPrintInterm } + +---------------------------------------------------------------------------------------------------- + +data AST_Reference o + = AST_RefObject (AST_Paren o) (AST_RefSuffix o) Location + | AST_Reference RefQualifier [Comment] Name (AST_RefSuffix o) Location + deriving (Eq, Ord, Show, Typeable, Functor) + +instance NFData o => NFData (AST_Reference o) where + rnf (AST_RefObject a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (AST_Reference a b c d e) = deepseq a $! deepseq b $! deepseq c $! deepseq d $! deepseq e () + +instance HasLocation (AST_Reference o) where + getLocation o = case o of + AST_RefObject _ _ loc -> loc + AST_Reference _ _ _ _ loc -> loc + setLocation o loc = case o of + AST_RefObject a b _ -> AST_RefObject a b loc + AST_Reference a b c d _ -> AST_Reference a b c d loc + delLocation o = case o of + AST_RefObject a b _ -> AST_RefObject (delLocation a) (delLocation b) LocationUnknown + AST_Reference a b c d _ -> AST_Reference a b c (delLocation d) LocationUnknown + +instance PPrintable o => PPrintable (AST_Reference o) where + pPrint o = pInline $ case o of + AST_RefObject o ref _ -> [pPrint o, pPrint ref] + AST_Reference q coms name ref _ -> concat $ + [ if q==UNQUAL then [] else [pPrint q, pString " "] + , [pPrint coms, pUStr (toUStr name), pPrint ref] + ] + +instance PrecedeWithSpace (AST_Reference o) where { precedeWithSpace _ = True } + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Reference o) where + randO = countNode $ runRandChoice + randChoice = randChoiceList $ + [ scramble $ return AST_Reference <*> randO <*> randO <*> randO <*> randO <*> no + , scramble $ return AST_RefObject <*> randO <*> randO <*> no + ] + defaultO = runDefaultChoice + defaultChoice = randChoiceList $ + [ return AST_Reference <*> defaultO <*> defaultO <*> defaultO <*> defaultO <*> no + , return AST_RefObject <*> defaultO <*> defaultO <*> no + ] + +instance Intermediate (ReferenceExpr o) (AST_Reference o) where + toInterm ast = case ast of + AST_RefObject paren ref loc -> [RefObjectExpr] <*> ti paren <*> ti ref <*> [loc] + AST_Reference q _ name ref loc -> [ReferenceExpr] <*> [q] <*> [name] <*> ti ref <*> [loc] + fromInterm o = case o of + RefObjectExpr paren ref loc -> [AST_RefObject] <*> fi paren <*> fi ref <*> [loc] + ReferenceExpr q name ref loc -> + [AST_Reference] <*> [q] <*> [[]] <*> [name] <*> fi ref <*> [loc] + +---------------------------------------------------------------------------------------------------- + +data RefPrefixExpr o + = PlainRefExpr (ReferenceExpr o) + | RefPrefixExpr RefPfxOp (RefPrefixExpr o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +-- | Eliminate composed DEREF-REF operations +-- > @$a == a +cleanupRefPrefixExpr :: RefPrefixExpr o -> RefPrefixExpr o +cleanupRefPrefixExpr o = + case o of { RefPrefixExpr DEREF (RefPrefixExpr REF o _) _ -> cleanupRefPrefixExpr o; _ -> o; } + +instance NFData o => NFData (RefPrefixExpr o) where + rnf (RefPrefixExpr a b c) = deepseq a $! deepseq b $! deepseq c () + rnf (PlainRefExpr a ) = deepseq a () + +instance HasNullValue (RefPrefixExpr o) where + nullValue = PlainRefExpr nullValue + testNull (PlainRefExpr a) = testNull a + testNull _ = False + +instance HasLocation (RefPrefixExpr o) where + getLocation o = case o of + PlainRefExpr o -> getLocation o + RefPrefixExpr _ _ o -> o + setLocation o loc = case o of + PlainRefExpr a -> PlainRefExpr (setLocation a loc) + RefPrefixExpr a b _ -> RefPrefixExpr a b loc + delLocation o = case o of + PlainRefExpr a -> PlainRefExpr (delLocation a) + RefPrefixExpr a b _ -> RefPrefixExpr a (delLocation b) LocationUnknown + +---------------------------------------------------------------------------------------------------- + +data AST_RefPrefix o + = AST_PlainRef (AST_Reference o) + | AST_RefPrefix RefPfxOp [Comment] (AST_RefPrefix o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_RefPrefix o) where + rnf (AST_PlainRef a ) = deepseq a () + rnf (AST_RefPrefix a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + +instance HasLocation (AST_RefPrefix o) where + getLocation o = case o of + AST_PlainRef a -> getLocation a + AST_RefPrefix _ _ _ loc -> loc + setLocation o loc = case o of + AST_PlainRef a -> AST_PlainRef $ setLocation a loc + AST_RefPrefix a b c _ -> AST_RefPrefix a b c loc + delLocation o = case o of + AST_PlainRef a -> AST_PlainRef $ delLocation a + AST_RefPrefix a b c _ -> AST_RefPrefix a b (delLocation c) LocationUnknown + +instance PPrintable o => PPrintable (AST_RefPrefix o) where + pPrint o = case o of + AST_PlainRef o -> pPrint o + AST_RefPrefix ariOp coms objXp _ -> pWrapIndent [pPrint ariOp, pPrint coms, pPrint objXp] + +instance PrecedeWithSpace (AST_RefPrefix o) where + precedeWithSpace o = case o of + AST_PlainRef _ -> True + _ -> False + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_RefPrefix o) where + randO = recurse $ countNode $ runRandChoice + randChoice = randChoiceList $ + [ return AST_PlainRef <*> randO + , return AST_RefPrefix <*> randO <*> randO <*> randO <*> no + ] + defaultO = runDefaultChoice + defaultChoice = randChoiceList $ + [ AST_PlainRef <$> defaultO + , return AST_RefPrefix <*> defaultO <*> defaultO <*> (AST_PlainRef <$> defaultO) <*> no + ] + +instance Intermediate (RefPrefixExpr o) (AST_RefPrefix o) where + toInterm ast = case ast of + AST_PlainRef a -> PlainRefExpr <$> toInterm a + AST_RefPrefix a _ c loc -> [RefPrefixExpr] <*> [a] <*> toInterm c <*> [loc] + fromInterm o = case o of + PlainRefExpr a -> AST_PlainRef <$> fromInterm a + RefPrefixExpr a c loc -> [AST_RefPrefix] <*> [a] <*> [[]] <*> fromInterm c <*> [loc] + +---------------------------------------------------------------------------------------------------- + +-- | Contains a list of 'ObjectExpr's, which are used to encode parameters to function calls, and +-- intialization lists. +data ObjListExpr o = ObjListExpr [AssignExpr o] Location deriving (Eq, Ord, Typeable, Show, Functor) + +instance Monoid (ObjListExpr o) where + mempty = ObjListExpr [] LocationUnknown + mappend (ObjListExpr a locA) (ObjListExpr b locB) = ObjListExpr (a++b) (locA<>locB) + +instance NFData o => NFData (ObjListExpr o) where { rnf (ObjListExpr a b) = deepseq a $! deepseq b () } + +instance HasNullValue (ObjListExpr o) where + nullValue = mempty + testNull (ObjListExpr a _) = null a + +instance HasLocation (ObjListExpr o) where + getLocation (ObjListExpr _ loc) = loc + setLocation (ObjListExpr a _ ) loc = ObjListExpr (fmap delLocation a) loc + delLocation (ObjListExpr a _ ) = ObjListExpr (fmap delLocation a) LocationUnknown + +---------------------------------------------------------------------------------------------------- + +data AST_ObjList o = AST_ObjList [Comment] [Com (AST_Assign o)] Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance Monoid (AST_ObjList o) where + mempty = AST_ObjList [] [] LocationUnknown + mappend (AST_ObjList a1 a2 aloc) (AST_ObjList b1 b2 bloc) = AST_ObjList (a1++b1) (a2++b2) (aloc<>bloc) + +instance HasNullValue (AST_ObjList o) where + nullValue = mempty + testNull (AST_ObjList [] [] _) = True + testNull _ = False + +instance HasLocation (AST_ObjList o) where + getLocation (AST_ObjList _ _ loc) = loc + setLocation (AST_ObjList a b _ ) loc = AST_ObjList a b loc + delLocation (AST_ObjList a b _ ) = AST_ObjList a (fmap delLocation b) LocationUnknown + +instance PPrintable o => PPrintable (AST_ObjList o) where + pPrint (AST_ObjList coms lst _) = pPrint coms >> + pInline (intersperse (pString ", ") (map pPrint lst)) + +instance NFData o => NFData (AST_ObjList o) where { rnf (AST_ObjList a b c) = deepseq a $! deepseq b $! deepseq c () } + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_ObjList o) where + randO = recurse $ depthLimitedInt 8 >>= \x -> AST_ObjList <$> randO <*> randList 0 x <*> no + defaultO = return AST_ObjList <*> defaultO <*> pure [] <*> no + +instance Intermediate (ObjListExpr o) (AST_ObjList o) where + toInterm (AST_ObjList _ lst loc) = [ObjListExpr] <*> [lst>>=uc0] <*> [loc] + fromInterm (ObjListExpr lst loc) = [AST_ObjList] <*> [[]] <*> [lst>>=nc0] <*> [loc] + +---------------------------------------------------------------------------------------------------- + +newtype OptObjListExpr o = OptObjListExpr (Maybe (ObjListExpr o)) + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (OptObjListExpr o) where { rnf (OptObjListExpr a) = deepseq a () } + +instance HasLocation (OptObjListExpr o) where + getLocation (OptObjListExpr o) = maybe LocationUnknown getLocation o + setLocation (OptObjListExpr o) loc = OptObjListExpr (setLocation o loc) + delLocation (OptObjListExpr o) = OptObjListExpr (delLocation o ) + +instance HasNullValue (OptObjListExpr o) where + nullValue = OptObjListExpr Nothing + testNull (OptObjListExpr Nothing) = True + testNull _ = False + +---------------------------------------------------------------------------------------------------- + +data AST_OptObjList o = AST_OptObjList [Comment] (Maybe (AST_ObjList o)) + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_OptObjList o) where + rnf (AST_OptObjList a b) = deepseq a $! deepseq b () + +instance HasNullValue (AST_OptObjList o) where + nullValue = AST_OptObjList [] Nothing + testNull (AST_OptObjList _ a) = maybe True testNull a + +pPrintObjList :: PPrintable o => String -> String -> String -> AST_ObjList o -> PPrint +pPrintObjList open comma close (AST_ObjList coms lst _) = pList (pPrint coms) open comma close (map pPrint lst) + +pPrintOptObjList :: PPrintable o => String -> String -> String -> AST_OptObjList o -> PPrint +pPrintOptObjList open comma close (AST_OptObjList coms o) = + maybe (return ()) (\o -> pPrint coms >> pPrintObjList open comma close o) o + +instance HasLocation (AST_OptObjList o) where + getLocation (AST_OptObjList _ o) = maybe LocationUnknown getLocation o + setLocation (AST_OptObjList c o) loc = AST_OptObjList c (fmap (flip setLocation loc) o) + delLocation (AST_OptObjList c o) = AST_OptObjList c (fmap delLocation o) + +instance PPrintable o => PPrintable (AST_OptObjList o) where { pPrint o = pPrintOptObjList "{" ", " "}" o } + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_OptObjList o) where + randO = countNode $ return AST_OptObjList <*> randO <*> randO + defaultO = return AST_OptObjList <*> defaultO <*> defaultO + +instance Intermediate (OptObjListExpr o) (AST_OptObjList o) where + toInterm (AST_OptObjList _ o) = OptObjListExpr <$> um1 o + fromInterm (OptObjListExpr o) = AST_OptObjList [] <$> nm1 o + +---------------------------------------------------------------------------------------------------- + +data LiteralExpr o = LiteralExpr o Location deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (LiteralExpr o) where + rnf (LiteralExpr a b) = deepseq a $! deepseq b () + +instance {- KEEP -} HasNullValue o => HasNullValue (LiteralExpr o) where + nullValue = LiteralExpr nullValue LocationUnknown + testNull (LiteralExpr o _) = testNull o + +instance HasLocation (LiteralExpr o) where + getLocation (LiteralExpr _ loc) = loc + setLocation (LiteralExpr o _ ) loc = LiteralExpr o loc + delLocation (LiteralExpr o _ ) = LiteralExpr o LocationUnknown + +---------------------------------------------------------------------------------------------------- + +data AST_Literal o = AST_Literal o Location deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_Literal o) where + rnf (AST_Literal a b) = deepseq a $! deepseq b () + +instance {- KEEP -} HasNullValue o => HasNullValue (AST_Literal o) where + nullValue = AST_Literal nullValue LocationUnknown + testNull (AST_Literal o _) = testNull o + +instance HasLocation (AST_Literal o) where + getLocation (AST_Literal _ loc) = loc + setLocation (AST_Literal a _ ) loc = AST_Literal a loc + delLocation (AST_Literal a _ ) = AST_Literal a LocationUnknown + +instance PPrintable o => PPrintable (AST_Literal o) where + pPrint (AST_Literal o _ ) = pPrint o + +instance PrecedeWithSpace (AST_Literal o) where + precedeWithSpace (AST_Literal _ _) = True + +instance HasRandGen o => HasRandGen (AST_Literal o) where + randO = scramble $ return AST_Literal <*> defaultO <*> no + defaultO = randO + +instance Intermediate (LiteralExpr o) (AST_Literal o) where + toInterm (AST_Literal a loc) = [LiteralExpr] <*> [a] <*> [loc] + fromInterm (LiteralExpr a loc) = [AST_Literal] <*> [a] <*> [loc] + +---------------------------------------------------------------------------------------------------- + +-- | Required parenthesese. +data ParenExpr o = ParenExpr (AssignExpr o) Location deriving (Eq, Ord, Typeable, Show, Functor) + +instance HasLocation (ParenExpr o) where + getLocation (ParenExpr _ loc) = loc + setLocation (ParenExpr o _ ) loc = ParenExpr o loc + delLocation (ParenExpr o _ ) = ParenExpr (delLocation o) LocationUnknown + +instance HasNullValue (ParenExpr o) where + nullValue = ParenExpr nullValue LocationUnknown + testNull (ParenExpr a _) = testNull a + +instance NFData o => NFData (ParenExpr o) where { rnf (ParenExpr a b) = deepseq a $! deepseq b () } + +instance PPrintable o => PPrintable (ParenExpr o) where { pPrint = pPrintInterm } + +---------------------------------------------------------------------------------------------------- + +data AST_Paren o = AST_Paren (Com (AST_Assign o)) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance HasLocation (AST_Paren o) where + getLocation (AST_Paren _ loc) = loc + setLocation (AST_Paren o _ ) loc = AST_Paren o loc + delLocation (AST_Paren o _ ) = AST_Paren (delLocation o) LocationUnknown + +instance HasNullValue (AST_Paren o) where + nullValue = AST_Paren nullValue LocationUnknown + testNull (AST_Paren a _) = testNull a + +instance NFData o => NFData (AST_Paren o) where { rnf (AST_Paren a b) = deepseq a $! deepseq b () } + +instance PPrintable o => PPrintable (AST_Paren o) where + pPrint (AST_Paren o _) = pInline [pString "(", pPrint o, pString ")"] + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Paren o) where + randO = recurse $ return AST_Paren <*> randO <*> no + defaultO = return AST_Paren <*> defaultO <*> no + +instance Intermediate (ParenExpr o) (AST_Paren o) where + toInterm (AST_Paren o loc) = [ParenExpr] <*> uc0 o <*> [loc] + fromInterm (ParenExpr o loc) = [AST_Paren] <*> nc0 o <*> [loc] + +---------------------------------------------------------------------------------------------------- + +data AssignExpr o + = EvalExpr (ObjTestExpr o) + | AssignExpr (ObjTestExpr o) UpdateOp (AssignExpr o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AssignExpr o) where + rnf (EvalExpr a ) = deepseq a () + rnf (AssignExpr a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + +instance HasNullValue (AssignExpr o) where + nullValue = EvalExpr nullValue + testNull (EvalExpr a) = testNull a + testNull _ = False + +instance HasLocation (AssignExpr o) where + getLocation o = case o of + EvalExpr o -> getLocation o + AssignExpr _ _ _ o -> o + setLocation o loc = case o of + EvalExpr a -> EvalExpr (setLocation a loc) + AssignExpr a b c _ -> AssignExpr a b c loc + delLocation o = case o of + EvalExpr a -> EvalExpr (delLocation a) + AssignExpr a b c _ -> AssignExpr (delLocation a) b (delLocation c) LocationUnknown + +instance PPrintable o => PPrintable (AssignExpr o) where { pPrint = pPrintInterm } + +---------------------------------------------------------------------------------------------------- + +data AST_Assign o + = AST_Eval (AST_ObjTest o) + | AST_Assign (AST_ObjTest o) (Com UpdateOp) (AST_Assign o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_Assign o) where + rnf (AST_Eval a ) = deepseq a () + rnf (AST_Assign a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + +instance HasNullValue (AST_Assign o) where + nullValue = AST_Eval nullValue + testNull (AST_Eval a) = testNull a + testNull _ = False + +instance HasLocation (AST_Assign o) where + getLocation o = case o of + AST_Eval o -> getLocation o + AST_Assign _ _ _ o -> o + setLocation o loc = case o of + AST_Eval o -> AST_Eval (setLocation o loc) + AST_Assign a b c _ -> AST_Assign a b c loc + delLocation o = case o of + AST_Eval o -> AST_Eval (delLocation o) + AST_Assign a b c _ -> AST_Assign (delLocation a) b (delLocation c) LocationUnknown + +instance PPrintable o => PPrintable (AST_Assign o) where + pPrint expr = case expr of + AST_Eval eq -> pPrint eq + AST_Assign objXp1 comUpdOp objXp2 _ -> pWrapIndent $ + [pPrint objXp1, pPrint comUpdOp, pPrint objXp2] + +instance PrecedeWithSpace (AST_Assign o) where + precedeWithSpace o = case o of + AST_Eval o -> precedeWithSpace o + AST_Assign o _ _ _ -> precedeWithSpace o + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Assign o) where + randO = countNode $ recurse $ runRandChoice + randChoice = randChoiceList $ + [ AST_Eval <$> randO + , do ox <- randListOf 0 3 (pure (,) <*> randO <*> randO) + o <- randO + return (foldr (\ (left, op) right -> AST_Assign left op right LocationUnknown) o ox) + ] + defaultO = runDefaultChoice + defaultChoice = randChoiceList $ + [ AST_Eval <$> defaultO + , return AST_Assign <*> defaultO <*> defaultO <*> (AST_Eval <$> defaultO) <*> no + ] + +instance Intermediate (AssignExpr o) (AST_Assign o) where + toInterm ast = case ast of + AST_Eval a -> EvalExpr <$> ti a + AST_Assign a b c loc -> [AssignExpr] <*> ti a <*> uc b <*> ti c <*> [loc] + fromInterm o = case o of + EvalExpr a -> AST_Eval <$> fi a + AssignExpr a b c loc -> [AST_Assign] <*> fi a <*> nc b <*> fi c <*> [loc] + +---------------------------------------------------------------------------------------------------- + +-- | A conditional expression of the form @a==b ? "yes" : "no"@ +data ObjTestExpr o + = ObjArithExpr (ArithExpr o) + | ObjTestExpr (ArithExpr o) (ArithExpr o) (ArithExpr o) Location + | ObjRuleFuncExpr (RuleFuncExpr o) + deriving (Eq, Ord, Show, Typeable, Functor) + +instance NFData o => NFData (ObjTestExpr o) where + rnf (ObjArithExpr a ) = deepseq a () + rnf (ObjTestExpr a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + rnf (ObjRuleFuncExpr a ) = deepseq a $! () + +instance HasNullValue (ObjTestExpr o) where + nullValue = ObjArithExpr nullValue + testNull (ObjArithExpr a) = testNull a + testNull _ = False + +instance HasLocation (ObjTestExpr o) where + getLocation o = case o of + ObjArithExpr a -> getLocation a + ObjTestExpr _ _ _ loc -> loc + ObjRuleFuncExpr o -> getLocation o + setLocation o loc = case o of + ObjArithExpr a -> ObjArithExpr (setLocation a loc) + ObjTestExpr a b c _ -> ObjTestExpr a b c loc + ObjRuleFuncExpr a -> ObjRuleFuncExpr (setLocation a loc) + delLocation o = case o of + ObjArithExpr a -> ObjArithExpr (delLocation a) + ObjTestExpr a b c _ -> + ObjTestExpr (delLocation a) (delLocation b) (delLocation c) LocationUnknown + ObjRuleFuncExpr a -> ObjRuleFuncExpr (delLocation a) + +instance PPrintable o => PPrintable (ObjTestExpr o) where { pPrint = pPrintInterm } + +---------------------------------------------------------------------------------------------------- + +-- | A conditional expression of the form @a==b ? "yes" : "no"@ +data AST_ObjTest o + = AST_ObjArith (AST_Arith o) + | AST_ObjTest (AST_Arith o) (Com ()) (AST_Arith o) (Com ()) (AST_Arith o) Location + | AST_ObjRuleFunc (AST_RuleFunc o) + deriving (Eq, Ord, Show, Typeable, Functor) + +instance NFData o => NFData (AST_ObjTest o) where + rnf (AST_ObjArith a ) = deepseq a () + rnf (AST_ObjTest a b c d e f) = + deepseq a $! deepseq b $! deepseq c $! deepseq d $! deepseq e $! deepseq f () + rnf (AST_ObjRuleFunc a ) = deepseq a () + +instance HasNullValue (AST_ObjTest o) where + nullValue = AST_ObjArith nullValue + testNull (AST_ObjArith a) = testNull a + testNull _ = False + +instance HasLocation (AST_ObjTest o) where + getLocation o = case o of + AST_ObjArith a -> getLocation a + AST_ObjTest _ _ _ _ _ loc -> loc + AST_ObjRuleFunc o -> getLocation o + setLocation o loc = case o of + AST_ObjArith a -> AST_ObjArith (setLocation a loc) + AST_ObjTest a b c d e _ -> AST_ObjTest a b c d e loc + AST_ObjRuleFunc a -> AST_ObjRuleFunc (setLocation a loc) + delLocation o = case o of + AST_ObjArith a -> AST_ObjArith (delLocation a) + AST_ObjTest a b c d e _ -> + AST_ObjTest (delLocation a) b (delLocation c) d (delLocation e) LocationUnknown + AST_ObjRuleFunc a -> AST_ObjRuleFunc (delLocation a) + +instance PPrintable o => PPrintable (AST_ObjTest o) where + pPrint o = case o of + AST_ObjArith a -> pPrint a + AST_ObjTest a b c d e _ -> pWrapIndent $ + [ pPrint a + , pPrintComWith (\ () -> pString " ? ") b, pPrint c + , pPrintComWith (\ () -> pString " : ") d, pPrint e + ] + AST_ObjRuleFunc o -> pPrint o + +instance PrecedeWithSpace (AST_ObjTest o) where + precedeWithSpace o = case o of + AST_ObjArith o -> precedeWithSpace o + AST_ObjTest o _ _ _ _ _ -> precedeWithSpace o + AST_ObjRuleFunc{} -> True + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_ObjTest o) where + randO = countNode $ runRandChoice + randChoice = randChoiceList $ + [ AST_ObjArith <$> randO + , let p = pure (Com ()) in + recurse $ scramble $ return AST_ObjTest <*> randO <*> p <*> randO <*> p <*> randO <*> no + , AST_ObjRuleFunc <$> randO + ] + defaultO = AST_ObjArith <$> defaultO + defaultChoice = randChoiceList [defaultO] + +instance Intermediate (ObjTestExpr o) (AST_ObjTest o) where + toInterm o = case o of + AST_ObjArith o -> ObjArithExpr <$> ti o + AST_ObjTest a _ b _ c loc -> [ObjTestExpr] <*> ti a <*> ti b <*> ti c <*> [loc] + AST_ObjRuleFunc a -> [ObjRuleFuncExpr] <*> ti a + fromInterm o = case o of + ObjArithExpr o -> AST_ObjArith <$> fi o + ObjTestExpr a b c loc -> + [AST_ObjTest] <*> fi a <*> [Com ()] <*> fi b <*> [Com ()] <*> fi c <*> [loc] + ObjRuleFuncExpr a -> AST_ObjRuleFunc <$> fi a + +---------------------------------------------------------------------------------------------------- + +data RefPfxOp = REF | DEREF deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read) + +instance NFData RefPfxOp where { rnf a = seq a () } + +instance UStrType RefPfxOp where + toUStr op = ustr $ case op of + REF -> "$" + DEREF -> "@" + maybeFromUStr str = case uchars str of + "$" -> Just REF + "@" -> Just DEREF + _ -> Nothing + fromUStr str = maybe (error (show str++" is not a prefix opretor")) id (maybeFromUStr str) + +instance PPrintable RefPfxOp where { pPrint = pUStr . toUStr } + +instance HasRandGen RefPfxOp where + randO = fmap toEnum (nextInt (1+fromEnum (maxBound::RefPfxOp))) + defaultO = randO + +---------------------------------------------------------------------------------------------------- + +data UpdateOp + = UCONST | UADD | USUB | UMULT | UDIV | UMOD | UPOW | UORB | UANDB | UXORB | USHL | USHR + deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read) +instance NFData UpdateOp where { rnf a = seq a () } + +allUpdateOpStrs :: String +allUpdateOpStrs = " = += -= *= /= %= **= |= &= ^= <<= >>= " + +instance UStrType UpdateOp where + toUStr a = ustr $ case a of + UCONST -> "=" + UADD -> "+=" + USUB -> "-=" + UMULT -> "*=" + UDIV -> "/=" + UMOD -> "%=" + UPOW -> "**=" + UORB -> "|=" + UANDB -> "&=" + UXORB -> "^=" + USHL -> "<<=" + USHR -> ">>=" + maybeFromUStr str = case uchars str of + "=" -> Just UCONST + "+=" -> Just UADD + "-=" -> Just USUB + "*=" -> Just UMULT + "/=" -> Just UDIV + "%=" -> Just UMOD + "**=" -> Just UPOW + "|=" -> Just UORB + "&=" -> Just UANDB + "^=" -> Just UXORB + "<<=" -> Just USHL + ">>=" -> Just USHR + _ -> Nothing + fromUStr str = + maybe (error (show str++" is not an assignment/update operator")) id (maybeFromUStr str) + +instance PPrintable UpdateOp where { pPrint op = pString (' ':uchars op++" ") } + +-- binary 0x8D 0x9D UpdateOp-->InfixOp +instance B.Binary UpdateOp mtab where + put o = B.putWord8 $ case o of + UCONST -> 0x8D + UADD -> 0x93 + USUB -> 0x94 + UMULT -> 0x95 + UDIV -> 0x96 + UMOD -> 0x97 + UPOW -> 0x98 + UORB -> 0x99 + UANDB -> 0x9A + UXORB -> 0x9B + USHL -> 0x9C + USHR -> 0x9D + get = B.word8PrefixTable <|> fail "expecting UpdateOp" + +instance B.HasPrefixTable UpdateOp B.Byte mtab where + prefixTable = B.mkPrefixTableWord8 "UpdateOp" 0x8D 0x9D $ let {r=return;z=mzero} in + [ r UCONST -- 0x8D + , z, z, z, z, z -- 0x8E,0x8F,0x90,0x91,0x92 + , r UADD, r USUB, r UMULT, r UDIV, r UMOD, r UPOW, r UORB -- 0x93,0x94,0x95,0x96,0x97,0x98,0x99 + , r UANDB, r UXORB, r USHL, r USHR -- 0x9A,0x9B,0x9C,0x9D + ] + +instance HasRandGen UpdateOp where + randO = fmap toEnum (nextInt (1+fromEnum (maxBound::UpdateOp))) + defaultO = randO + +---------------------------------------------------------------------------------------------------- + +data ArithExpr o + = ObjectExpr (ObjectExpr o) + | ArithExpr (ArithExpr o) InfixOp (ArithExpr o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (ArithExpr o) where + rnf (ObjectExpr a ) = deepseq a () + rnf (ArithExpr a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + +instance HasNullValue (ArithExpr o) where + nullValue = ObjectExpr nullValue + testNull (ObjectExpr a) = testNull a + testNull _ = False + +instance HasLocation (ArithExpr o) where + getLocation o = case o of + ObjectExpr o -> getLocation o + ArithExpr _ _ _ o -> o + setLocation o loc = case o of + ObjectExpr a -> ObjectExpr (setLocation a loc) + ArithExpr a b c _ -> ArithExpr a b c loc + delLocation o = case o of + ObjectExpr a -> ObjectExpr (delLocation a) + ArithExpr a b c _ -> ArithExpr (delLocation a) b (delLocation c) LocationUnknown + +instance PPrintable o => PPrintable (ArithExpr o) where { pPrint = pPrintInterm } + +---------------------------------------------------------------------------------------------------- + +data AST_Arith o + = AST_Object (AST_Object o) + | AST_Arith (AST_Arith o) (Com InfixOp) (AST_Arith o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_Arith o) where + rnf (AST_Object a ) = deepseq a () + rnf (AST_Arith a b c d ) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + +instance HasNullValue (AST_Arith o) where + nullValue = AST_Object nullValue + testNull (AST_Object a) = testNull a + testNull _ = False + +instance HasLocation (AST_Arith o) where + getLocation o = case o of + AST_Object o -> getLocation o + AST_Arith _ _ _ o -> o + setLocation o loc = case o of + AST_Object a -> AST_Object (setLocation a loc) + AST_Arith a b c _ -> AST_Arith a b c loc + delLocation o = case o of + AST_Object a -> AST_Object (delLocation a) + AST_Arith a b c _ -> AST_Arith (delLocation a) b (delLocation c) LocationUnknown + +instance PPrintable o => PPrintable (AST_Arith o) where + pPrint o = case o of + AST_Object o -> pPrint o + AST_Arith objXp1 comAriOp objXp2 _ -> pWrapIndent [pPrint objXp1, pPrint comAriOp, pPrint objXp2] + +instance PrecedeWithSpace (AST_Arith o) where + precedeWithSpace o = case o of + AST_Object o -> precedeWithSpace o + AST_Arith o _ _ _ -> precedeWithSpace o + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Arith o) where + randO = countNode $ runRandChoice + defaultChoice = randChoiceList $ + [ AST_Object <$> defaultO + , return AST_Arith <*> (AST_Object <$> defaultO) <*> defaultO <*> (AST_Object <$> defaultO) <*> no + ] + defaultO = runDefaultChoice + randChoice = randChoiceList $ + [ AST_Object <$> randO + , do left <- AST_Object <$> randO + x <- getCurrentDepth + ops <- randListOf 0 (max 1 (4-x)) $ + pure (,) <*> randInfixOp <*> (AST_Object <$> randO) + return $ foldPrec left ops + ] where + randInfixOp :: RandO (Com InfixOp, Int, Bool) + randInfixOp = do + (op, prec, assoc) <- runRandChoiceOf opGroups + op <- randComWith (return op) + return (op, prec, assoc) + left op = (True , op) + right op = (False, op) + opGroups :: RandChoice (InfixOp, Int, Bool) + opGroups = randChoiceList $ map return $ do + (precedence, (associativity, operators)) <- zip [1..] $ concat $ + [ map right [[OR], [AND], [EQUL, NEQUL]] + , map left $ + [ [GTN, LTN, GTEQ, LTEQ], [SHL, SHR] + , [ORB], [XORB], [ANDB] + , [ADD, SUB], [MULT, DIV, MOD] + ] + , map right [[POW], [ARROW]] + ] + operator <- operators + return (operator, precedence, associativity) + bind left op right = AST_Arith left op right LocationUnknown + foldPrec left ops = case ops of + [] -> left + ((op, prec, _), right):ops -> case scanRight prec right ops of + (right, ops) -> foldPrec (bind left op right) ops + scanRight prevPrec left ops = case ops of + [] -> (left, []) + ((op, prec, assoc), right):next -> + if prevPrec scanRight prevPrec (bind left op right) next + else (left, ops) + +instance Intermediate (ArithExpr o) (AST_Arith o) where + toInterm o = case o of + AST_Object a -> ObjectExpr <$> ti a + AST_Arith a b c loc -> [ArithExpr ] <*> ti a <*> uc b <*> ti c <*> [loc] + fromInterm o = case o of + ObjectExpr a -> AST_Object <$> fi a + ArithExpr a b c loc -> [AST_Arith ] <*> fi a <*> nc b <*> fi c <*> [loc] + +---------------------------------------------------------------------------------------------------- + +data ObjectExpr o + = VoidExpr + | ObjLiteralExpr (LiteralExpr o) + | ObjSingleExpr (RefPrefixExpr o) + | ArithPfxExpr ArithPfxOp (ObjectExpr o) Location + | InitExpr DotLabelExpr (OptObjListExpr o) (ObjListExpr o) Location + | StructExpr Name (OptObjListExpr o) Location + | MetaEvalExpr (CodeBlock o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (ObjectExpr o) where + rnf VoidExpr = () + rnf (ObjLiteralExpr a ) = deepseq a () + rnf (ObjSingleExpr a ) = deepseq a $! () + rnf (ArithPfxExpr a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (InitExpr a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + rnf (StructExpr a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (MetaEvalExpr a b ) = deepseq a $! deepseq b () + +instance HasNullValue (ObjectExpr o) where + nullValue = VoidExpr + testNull VoidExpr = True + testNull _ = False + +instance HasLocation (ObjectExpr o) where + getLocation o = case o of + VoidExpr -> LocationUnknown + ObjLiteralExpr o -> getLocation o + ObjSingleExpr o -> getLocation o + ArithPfxExpr _ _ o -> o + InitExpr _ _ _ o -> o + StructExpr _ _ o -> o + MetaEvalExpr _ o -> o + setLocation o loc = case o of + VoidExpr -> VoidExpr + ObjLiteralExpr a -> ObjLiteralExpr (setLocation a loc) + ObjSingleExpr a -> ObjSingleExpr (setLocation a loc) + ArithPfxExpr a b _ -> ArithPfxExpr a b loc + InitExpr a b c _ -> InitExpr a b c loc + StructExpr a b _ -> StructExpr a b loc + MetaEvalExpr a _ -> MetaEvalExpr a loc + delLocation o = case o of + VoidExpr -> VoidExpr + ObjLiteralExpr a -> ObjLiteralExpr (fd a) + ObjSingleExpr a -> ObjSingleExpr (fd a) + ArithPfxExpr a b _ -> ArithPfxExpr a (fd b) lu + InitExpr a b c _ -> InitExpr (fd a) (fd b) (fd c) lu + StructExpr a b _ -> StructExpr (fd a) (fd b) lu + MetaEvalExpr a _ -> MetaEvalExpr (fd a) lu + where + lu = LocationUnknown + fd :: HasLocation a => a -> a + fd = delLocation + +instance PPrintable o => PPrintable (ObjectExpr o) where { pPrint = pPrintInterm } + +---------------------------------------------------------------------------------------------------- + +-- | Part of the Dao language abstract syntax tree: any expression that evaluates to an Object. +data AST_Object o + = AST_Void -- ^ Not a language construct, but used where an object expression is optional. + | AST_ObjLiteral (AST_Literal o) + | AST_ObjSingle (AST_RefPrefix o) + | AST_ArithPfx ArithPfxOp [Comment] (AST_Object o) Location + | AST_Init AST_DotLabel (AST_OptObjList o) (AST_ObjList o) Location + | AST_Struct Name (AST_OptObjList o) Location + | AST_MetaEval (AST_CodeBlock o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_Object o) where + rnf AST_Void = () + rnf (AST_ObjLiteral a ) = deepseq a () + rnf (AST_ObjSingle a ) = deepseq a () + rnf (AST_ArithPfx a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + rnf (AST_Init a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + rnf (AST_Struct a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (AST_MetaEval a b ) = deepseq a $! deepseq b () + +instance HasNullValue (AST_Object o) where + nullValue = AST_Void + testNull AST_Void = True + testNull _ = False + +instance HasLocation (AST_Object o) where + getLocation o = case o of + AST_Void -> LocationUnknown + AST_ObjLiteral o -> getLocation o + AST_ObjSingle o -> getLocation o + AST_ArithPfx _ _ _ o -> o + AST_Init _ _ _ o -> o + AST_Struct _ _ o -> o + AST_MetaEval _ o -> o + setLocation o loc = case o of + AST_Void -> AST_Void + AST_ObjLiteral a -> AST_ObjLiteral (setLocation a loc) + AST_ObjSingle a -> AST_ObjSingle (setLocation a loc) + AST_ArithPfx a b c _ -> AST_ArithPfx a b c loc + AST_Init a b c _ -> AST_Init a b c loc + AST_Struct a b _ -> AST_Struct a b loc + AST_MetaEval a _ -> AST_MetaEval a loc + delLocation o = case o of + AST_Void -> AST_Void + AST_ObjLiteral a -> AST_ObjLiteral (delLocation a) + AST_ObjSingle a -> AST_ObjSingle (delLocation a) + AST_ArithPfx a b c _ -> AST_ArithPfx a b (delLocation c) LocationUnknown + AST_Init a b c _ -> AST_Init (delLocation a) (delLocation b) (delLocation c) LocationUnknown + AST_Struct a b _ -> AST_Struct a (delLocation b) LocationUnknown + AST_MetaEval a _ -> AST_MetaEval (delLocation a) LocationUnknown + +instance PPrintable o => PPrintable (AST_Object o) where + pPrint expr = case expr of + AST_Void -> return () + AST_ObjLiteral o -> pPrint o + AST_ObjSingle o -> pPrint o + AST_ArithPfx op coms objXp _ -> pWrapIndent $ + [pPrint op, pPrint coms, pPrint objXp] + AST_Init ref objs elems _ -> + pInline [pPrint ref, pPrintOptObjList "(" ", " ")" objs, pPrintObjList "{" ", " "}" elems] + AST_Struct nm itms _ -> case itms of + AST_OptObjList coms items -> do + let name = pString $ '#' : uchars (toUStr nm) + pPrint coms + case items of + Nothing -> name + Just (AST_ObjList coms items _) -> do + pPrint coms + pList name "{" ", " "}" $ map pPrint items + AST_MetaEval cObjXp _ -> pInline [pString "${", pPrint cObjXp, pString "}"] + +instance PrecedeWithSpace (AST_Object o) where + precedeWithSpace o = case o of + AST_Void -> False + AST_MetaEval{} -> False + AST_ObjSingle o -> precedeWithSpace o + _ -> True + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Object o) where + randO = countNode $ runRandChoice + randChoice = randChoiceList $ + [ AST_ObjLiteral <$> randO + , AST_ObjSingle <$> randO + , pure AST_ArithPfx <*> randO <*> randO <*> randO <*> no + , pure AST_Init <*> randO <*> randO <*> randO <*> no + , pure AST_MetaEval <*> randO <*> no + ] + defaultO = runDefaultChoice + defaultChoice = randChoiceList $ + [ AST_ObjLiteral <$> defaultO + , AST_ObjSingle <$> defaultO + , return AST_ArithPfx <*> defaultO <*> defaultO <*> (AST_ObjLiteral <$> defaultO) <*> no + , return AST_Init <*> defaultO <*> defaultO <*> defaultO <*> no + , return AST_Struct <*> defaultO <*> defaultO <*> no + ] + +instance (HasNullValue o, HasRandGen o) => HasRandGen [Com (AST_Object o)] where + randO = depthLimitedInt 24 >>= \x -> countNode $ randList 1 x + +instance Intermediate (ObjectExpr o) (AST_Object o) where + toInterm ast = case ast of + AST_Void -> [VoidExpr ] + AST_ObjLiteral a -> ObjLiteralExpr <$> ti a + AST_ObjSingle a -> [ObjSingleExpr ] <*> ti a + AST_ArithPfx a _ c loc -> [ArithPfxExpr ] <*> [a] <*> ti c <*> [loc] + AST_Init a b c loc -> [InitExpr ] <*> ti a <*> ti b <*> ti c <*> [loc] + AST_Struct a b loc -> [StructExpr ] <*> [a] <*> ti b <*> [loc] + AST_MetaEval a loc -> [MetaEvalExpr ] <*> ti a <*> [loc] + fromInterm o = case o of + VoidExpr -> [AST_Void ] + ObjLiteralExpr a -> AST_ObjLiteral <$> fi a + ObjSingleExpr a -> AST_ObjSingle <$> fi a + ArithPfxExpr a b loc -> [AST_ArithPfx ] <*> [a] <*> [[]] <*> fi b <*> [loc] + InitExpr a b c loc -> [AST_Init ] <*> fi a <*> fi b <*> fi c <*> [loc] + StructExpr a b loc -> [AST_Struct ] <*> [a] <*> fi b <*> [loc] + MetaEvalExpr a loc -> [AST_MetaEval ] <*> fi a <*> [loc] + +---------------------------------------------------------------------------------------------------- + +-- | Functions and function parameters can specify optional type-checking expressions. This is a +-- data type that wraps a dao-typeable expression with type information. +data TyChkExpr a o + = NotTypeChecked{tyChkItem::a} + -- ^ no type information was specified for this item + | TypeChecked {tyChkItem::a, tyChkExpr::ArithExpr o, tyChkLoc::Location} + -- ^ type check information was specified and should be checked every time it is evaluated. + | DisableCheck {tyChkItem::a, tyChkExpr::ArithExpr o, typChkResult::o, tyChkLoc::Location} + -- ^ type check information was specified but has been disabled for efficiency reasons because + -- we have verified that the item will always return a succesfull type-check. + deriving (Eq, Ord, Typeable, Show) + +checkedExpr :: TyChkExpr a o -> a +checkedExpr o = case o of + NotTypeChecked o -> o + TypeChecked o _ _ -> o + DisableCheck o _ _ _ -> o + +instance Functor (TyChkExpr a) where + fmap _ (NotTypeChecked a ) = NotTypeChecked a + fmap f (TypeChecked a b c ) = TypeChecked a (fmap f b) c + fmap f (DisableCheck a b c d) = DisableCheck a (fmap f b) (f c) d + +fmapCheckedValueExpr :: (a -> b) -> TyChkExpr a o -> TyChkExpr b o +fmapCheckedValueExpr f a = case a of + NotTypeChecked a -> NotTypeChecked (f a) + TypeChecked a b c -> TypeChecked (f a) b c + DisableCheck a b c d -> DisableCheck (f a) b c d + +instance (NFData o, NFData a) => NFData (TyChkExpr a o) where + rnf (NotTypeChecked a ) = deepseq a () + rnf (TypeChecked a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (DisableCheck a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + +instance (HasNullValue o, HasNullValue a) => HasNullValue (TyChkExpr a o) where + nullValue = NotTypeChecked nullValue + testNull (NotTypeChecked a) = testNull a + testNull _ = False + +instance HasLocation a => HasLocation (TyChkExpr a o) where + getLocation a = case a of + NotTypeChecked a -> getLocation a + TypeChecked a _ loc -> getLocation a <> loc + DisableCheck a _ _ loc -> getLocation a <> loc + setLocation a loc = case a of + NotTypeChecked a -> NotTypeChecked (setLocation a loc) + TypeChecked a b _ -> TypeChecked a b loc + DisableCheck a b c _ -> DisableCheck a b c loc + delLocation a = case a of + NotTypeChecked a -> NotTypeChecked (delLocation a) + TypeChecked a b _ -> TypeChecked (delLocation a) (delLocation b) LocationUnknown + DisableCheck a b c _ -> DisableCheck a b c LocationUnknown + +instance (PPrintable o, PPrintable a) => PPrintable (TyChkExpr a o) where + pPrint a = case a of + NotTypeChecked a -> pPrint a + TypeChecked a expr _ -> pInline [pPrint a, pString ": ", pPrint expr] + DisableCheck a _ _ _ -> pInline [pPrint a] + +---------------------------------------------------------------------------------------------------- + +-- | This node can be found in a few different syntactic structures. When a name or function or +-- expression is followed by a colon and some type checking information, this node is used for that +-- purpose. +data AST_TyChk a o + = AST_NotChecked a + | AST_Checked a (Com ()) (AST_Arith o) Location + deriving (Eq, Ord, Typeable, Show) + +checkedAST :: AST_TyChk a o -> a +checkedAST a = case a of { AST_NotChecked a -> a; AST_Checked a _ _ _ -> a; } + +astTyChkDelLocWith :: (a -> a) -> AST_TyChk a o -> AST_TyChk a o +astTyChkDelLocWith del a = case a of + AST_NotChecked a -> AST_NotChecked (del a) + AST_Checked a b c _ -> AST_Checked (del a) b (delLocation c) LocationUnknown + +instance Functor (AST_TyChk o) where + fmap _ (AST_NotChecked a ) = AST_NotChecked a + fmap f (AST_Checked a b c d) = AST_Checked a b (fmap f c) d + +fmapCheckedValueAST :: (a -> b) -> AST_TyChk a o -> AST_TyChk b o +fmapCheckedValueAST f a = case a of + AST_NotChecked a -> AST_NotChecked (f a) + AST_Checked a b c d -> AST_Checked (f a) b c d + +instance (NFData o, NFData a) => NFData (AST_TyChk a o) where + rnf (AST_NotChecked a) = deepseq a () + rnf (AST_Checked a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + +instance (HasNullValue o, HasNullValue a) => HasNullValue (AST_TyChk a o) where + nullValue = AST_NotChecked nullValue + testNull (AST_NotChecked a ) = testNull a + testNull (AST_Checked _ _ a _) = testNull a + +instance (PPrintable o, PPrintable a) => PPrintable (AST_TyChk a o) where + pPrint a = case a of + AST_NotChecked a -> pPrint a + AST_Checked a coms expr _ -> pInline $ + [ pPrint a + , pPrintComWith (\ () -> pString "::") coms + , pPrint expr + ] + +instance HasLocation a => HasLocation (AST_TyChk a o) where + getLocation a = case a of + AST_NotChecked a -> getLocation a + AST_Checked a _ _ loc -> getLocation a <> loc + setLocation a loc = case a of + AST_NotChecked a -> AST_NotChecked (setLocation a loc) + AST_Checked a b c _ -> AST_Checked a b c loc + delLocation = astTyChkDelLocWith delLocation + +instance (HasRandGen o, HasRandGen a) => HasRandGen (AST_TyChk a o) where + randO = countNode $ AST_NotChecked <$> randO + --randChoice = randChoiceList [AST_NotChecked <$> randO, return AST_Checked <*> randO <*> randO <*> randO <*> no] + defaultO = AST_NotChecked <$> defaultO + +tyChkToInterm :: (b -> [a]) -> AST_TyChk b o -> [TyChkExpr a o] +tyChkToInterm ti a = case a of + AST_NotChecked a -> NotTypeChecked <$> ti a + AST_Checked a _ b loc -> [TypeChecked] <*> ti a <*> toInterm b <*> [loc] + +tyChkFromInterm :: (a -> [b]) -> TyChkExpr a o -> [AST_TyChk b o] +tyChkFromInterm fi a = case a of + NotTypeChecked a -> AST_NotChecked <$> fi a + TypeChecked a b loc -> [AST_Checked] <*> fi a <*> [Com ()] <*> fromInterm b <*> [loc] + DisableCheck a b _ loc -> [AST_Checked] <*> fi a <*> [Com ()] <*> fromInterm b <*> [loc] + +---------------------------------------------------------------------------------------------------- + +-- | A list of function parameters (arguments) to a function in an object representing a function +-- expression. +data ParamListExpr o = ParamListExpr (TyChkExpr [ParamExpr o] o) Location + deriving (Eq, Ord, Typeable, Show) + +instance Functor ParamListExpr where + fmap f (ParamListExpr a loc) = + ParamListExpr (fmapCheckedValueExpr (fmap (fmap f)) $ fmap f a) loc + +instance NFData o => NFData (ParamListExpr o) where { rnf (ParamListExpr a b) = deepseq a $! deepseq b () } + +instance HasNullValue (ParamListExpr o) where + nullValue = ParamListExpr (NotTypeChecked []) LocationUnknown + testNull (ParamListExpr (NotTypeChecked []) _) = True + testNull _ = False + +instance HasLocation (ParamListExpr o) where + getLocation (ParamListExpr _ loc) = loc + setLocation (ParamListExpr a _ ) loc = ParamListExpr a loc + delLocation (ParamListExpr a _ ) = ParamListExpr a LocationUnknown + +instance PPrintable o => PPrintable (ParamListExpr o) where { pPrint (ParamListExpr lst _) = pPrint lst } + +getTypeCheckList :: ParamListExpr o -> [ParamExpr o] +getTypeCheckList (ParamListExpr tychk _) = tyChkItem tychk + +---------------------------------------------------------------------------------------------------- + +-- | 'ParamExpr' is a part of the Dao language semantics, and is also used in the the 'CallableCode' +-- data type when evaluating parameters to be passed to the callable code function execution. The +-- boolean parameter here indicates whether or not the parameter should be passed by reference. +data ParamExpr o = ParamExpr Bool (TyChkExpr Name o) Location deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (ParamExpr o) where + rnf (ParamExpr a b c) = deepseq a $! deepseq b $! deepseq c () + +instance HasLocation (ParamExpr o) where + getLocation (ParamExpr _ _ loc) = loc + setLocation (ParamExpr a b _ ) loc = ParamExpr a b loc + delLocation (ParamExpr a b _ ) = ParamExpr a b LocationUnknown + +instance PPrintable o => PPrintable (ParamExpr o) where + pPrint (ParamExpr byRef tychk _) = when byRef (pString "$") >> pPrint tychk + +instance PPrintable o => PPrintable [ParamExpr o] where { pPrint lst = pList_ "(" ", " ")" (fmap pPrint lst) } + +---------------------------------------------------------------------------------------------------- + +data AST_Param o + = AST_NoParams + | AST_Param (Maybe [Comment]) (AST_TyChk Name o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_Param o) where + rnf AST_NoParams = () + rnf (AST_Param a b c) = deepseq a $! deepseq b $! deepseq c () + +instance HasNullValue (AST_Param o) where + nullValue = AST_NoParams + testNull AST_NoParams = True + testNull _ = False + +instance HasLocation (AST_Param o) where + getLocation a = case a of + AST_NoParams -> LocationUnknown + AST_Param _ _ loc -> loc + setLocation a loc = case a of + AST_NoParams -> AST_NoParams + AST_Param a b _ -> AST_Param a b loc + delLocation a = case a of + AST_NoParams -> AST_NoParams + AST_Param a b _ -> AST_Param a (astTyChkDelLocWith delLocation b) LocationUnknown + +instance PPrintable o => PPrintable (AST_Param o) where + pPrint o = case o of + AST_NoParams -> return () + AST_Param mcoms tychk _ -> pInline $ + [ maybe (return ()) (\coms -> pString "$" >> pPrint coms) mcoms + , pPrint tychk + ] + +instance PPrintable o => PPrintable [Com (AST_Param o)] where + pPrint lst = pList_ "(" ", " ")" (fmap pPrint lst) + +---------------------------------------------------------------------------------------------------- + +instance HasRandGen o => HasRandGen (AST_Param o) where + randO = countNode $ return AST_Param <*> randO <*> randO <*> no + defaultO = return AST_Param <*> defaultO <*> defaultO <*> no + +instance HasRandGen o => HasRandGen [Com (AST_Param o)] where + randO = recurse $ depthLimitedInt 8 >>= \x -> randListOf 0 x scrambO + defaultO = defaultList 0 1 + +instance Intermediate (ParamExpr o) (AST_Param o) where + toInterm a = case a of + AST_NoParams -> [] + AST_Param a b loc -> + [ParamExpr] <*> [maybe False (const True) a] <*> tyChkToInterm return b <*> [loc] + fromInterm o = case o of + ParamExpr a b loc -> + [AST_Param] <*> [if a then Just [] else Nothing] <*> tyChkFromInterm return b <*> [loc] + +instance Intermediate [ParamExpr o] [Com (AST_Param o)] where + toInterm ax = [ax >>= toInterm . unComment] + fromInterm ax = [ax >>= fmap Com . fromInterm] + +---------------------------------------------------------------------------------------------------- + +data AST_ParamList o + = AST_ParamList (AST_TyChk [Com (AST_Param o)] o) Location + deriving (Eq, Ord, Typeable, Show) + +instance Functor AST_ParamList where + fmap f (AST_ParamList a loc) = + AST_ParamList (fmapCheckedValueAST (fmap (fmap (fmap f))) $ fmap f a) loc + +instance NFData o => NFData (AST_ParamList o) where { rnf (AST_ParamList a b) = deepseq a $! deepseq b () } + +instance HasNullValue o => HasNullValue (AST_ParamList o) where + nullValue = AST_ParamList nullValue LocationUnknown + testNull (AST_ParamList a _) = testNull a + +instance HasLocation (AST_ParamList o) where + getLocation (AST_ParamList _ loc) = loc + setLocation (AST_ParamList a _ ) loc = AST_ParamList a loc + delLocation (AST_ParamList a _ ) = AST_ParamList (astTyChkDelLocWith (fmap delLocation) a) LocationUnknown + +instance PPrintable o => PPrintable (AST_ParamList o) where + pPrint (AST_ParamList lst _) = pInline [pPrint lst] + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_ParamList o) where + randO = countNode $ return AST_ParamList <*> randO <*> no + defaultO = return $ AST_ParamList nullValue LocationUnknown + +instance Intermediate (ParamListExpr o) (AST_ParamList o) where + toInterm (AST_ParamList ox loc) = [ParamListExpr] <*> tyChkToInterm toInterm ox <*> [loc] + fromInterm (ParamListExpr ox loc) = [AST_ParamList] <*> tyChkFromInterm fromInterm ox <*> [loc] + +---------------------------------------------------------------------------------------------------- + +data RuleFuncExpr o + = LambdaExpr (ParamListExpr o) (CodeBlock o) Location + | FuncExpr Name (ParamListExpr o) (CodeBlock o) Location + | RuleExpr (RuleHeadExpr o) (CodeBlock o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (RuleFuncExpr o) where + rnf (LambdaExpr a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (FuncExpr a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + rnf (RuleExpr a b c ) = deepseq a $! deepseq b $! deepseq c () + +instance HasNullValue (RuleFuncExpr o) where + nullValue = LambdaExpr nullValue nullValue LocationUnknown + testNull (RuleExpr a b _) = testNull a && testNull b + testNull _ = False + +instance HasLocation (RuleFuncExpr o) where + getLocation o = case o of + LambdaExpr _ _ o -> o + FuncExpr _ _ _ o -> o + RuleExpr _ _ o -> o + setLocation o loc = case o of + LambdaExpr a b _ -> LambdaExpr a b loc + FuncExpr a b c _ -> FuncExpr a b c loc + RuleExpr a b _ -> RuleExpr a b loc + delLocation o = case o of + LambdaExpr a b _ -> LambdaExpr (delLocation a) (delLocation b) LocationUnknown + FuncExpr a b c _ -> FuncExpr a (delLocation b) (delLocation c) LocationUnknown + RuleExpr a b _ -> RuleExpr a (delLocation b) LocationUnknown + +instance PPrintable o => PPrintable (RuleFuncExpr o) where { pPrint = pPrintInterm } + +---------------------------------------------------------------------------------------------------- + +data AST_RuleFunc o + = AST_Lambda (Com (AST_ParamList o)) (AST_CodeBlock o) Location + | AST_Func [Comment] Name (Com (AST_ParamList o)) (AST_CodeBlock o) Location + | AST_Rule (Com (AST_RuleHeader o)) (AST_CodeBlock o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_RuleFunc o) where + rnf (AST_Lambda a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (AST_Func a b c d e) = deepseq a $! deepseq b $! deepseq c $! deepseq d $! deepseq e () + rnf (AST_Rule a b c ) = deepseq a $! deepseq b $! deepseq c () + +instance HasNullValue o => HasNullValue (AST_RuleFunc o) where + nullValue = AST_Lambda nullValue nullValue LocationUnknown + testNull (AST_Lambda a b _) = testNull a && testNull b + testNull _ = False + +instance HasLocation (AST_RuleFunc o) where + getLocation o = case o of + AST_Lambda _ _ o -> o + AST_Func _ _ _ _ o -> o + AST_Rule _ _ o -> o + setLocation o loc = case o of + AST_Lambda a b _ -> AST_Lambda a b loc + AST_Func a b c d _ -> AST_Func a b c d loc + AST_Rule a b _ -> AST_Rule a b loc + delLocation o = case o of + AST_Lambda a b _ -> AST_Lambda (delLocation a) (delLocation b) LocationUnknown + AST_Func a b c d _ -> AST_Func a b (delLocation c) (delLocation d) LocationUnknown + AST_Rule a b _ -> AST_Rule (delLocation a) (delLocation b) LocationUnknown + +instance PPrintable o => PPrintable (AST_RuleFunc o) where + pPrint expr = case expr of + AST_Lambda ccNmx xcObjXp _ -> + pPrintSubBlock (pInline [pString "function", pPrintComWith pPrint ccNmx]) xcObjXp + AST_Func co nm ccNmx xcObjXp _ -> + pClosure (pInline [pString "function ", pPrint co, pPrint nm, pPrint ccNmx]) "{" "}" [pPrint xcObjXp] + AST_Rule ccNmx xcObjXp _ -> pClosure (pPrint ccNmx) "{" "}" [pPrint xcObjXp] + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_RuleFunc o) where + randO = recurse $ countNode $ runRandChoice + randChoice = randChoiceList $ + [ scramble $ return AST_Lambda <*> randO <*> randO <*> no + , scramble $ return AST_Func <*> randO <*> randO <*> randO <*> randO <*> no + , scramble $ return AST_Rule <*> randO <*> randO <*> no + ] + defaultO = runDefaultChoice + defaultChoice = randChoiceList $ + [ scramble $ return AST_Lambda <*> defaultO <*> defaultO <*> no + , scramble $ return AST_Func <*> defaultO <*> defaultO <*> defaultO <*> defaultO <*> no + , scramble $ return AST_Rule <*> defaultO <*> defaultO <*> no + ] + +instance Intermediate (RuleFuncExpr o) (AST_RuleFunc o) where + toInterm ast = case ast of + AST_Lambda a b loc -> [LambdaExpr] <*> uc0 a <*> ti b <*> [loc] + AST_Func _ a b c loc -> [FuncExpr] <*> [a] <*> uc0 b <*> ti c <*> [loc] + AST_Rule a b loc -> [RuleExpr] <*> uc0 a <*> ti b <*> [loc] + fromInterm o = case o of + LambdaExpr a b loc -> [AST_Lambda] <*> nc0 a <*> fi b <*> [loc] + FuncExpr a b c loc -> [AST_Func] <*> [[]] <*> [a] <*> nc0 b <*> fi c <*> [loc] + RuleExpr a b loc -> [AST_Rule] <*> nc0 a <*> fi b <*> [loc] + +---------------------------------------------------------------------------------------------------- + +data RuleHeadExpr o + = RuleStringExpr UStr Location + | RuleHeadExpr [AssignExpr o] Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance HasNullValue (RuleHeadExpr o) where + nullValue = RuleStringExpr nil LocationUnknown + testNull (RuleStringExpr a _) = a==nil + testNull _ = False + +instance HasLocation (RuleHeadExpr o) where + getLocation o = case o of + RuleStringExpr _ o -> o + RuleHeadExpr _ o -> o + setLocation o loc = case o of + RuleStringExpr o _ -> RuleStringExpr o loc + RuleHeadExpr o _ -> RuleHeadExpr o loc + delLocation o = case o of + RuleStringExpr o _ -> RuleStringExpr o LocationUnknown + RuleHeadExpr o _ -> RuleHeadExpr (fmap delLocation o) LocationUnknown + +instance NFData o => NFData (RuleHeadExpr o) where + rnf (RuleStringExpr a b) = deepseq a $! deepseq b () + rnf (RuleHeadExpr a b) = deepseq a $! deepseq b () + +---------------------------------------------------------------------------------------------------- + +data AST_RuleHeader o + = AST_NullRules [Comment] Location + | AST_RuleString (Com UStr) Location + | AST_RuleHeader [Com (AST_Assign o)] Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_RuleHeader o) where + rnf (AST_NullRules a b) = deepseq a $! deepseq b () + rnf (AST_RuleString a b) = deepseq a $! deepseq b () + rnf (AST_RuleHeader a b) = deepseq a $! deepseq b () + +instance HasNullValue (AST_RuleHeader o) where + nullValue = AST_NullRules [] LocationUnknown + testNull (AST_NullRules _ _) = True + testNull _ = False + +instance HasLocation (AST_RuleHeader o) where + getLocation o = case o of + AST_NullRules _ o -> o + AST_RuleString _ o -> o + AST_RuleHeader _ o -> o + setLocation o loc = case o of + AST_NullRules a _ -> AST_NullRules a loc + AST_RuleString a _ -> AST_RuleString a loc + AST_RuleHeader a _ -> AST_RuleHeader a loc + delLocation o = case o of + AST_NullRules a _ -> AST_NullRules a LocationUnknown + AST_RuleString a _ -> AST_RuleString a LocationUnknown + AST_RuleHeader a _ -> AST_RuleHeader (fmap delLocation a) LocationUnknown + +instance PPrintable o => PPrintable (AST_RuleHeader o) where + pPrint o = case o of + AST_NullRules coms _ -> pInline [pString "rule(", pPrint coms, pString ")"] + AST_RuleString r _ -> pInline [pString "rule ", pPrintComWith pShow r, pString " "] + AST_RuleHeader ruls _ -> pList (pString "rule") "(" ", " ")" (fmap pPrint ruls) + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_RuleHeader o) where + randO = countNode $ runRandChoice + randChoice = randChoiceList $ + [ return AST_RuleHeader <*> randList 0 3 <*> no + , return AST_RuleString <*> randO <*> no + , return AST_NullRules <*> scrambO <*> no + ] + defaultO = runDefaultChoice + defaultChoice = randChoiceList $ + [ return AST_NullRules <*> defaultO <*> no + , return AST_RuleString <*> defaultO <*> no + ] + +instance Intermediate (RuleHeadExpr o) (AST_RuleHeader o) where + toInterm o = case o of + AST_NullRules _ loc -> [RuleHeadExpr [] loc] + AST_RuleString o loc -> [RuleStringExpr (unComment o) loc] + AST_RuleHeader o loc -> [RuleHeadExpr] <*> [o>>=uc0] <*> [loc] + fromInterm o = case o of + RuleHeadExpr [] loc -> [AST_NullRules [] loc] + RuleStringExpr o loc -> [AST_RuleString (Com o) loc] + RuleHeadExpr o loc -> [AST_RuleHeader] <*> [o>>=nc0] <*> [loc] + +---------------------------------------------------------------------------------------------------- + +-- | Defined such that the instantiation of 'CodeBlock' into the 'Executable' class executes each +-- 'ScriptExpr' in the 'CodeBlock', one after the other. Execution does not +-- occur within a 'execNested' because many other expressions which execute 'CodeBlock's, +-- especially 'TryCatch' expressions and 'ForLoop's need to be able to choose +-- when the stack is pushed so they can define temporary local variables. +newtype CodeBlock o = CodeBlock { codeBlock :: [ScriptExpr o] } + deriving (Eq, Ord, Show, Typeable, Functor) + +instance NFData o => NFData (CodeBlock o) where { rnf (CodeBlock a) = deepseq a () } + +instance Monoid (CodeBlock o) where + mempty = CodeBlock [] + mappend a b = CodeBlock (mappend (codeBlock a) (codeBlock b)) + +instance HasNullValue (CodeBlock o) where + nullValue = mempty + testNull (CodeBlock []) = True + testNull _ = False + +instance HasLocation (CodeBlock o) where + getLocation o = case codeBlock o of + [] -> LocationUnknown + [o] -> getLocation o + o:ox -> mappend (getLocation o) (getLocation (foldl (flip const) o ox)) + setLocation o _ = o + delLocation o = CodeBlock (fmap delLocation (codeBlock o)) + +instance PPrintable o => PPrintable (CodeBlock o) where { pPrint = pPrintInterm } + +---------------------------------------------------------------------------------------------------- + +-- | This node in the AST typically represents the list of 'AST_Script' expressions found between +-- curly-brackets in expressions like "if" and "else" statement, "for" statements and "while" +-- statements, "with" satements, "try" and "catch" statements and function declrataions. +newtype AST_CodeBlock o = AST_CodeBlock{ getAST_CodeBlock :: [AST_Script o] } + deriving (Eq, Ord, Typeable, Show, Functor) + -- A code block is never standing on it's own, it is always part of a larger expression, so there + -- is no 'Dao.Token.Location' parameter for 'AST_CodeBlock'. + +instance Monoid (AST_CodeBlock o) where + mempty = AST_CodeBlock [] + mappend a b = AST_CodeBlock (mappend (getAST_CodeBlock a) (getAST_CodeBlock b)) + +instance NFData o => NFData (AST_CodeBlock o) where { rnf (AST_CodeBlock a) = deepseq a () } + +instance HasNullValue (AST_CodeBlock o) where + nullValue = AST_CodeBlock [] + testNull (AST_CodeBlock a) = null a + +instance HasLocation (AST_CodeBlock o) where + getLocation o = case getAST_CodeBlock o of + [] -> LocationUnknown + [o] -> getLocation o + o:ox -> mappend (getLocation o) (getLocation (foldl (flip const) o ox)) + setLocation o _ = o + delLocation o = AST_CodeBlock (fmap delLocation (getAST_CodeBlock o)) + +-- 'pPrintComWith' wasn't good enough for this, because the comments might occur after the header +-- but before the opening bracket. +pPrintComCodeBlock :: PPrintable o => PPrint -> Com (AST_CodeBlock o) -> PPrint +pPrintComCodeBlock header c = case c of + Com c -> run [] c [] + ComBefore bx c -> run bx c [] + ComAfter c ax -> run [] c ax + ComAround bx c ax -> run bx c ax + where + run :: PPrintable o => [Comment] -> (AST_CodeBlock o) -> [Comment] -> PPrint + run before cx after = case getAST_CodeBlock cx of + [] -> header >> pInline (map pPrint before) >> pString " {}" >> pInline (map pPrint after) + cx -> do + pClosure (header >> pInline (map pPrint before)) " { " " }" (map (pGroup True . pPrint) cx) + pInline (map pPrint after) + +pPrintSubBlock :: PPrintable o => PPrint -> (AST_CodeBlock o) -> PPrint +pPrintSubBlock header px = pPrintComCodeBlock header (Com px) + +instance PPrintable o => PPrintable (AST_CodeBlock o) where { pPrint o = mapM_ pPrint (getAST_CodeBlock o) } + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_CodeBlock o) where + randO = countNode $ AST_CodeBlock . concat <$> sequence [return <$> scrambO, depthLimitedInt 16 >>= \x -> randList 0 x] + defaultO = return $ AST_CodeBlock [] + +instance Intermediate (CodeBlock o) (AST_CodeBlock o) where + toInterm (AST_CodeBlock ast) = [CodeBlock $ ast >>= toInterm ] + fromInterm (CodeBlock obj) = [AST_CodeBlock $ obj >>= fromInterm] + +---------------------------------------------------------------------------------------------------- + +data IfExpr o = IfExpr (ParenExpr o) (CodeBlock o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (IfExpr o) where { rnf (IfExpr a b c) = deepseq a $! deepseq b $! deepseq c () } + +instance HasNullValue (IfExpr o) where + nullValue = IfExpr nullValue nullValue LocationUnknown + testNull (IfExpr a b _) = testNull a && testNull b + +instance HasLocation (IfExpr o) where + getLocation (IfExpr _ _ loc) = loc + setLocation (IfExpr a b _ ) loc = IfExpr a b loc + delLocation (IfExpr a b _ ) = IfExpr (delLocation a) (delLocation b) LocationUnknown + +---------------------------------------------------------------------------------------------------- + +data AST_If o = AST_If (Com (AST_Paren o)) (AST_CodeBlock o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_If o) where { rnf (AST_If a b c) = deepseq a $! deepseq b $! deepseq c () } + +instance HasLocation (AST_If o) where + getLocation (AST_If _ _ loc) = loc + setLocation (AST_If a b _ ) loc = AST_If a b loc + delLocation (AST_If a b _ ) = AST_If (delLocation a) (delLocation b) LocationUnknown + +instance HasNullValue (AST_If o) where + nullValue = AST_If nullValue nullValue LocationUnknown + testNull (AST_If a b _) = testNull a && testNull b + +instance PPrintable o => PPrintable (AST_If o) where + pPrint (AST_If ifn thn _) = + pClosure (pString "if" >> pPrint ifn) "{" "}" [pPrint thn] + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_If o) where + randO = countNode $ return AST_If <*> randO <*> randO <*> no + defaultO = return AST_If <*> defaultO <*> defaultO <*> no + +instance Intermediate (IfExpr o) (AST_If o) where + toInterm (AST_If a b loc) = [IfExpr] <*> uc0 a <*> ti b <*> [loc] + fromInterm (IfExpr a b loc) = [AST_If] <*> nc0 a <*> fi b <*> [loc] + +---------------------------------------------------------------------------------------------------- + +data ElseExpr o = ElseExpr (IfExpr o) Location deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (ElseExpr o) where { rnf (ElseExpr a b ) = deepseq a $! deepseq b $! () } + +instance HasNullValue (ElseExpr o) where + nullValue = ElseExpr nullValue LocationUnknown + testNull (ElseExpr a _) = testNull a + +instance HasLocation (ElseExpr o) where + getLocation (ElseExpr _ loc) = loc + setLocation (ElseExpr a _ ) loc = ElseExpr a loc + delLocation (ElseExpr a _ ) = ElseExpr (delLocation a) LocationUnknown + +---------------------------------------------------------------------------------------------------- + +data AST_Else o = AST_Else (Com ()) (AST_If o) Location deriving (Eq, Ord, Typeable, Show, Functor) + -- ^ @/**/ else /**/ if /**/ obj /**/ {}@ + +instance NFData o => NFData (AST_Else o) where { rnf (AST_Else a b c) = deepseq a $! deepseq b $! deepseq c () } + +instance HasNullValue (AST_Else o) where + nullValue = AST_Else nullValue nullValue LocationUnknown + testNull (AST_Else a b _) = testNull a && testNull b + +instance HasLocation (AST_Else o) where + getLocation (AST_Else _ _ loc) = loc + setLocation (AST_Else a b _ ) loc = AST_Else a b loc + delLocation (AST_Else a b _ ) = AST_Else a (delLocation b) LocationUnknown + +instance PPrintable o => PPrintable (AST_Else o) where + pPrint (AST_Else coms (AST_If ifn thn _) _) = + pClosure (pPrintComWith (\ () -> pString "else ") coms >> pString "if" >> pPrint ifn) "{" "}" [pPrint thn] + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Else o) where + randO = countNode $ return AST_Else <*> randO <*> randO <*> no + defaultO = return AST_Else <*> defaultO <*> defaultO <*> no + +instance Intermediate (ElseExpr o) (AST_Else o) where + toInterm (AST_Else _ a loc) = [ElseExpr] <*> ti a <*> [loc] + fromInterm (ElseExpr a loc) = [AST_Else] <*> [Com ()] <*> fi a <*> [loc] + +---------------------------------------------------------------------------------------------------- + +data IfElseExpr o = IfElseExpr (IfExpr o) [ElseExpr o] (Maybe (LastElseExpr o)) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (IfElseExpr o) where + rnf (IfElseExpr a b c d ) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + +instance HasNullValue (IfElseExpr o) where + nullValue = IfElseExpr nullValue [] Nothing LocationUnknown + testNull (IfElseExpr a [] Nothing _) = testNull a + testNull _ = False + +instance HasLocation (IfElseExpr o) where + getLocation (IfElseExpr _ _ _ loc) = loc + setLocation (IfElseExpr a b c _ ) loc = IfElseExpr a b c loc + delLocation (IfElseExpr a b c _ ) = + IfElseExpr (delLocation a) (fmap delLocation b) (fmap delLocation c) LocationUnknown + +---------------------------------------------------------------------------------------------------- + +data AST_IfElse o = AST_IfElse (AST_If o) [AST_Else o] (Maybe (AST_LastElse o)) Location + -- ^ @if /**/ obj /**/ {} /**/ else /**/ if /**/ obj /**/ {} /**/ else {}@ + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_IfElse o) where + rnf (AST_IfElse a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + +instance HasNullValue (AST_IfElse o) where + nullValue = AST_IfElse nullValue [] Nothing LocationUnknown + testNull (AST_IfElse a [] Nothing _) = testNull a + testNull _ = False + +instance HasLocation (AST_IfElse o) where + getLocation (AST_IfElse _ _ _ loc) = loc + setLocation (AST_IfElse a b c _ ) loc = AST_IfElse a b c loc + delLocation (AST_IfElse a b c _ ) = AST_IfElse (delLocation a) (fmap delLocation b) (fmap delLocation c) LocationUnknown + +instance PPrintable o => PPrintable (AST_IfElse o) where + pPrint (AST_IfElse ifn els deflt _) = do + pPrint ifn >> pNewLine + mapM_ pPrint els >> pNewLine + maybe (return ()) pPrint deflt + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_IfElse o) where + randO = countNode $ depthLimitedInt 8 >>= \x -> + return AST_IfElse <*> randO <*> randList 0 x <*> randO <*> no + defaultO = return AST_IfElse <*> defaultO <*> defaultList 0 1 <*> randO <*> no + +instance Intermediate (IfElseExpr o) (AST_IfElse o) where + toInterm (AST_IfElse a b c loc) = + [IfElseExpr] <*> ti a <*> [b>>=ti] <*> um1 c <*> [loc] + fromInterm (IfElseExpr a b c loc) = + [AST_IfElse] <*> fi a <*> [b>>=fi] <*> nm1 c <*> [loc] + +---------------------------------------------------------------------------------------------------- + +data LastElseExpr o = LastElseExpr (CodeBlock o) Location + deriving (Eq, Ord, Show, Typeable, Functor) + +instance NFData o => NFData (LastElseExpr o) where + rnf (LastElseExpr a b) = deepseq a $! deepseq b () + +instance HasNullValue (LastElseExpr o) where + nullValue = LastElseExpr nullValue LocationUnknown + testNull (LastElseExpr o _) = testNull o + +instance HasLocation (LastElseExpr o) where + getLocation (LastElseExpr _ loc) = loc + setLocation (LastElseExpr a _ ) loc = LastElseExpr a loc + delLocation (LastElseExpr a _ ) = LastElseExpr (delLocation a) LocationUnknown + +---------------------------------------------------------------------------------------------------- + +data AST_LastElse o = AST_LastElse (Com ()) (AST_CodeBlock o) Location + deriving (Eq, Ord, Show, Typeable, Functor) + +instance NFData o => NFData (AST_LastElse o) where + rnf (AST_LastElse a b c) = deepseq a $! deepseq b $! deepseq c () + +instance HasNullValue (AST_LastElse o) where + nullValue = AST_LastElse (Com ()) nullValue LocationUnknown + testNull (AST_LastElse a b _) = testNull a && testNull b + +instance HasLocation (AST_LastElse o) where + getLocation (AST_LastElse _ _ loc) = loc + setLocation (AST_LastElse a b _ ) loc = AST_LastElse a b loc + delLocation (AST_LastElse a b _ ) = AST_LastElse a (delLocation b) LocationUnknown + +instance PPrintable o => PPrintable (AST_LastElse o) where + pPrint (AST_LastElse coms code _) = + pClosure (pPrintComWith (\ () -> pString "else") coms) "{" "}" [pPrint code] + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_LastElse o) where + randO = countNode $ return AST_LastElse <*> randO <*> randO <*> no + randChoice = randChoiceList [randO] + defaultO = return AST_LastElse <*> defaultO <*> defaultO <*> no + defaultChoice = randChoiceList [defaultO] + +instance Intermediate (LastElseExpr o) (AST_LastElse o) where + toInterm (AST_LastElse _ o loc) = [LastElseExpr] <*> toInterm o <*> [loc] + fromInterm (LastElseExpr o loc) = [AST_LastElse] <*> [Com ()] <*> fromInterm o <*> [loc] + +---------------------------------------------------------------------------------------------------- + +data CatchExpr o = CatchExpr (ParamExpr o) (CodeBlock o) Location + deriving (Eq, Ord, Show, Typeable, Functor) + +instance NFData o => NFData (CatchExpr o) where + rnf (CatchExpr a b c) = deepseq a $! deepseq b $! deepseq c () + +instance HasLocation (CatchExpr o) where + getLocation (CatchExpr _ _ loc) = loc + setLocation (CatchExpr a b _ ) loc = CatchExpr a b loc + delLocation (CatchExpr a b _ ) = CatchExpr (delLocation a) (delLocation b) LocationUnknown + +---------------------------------------------------------------------------------------------------- + +data AST_Catch o = AST_Catch [Comment] (Com (AST_Param o)) (AST_CodeBlock o) Location + deriving (Eq, Ord, Show, Typeable, Functor) + +instance NFData o => NFData (AST_Catch o) where + rnf (AST_Catch a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + +instance HasLocation (AST_Catch o) where + getLocation (AST_Catch _ _ _ loc) = loc + setLocation (AST_Catch a b c _ ) loc = AST_Catch a b c loc + delLocation (AST_Catch a b c _ ) = AST_Catch a (delLocation b) (delLocation c) LocationUnknown + +instance PPrintable o => PPrintable (AST_Catch o) where + pPrint (AST_Catch coms param code _) = pPrint coms >> + pClosure (pString "catch " >> pPrint param) "{" "}" [pPrint code] + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Catch o) where + randO = countNode $ return AST_Catch <*> randO <*> randO <*> randO <*> no + randChoice = randChoiceList [randO] + defaultO = return AST_Catch <*> defaultO <*> defaultO <*> defaultO <*> no + defaultChoice = randChoiceList [defaultO] + +instance Intermediate (CatchExpr o) (AST_Catch o) where + toInterm (AST_Catch _ a b loc) = [CatchExpr] <*> uc0 a <*> ti b <*> [loc] + fromInterm (CatchExpr a b loc) = [AST_Catch] <*> [[]] <*> nc0 a <*> fi b <*> [loc] + +---------------------------------------------------------------------------------------------------- + +newtype WhileExpr o = WhileExpr (IfExpr o) deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (WhileExpr o) where { rnf (WhileExpr (IfExpr a b c)) = deepseq a $! deepseq b $! deepseq c () } + +instance HasNullValue (WhileExpr o) where + nullValue = WhileExpr nullValue + testNull (WhileExpr a) = testNull a + +instance HasLocation (WhileExpr o) where + getLocation (WhileExpr a) = getLocation a + setLocation (WhileExpr a) loc = WhileExpr (setLocation a loc) + delLocation (WhileExpr a) = WhileExpr (delLocation a) + +---------------------------------------------------------------------------------------------------- + +newtype AST_While o = AST_While (AST_If o) deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_While o) where { rnf (AST_While (AST_If a b c)) = deepseq a $! deepseq b $! deepseq c () } + +instance HasNullValue (AST_While o) where + nullValue = AST_While nullValue + testNull (AST_While a) = testNull a + +instance HasLocation (AST_While o) where + getLocation (AST_While a) = getLocation a + setLocation (AST_While a) loc = AST_While (setLocation a loc) + delLocation (AST_While a) = AST_While (delLocation a) + +instance PPrintable o => PPrintable (AST_While o) where + pPrint (AST_While (AST_If ifn thn _)) = + pClosure (pInline [pString "while", pPrint ifn]) "{" "}" [pPrint thn] + +instance Intermediate (WhileExpr o) (AST_While o) where + toInterm (AST_While a) = WhileExpr <$> ti a + fromInterm (WhileExpr a) = AST_While <$> fi a + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_While o) where + randO = AST_While <$> randO + defaultO = AST_While <$> defaultO + +---------------------------------------------------------------------------------------------------- + +-- | Part of the Dao language abstract syntax tree: any expression that controls the flow of script +-- exectuion. +data ScriptExpr o + = IfThenElse (IfElseExpr o) + | WhileLoop (WhileExpr o) + | RuleFuncExpr (RuleFuncExpr o) + | EvalObject (AssignExpr o) Location -- location of the semicolon + | TryCatch (CodeBlock o) [LastElseExpr o] [CatchExpr o] Location + | ForLoop Name (RefPrefixExpr o) (CodeBlock o) Location + | ContinueExpr Bool (AssignExpr o) Location + | ReturnExpr Bool (AssignExpr o) Location + | WithDoc (ParenExpr o) (CodeBlock o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (ScriptExpr o) where + rnf (IfThenElse a ) = deepseq a () + rnf (WhileLoop a ) = deepseq a () + rnf (RuleFuncExpr a ) = deepseq a () + rnf (EvalObject a b ) = deepseq a $! deepseq b () + rnf (TryCatch a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + rnf (ForLoop a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + rnf (ContinueExpr a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (ReturnExpr a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (WithDoc a b c ) = deepseq a $! deepseq b $! deepseq c () + +instance HasNullValue o => HasNullValue (ScriptExpr o) where + nullValue = EvalObject nullValue LocationUnknown + testNull (EvalObject a _) = testNull a + testNull _ = False + +instance HasLocation (ScriptExpr o) where + getLocation o = case o of + EvalObject _ o -> o + IfThenElse o -> getLocation o + RuleFuncExpr o -> getLocation o + WhileLoop o -> getLocation o + TryCatch _ _ _ o -> o + ForLoop _ _ _ o -> o + ContinueExpr _ _ o -> o + ReturnExpr _ _ o -> o + WithDoc _ _ o -> o + setLocation o loc = case o of + EvalObject a _ -> EvalObject a loc + IfThenElse a -> IfThenElse (setLocation a loc) + WhileLoop a -> WhileLoop (setLocation a loc) + RuleFuncExpr a -> RuleFuncExpr (setLocation a loc) + TryCatch a b c _ -> TryCatch a b c loc + ForLoop a b c _ -> ForLoop a b c loc + ContinueExpr a b _ -> ContinueExpr a b loc + ReturnExpr a b _ -> ReturnExpr a b loc + WithDoc a b _ -> WithDoc a b loc + delLocation o = case o of + EvalObject a _ -> EvalObject (delLocation a) LocationUnknown + IfThenElse a -> IfThenElse (delLocation a) + WhileLoop a -> WhileLoop (delLocation a) + RuleFuncExpr a -> RuleFuncExpr (delLocation a) + TryCatch a b c _ -> TryCatch (delLocation a) (fmap delLocation b) (fmap delLocation c) LocationUnknown + ForLoop a b c _ -> ForLoop a (delLocation b) (delLocation c) LocationUnknown + ContinueExpr a b _ -> ContinueExpr a (delLocation b) LocationUnknown + ReturnExpr a b _ -> ReturnExpr a (delLocation b) LocationUnknown + WithDoc a b _ -> WithDoc (delLocation a) (delLocation b) LocationUnknown + +---------------------------------------------------------------------------------------------------- + +-- | Part of the Dao language abstract syntax tree: any expression that controls the flow of script +-- exectuion. +data AST_Script o + = AST_Comment [Comment] + | AST_IfThenElse (AST_IfElse o) + | AST_WhileLoop (AST_While o) + | AST_RuleFunc (AST_RuleFunc o) + | AST_EvalObject (AST_Assign o) [Comment] Location + -- ^ @some.object.expression = for.example - equations || function(calls) /**/ ;@ + | AST_TryCatch [Comment] (AST_CodeBlock o) [AST_LastElse o] [AST_Catch o] Location + -- ^ @try /**/ {} /**/ else /**/ {} /**/ catch /**/ errVar /**/ {}@ + | AST_ForLoop (Com Name) (Com (AST_RefPrefix o)) (AST_CodeBlock o) Location + -- ^ @for /**/ var /**/ in /**/ objExpr /**/ {}@ + | AST_ContinueExpr Bool [Comment] (Com (AST_Assign o)) Location + -- ^ The boolean parameter is True for a "continue" statement, False for a "break" statement. + -- @continue /**/ ;@ or @continue /**/ if /**/ objExpr /**/ ;@ + | AST_ReturnExpr Bool (Com (AST_Assign o)) Location + -- ^ The boolean parameter is True for a "return" statement, False for a "throw" statement. + -- ^ @return /**/ ;@ or @return /**/ objExpr /**/ ;@ + | AST_WithDoc (Com (AST_Paren o)) (AST_CodeBlock o) Location + -- ^ @with /**/ objExpr /**/ {}@ + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (AST_Script o) where + rnf (AST_Comment a ) = deepseq a () + rnf (AST_IfThenElse a ) = deepseq a () + rnf (AST_WhileLoop a ) = deepseq a () + rnf (AST_RuleFunc a ) = deepseq a () + rnf (AST_EvalObject a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (AST_TryCatch a b c d e) = deepseq a $! deepseq b $! deepseq c $! deepseq d $! deepseq e () + rnf (AST_ForLoop a b c d ) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + rnf (AST_ContinueExpr a b c d ) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + rnf (AST_ReturnExpr a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (AST_WithDoc a b c ) = deepseq a $! deepseq b $! deepseq c () + +instance HasNullValue (AST_Script o) where + nullValue = AST_EvalObject nullValue [] LocationUnknown + testNull (AST_EvalObject a _ _) = testNull a + testNull _ = False + +instance HasLocation (AST_Script o) where + getLocation o = case o of + AST_Comment _ -> LocationUnknown + AST_EvalObject _ _ o -> o + AST_IfThenElse o -> getLocation o + AST_WhileLoop o -> getLocation o + AST_RuleFunc o -> getLocation o + AST_TryCatch _ _ _ _ o -> o + AST_ForLoop _ _ _ o -> o + AST_ContinueExpr _ _ _ o -> o + AST_ReturnExpr _ _ o -> o + AST_WithDoc _ _ o -> o + setLocation o loc = case o of + AST_Comment a -> AST_Comment a + AST_EvalObject a b _ -> AST_EvalObject a b loc + AST_IfThenElse a -> AST_IfThenElse (setLocation a loc) + AST_WhileLoop a -> AST_WhileLoop (setLocation a loc) + AST_RuleFunc a -> AST_RuleFunc (setLocation a loc) + AST_TryCatch a b c d _ -> AST_TryCatch a b c d loc + AST_ForLoop a b c _ -> AST_ForLoop a b c loc + AST_ContinueExpr a b c _ -> AST_ContinueExpr a b c loc + AST_ReturnExpr a b _ -> AST_ReturnExpr a b loc + AST_WithDoc a b _ -> AST_WithDoc a b loc + delLocation o = case o of + AST_Comment a -> AST_Comment a + AST_EvalObject a b _ -> AST_EvalObject (delLocation a) b LocationUnknown + AST_IfThenElse a -> AST_IfThenElse (delLocation a) + AST_WhileLoop a -> AST_WhileLoop (delLocation a) + AST_RuleFunc a -> AST_RuleFunc (delLocation a) + AST_TryCatch a b c d _ -> AST_TryCatch a (delLocation b) (fmap delLocation c) (fmap delLocation d) LocationUnknown + AST_ForLoop a b c _ -> AST_ForLoop a (fmap delLocation b) (delLocation c) LocationUnknown + AST_ContinueExpr a b c _ -> AST_ContinueExpr a b (fmap delLocation c) LocationUnknown + AST_ReturnExpr a b _ -> AST_ReturnExpr a (fmap delLocation b) LocationUnknown + AST_WithDoc a b _ -> AST_WithDoc (fmap delLocation a) (delLocation b) LocationUnknown + +instance PPrintable o => PPrintable (AST_Script o) where + pPrint expr = pGroup True $ case expr of + AST_Comment coms -> mapM_ pPrint coms + AST_EvalObject objXp coms _ -> + pPrint objXp >> mapM_ pPrint coms >> pString ";" + AST_IfThenElse ifXp -> pPrint ifXp + AST_WhileLoop whileLoop -> pPrint whileLoop + AST_RuleFunc ruleOrFunc -> pPrint ruleOrFunc + AST_TryCatch coms scrpXp elsXp catchExpr _ -> do + pClosure (pString "try" >> pPrint coms) "{" "}" [pPrint scrpXp] + mapM_ (\o -> pPrint o >> pEndLine) elsXp + mapM_ (\o -> pPrint o >> pEndLine) catchExpr + AST_ForLoop cNm cObjXp xcScrpXp _ -> + pPrintSubBlock (pString "for " >> pPrint cNm >> pString " in " >> pPrint cObjXp) xcScrpXp + AST_ContinueExpr contin coms cObjXp _ -> pWrapIndent $ + [ pString (if contin then "continue" else "break") + , pInline (map pPrint coms) + , case unComment cObjXp of + AST_Eval (AST_ObjArith (AST_Object AST_Void)) -> return () + _ -> pString " if" >> when (precedeWithSpace cObjXp) (pString " ") >> pPrint cObjXp + , pString ";" + ] + AST_ReturnExpr retrn cObjXp _ -> pWrapIndent $ + [pString (if retrn then "return " else "throw "), pPrint cObjXp, pString ";"] + AST_WithDoc cObjXp xcScrpXp _ -> + pPrintSubBlock (pString "with " >> pPrint cObjXp) xcScrpXp + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Script o) where + randO = countNode $ recurse $ runRandChoice + randChoice = randChoiceList $ + [ return AST_EvalObject <*> randO <*> randO <*> no + , return AST_IfThenElse <*> randO + , return AST_WhileLoop <*> randO + , return AST_RuleFunc <*> randO + , scramble $ depthLimitedInt 4 >>= \x -> depthLimitedInt 4 >>= \y -> + return AST_TryCatch <*> randO <*> randO <*> randList 0 x <*> randList 0 y <*> no + , scramble $ return AST_ForLoop <*> randO <*> randO <*> randO <*> no + , scramble $ return AST_ContinueExpr <*> randO <*> randO <*> randO <*> no + , scramble $ return AST_ReturnExpr <*> randO <*> randO <*> no + , scramble $ return AST_WithDoc <*> randO <*> randO <*> no + ] + defaultO = runDefaultChoice + defaultChoice = randChoiceList $ + [ AST_IfThenElse <$> defaultO + , AST_WhileLoop <$> defaultO + , AST_RuleFunc <$> defaultO + , return AST_TryCatch <*> pure [] <*> defaultO <*> defaultList 0 1 <*> defaultList 0 1 <*> no + , return AST_ContinueExpr <*> defaultO <*> defaultO <*> defaultO <*> no + , return AST_ReturnExpr <*> defaultO <*> defaultO <*> no + ] + +instance PPrintable o => PPrintable (ScriptExpr o) where { pPrint = pPrintInterm } + +instance Intermediate (ScriptExpr o) (AST_Script o) where + toInterm ast = case ast of + AST_Comment _ -> mzero + AST_EvalObject a _ loc -> [EvalObject ] <*> ti a <*> [loc] + AST_IfThenElse a -> [IfThenElse ] <*> ti a + AST_WhileLoop a -> [WhileLoop ] <*> ti a + AST_RuleFunc a -> [RuleFuncExpr] <*> ti a + AST_TryCatch _ a b c loc -> [TryCatch ] <*> ti a <*> mapM ti b <*> mapM ti c <*> [loc] + AST_ForLoop a b c loc -> [ForLoop ] <*> uc a <*> uc0 b <*> ti c <*> [loc] + AST_ContinueExpr a _ c loc -> [ContinueExpr] <*> [a] <*> uc0 c <*> [loc] + AST_ReturnExpr a b loc -> [ReturnExpr ] <*> [a] <*> uc0 b <*> [loc] + AST_WithDoc a b loc -> [WithDoc ] <*> uc0 a <*> ti b <*> [loc] + fromInterm obj = case obj of + EvalObject a loc -> [AST_EvalObject ] <*> fi a <*> [[]] <*> [loc] + IfThenElse a -> AST_IfThenElse <$> fi a + WhileLoop a -> AST_WhileLoop <$> fi a + RuleFuncExpr a -> AST_RuleFunc <$> fi a + TryCatch a b c loc -> [AST_TryCatch ] <*> [[]] <*> fi a <*> mapM fi b <*> mapM fi c <*> [loc] + ForLoop a b c loc -> [AST_ForLoop ] <*> nc a <*> nc0 b <*> fi c <*> [loc] + ContinueExpr a b loc -> [AST_ContinueExpr] <*> [a] <*> [[]] <*> nc0 b <*> [loc] + ReturnExpr a b loc -> [AST_ReturnExpr ] <*> [a] <*> nc0 b <*> [loc] + WithDoc a b loc -> [AST_WithDoc ] <*> nc0 a <*> fi b <*> [loc] + +---------------------------------------------------------------------------------------------------- + +data AttributeExpr + = AttribDotNameExpr DotLabelExpr + | AttribStringExpr UStr Location + deriving (Eq, Ord, Show, Typeable) + +instance NFData AttributeExpr where + rnf (AttribDotNameExpr a ) = deepseq a () + rnf (AttribStringExpr a b) = deepseq a $! deepseq b () + +instance HasNullValue AttributeExpr where + nullValue = AttribStringExpr nil LocationUnknown + testNull (AttribStringExpr a _) = a==nil + testNull _ = False + +instance HasLocation AttributeExpr where + getLocation o = case o of + AttribDotNameExpr o -> getLocation o + AttribStringExpr _ loc -> loc + setLocation o loc = case o of + AttribDotNameExpr o -> AttribDotNameExpr (setLocation o loc) + AttribStringExpr o _ -> AttribStringExpr o loc + delLocation o = case o of + AttribDotNameExpr o -> AttribDotNameExpr (delLocation o) + AttribStringExpr o _ -> AttribStringExpr o LocationUnknown + +instance PPrintable AttributeExpr where { pPrint = pPrintInterm } + +---------------------------------------------------------------------------------------------------- + +data AST_Attribute + = AST_AttribDotName AST_DotLabel + | AST_AttribString UStr Location + deriving (Eq, Ord, Show, Typeable) + +instance NFData AST_Attribute where + rnf (AST_AttribDotName a ) = deepseq a () + rnf (AST_AttribString a b) = deepseq a $! deepseq b () + +instance HasNullValue AST_Attribute where + nullValue = AST_AttribString nil LocationUnknown + testNull (AST_AttribString a _) = a==nil + testNull _ = False + +instance HasLocation AST_Attribute where + getLocation o = case o of + AST_AttribDotName o -> getLocation o + AST_AttribString _ loc -> loc + setLocation o loc = case o of + AST_AttribDotName o -> AST_AttribDotName (setLocation o loc) + AST_AttribString o _ -> AST_AttribString o loc + delLocation o = case o of + AST_AttribDotName o -> AST_AttribDotName (delLocation o) + AST_AttribString o _ -> AST_AttribString o LocationUnknown + +instance PPrintable AST_Attribute where + pPrint o = case o of + AST_AttribDotName nm -> pPrint nm + AST_AttribString str _ -> pPrint str + +instance HasRandGen AST_Attribute where + randChoice = randChoiceList $ + [ AST_AttribDotName <$> randO + , return AST_AttribString <*> randO <*> no + ] + randO = countNode $ runRandChoice + defaultO = randO + defaultChoice = randChoiceList [defaultO] + +instance Intermediate AttributeExpr AST_Attribute where + toInterm o = case o of + AST_AttribDotName a -> AttribDotNameExpr <$> ti a + AST_AttribString a loc -> [AttribStringExpr a loc] + fromInterm o = case o of + AttribDotNameExpr a -> AST_AttribDotName <$> fi a + AttribStringExpr a loc -> [AST_AttribString a loc] + +---------------------------------------------------------------------------------------------------- + +data TopLevelEventType + = BeginExprType | EndExprType | ExitExprType + deriving (Eq, Ord, Typeable, Enum) + +instance Show TopLevelEventType where + show t = case t of + BeginExprType -> "BEGIN" + EndExprType -> "END" + ExitExprType -> "EXIT" + +instance Read TopLevelEventType where + readsPrec _ str = map (\t -> (t, "")) $ case str of + "BEGIN" -> [BeginExprType] + "END" -> [EndExprType] + "EXIT" -> [ExitExprType] + _ -> [] + +instance NFData TopLevelEventType where { rnf a = seq a () } + +instance HasRandGen TopLevelEventType where + randO = fmap toEnum (nextInt 3) + defaultO = randO + +---------------------------------------------------------------------------------------------------- + +-- | A 'TopLevelExpr' is a single declaration for the top-level of the program file. A Dao 'SourceCode' +-- is a list of these directives. +data TopLevelExpr o + = RequireExpr AttributeExpr Location + | ImportExpr AttributeExpr NamespaceExpr Location + | TopScript (ScriptExpr o) Location + | EventExpr TopLevelEventType (CodeBlock o) Location + deriving (Eq, Ord, Typeable, Show, Functor) + +instance NFData o => NFData (TopLevelExpr o) where + rnf (RequireExpr a b ) = deepseq a $! deepseq b () + rnf (ImportExpr a b c) = deepseq a $! deepseq b $! deepseq c () + rnf (TopScript a b ) = deepseq a $! deepseq b () + rnf (EventExpr a b c) = deepseq a $! deepseq b $! deepseq c () + +instance HasNullValue o => HasNullValue (TopLevelExpr o) where + nullValue = TopScript nullValue LocationUnknown + testNull (TopScript a LocationUnknown) = testNull a + testNull _ = False + +isAttribute :: TopLevelExpr o -> Bool +isAttribute toplevel = case toplevel of { RequireExpr{} -> True; ImportExpr{} -> True; _ -> False; } + +instance HasLocation (TopLevelExpr o) where + getLocation o = case o of + RequireExpr _ o -> o + ImportExpr _ _ o -> o + TopScript _ o -> o + EventExpr _ _ o -> o + setLocation o loc = case o of + RequireExpr a _ -> RequireExpr a loc + ImportExpr a b _ -> ImportExpr a b loc + TopScript a _ -> TopScript a loc + EventExpr a b _ -> EventExpr a b loc + delLocation o = case o of + RequireExpr a _ -> RequireExpr (delLocation a) LocationUnknown + ImportExpr a b _ -> ImportExpr (delLocation a) (delLocation b) LocationUnknown + TopScript a _ -> TopScript (delLocation a) LocationUnknown + EventExpr a b _ -> EventExpr a (delLocation b) LocationUnknown + +instance PPrintable o => PPrintable (TopLevelExpr o) where { pPrint = pPrintInterm } + +---------------------------------------------------------------------------------------------------- + +-- | A 'AST_TopLevel' is a single declaration for the top-level of the program file. A Dao 'SourceCode' +-- is a list of these directives. +data AST_TopLevel o + = AST_Require (Com AST_Attribute) Location + | AST_Import (Com AST_Attribute) AST_Namespace Location + | AST_TopScript (AST_Script o) Location + | AST_Event TopLevelEventType [Comment] (AST_CodeBlock o) Location + | AST_TopComment [Comment] + deriving (Eq, Ord, Typeable, Show, Functor) + +instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_TopLevel o) where + randO = countNode $ runRandChoice + randChoice = randChoiceList $ + [ return AST_Require <*> randO <*> no + , return AST_Import <*> randO <*> randO <*> no + , return AST_TopScript <*> randO <*> no + , return AST_Event <*> randO <*> randO <*> randO <*> no + , AST_TopComment <$> defaultO + ] + defaultO = runDefaultChoice + defaultChoice = randChoiceList $ + [ return AST_Import <*> defaultO <*> defaultO <*> no + , return AST_Require <*> defaultO <*> no + , return AST_TopScript <*> defaultO <*> no + , return AST_Event <*> defaultO <*> defaultO <*> defaultO <*> no + ] + +instance Intermediate (TopLevelExpr o) (AST_TopLevel o) where + toInterm ast = case ast of + AST_Require a loc -> [RequireExpr] <*> uc0 a <*> [loc] + AST_Import a b loc -> [ImportExpr ] <*> uc0 a <*> ti b <*> [loc] + AST_TopScript a loc -> [TopScript ] <*> ti a <*> [loc] + AST_Event a _ b loc -> [EventExpr ] <*> [a] <*> ti b <*> [loc] + AST_TopComment _loc -> mzero + fromInterm obj = case obj of + RequireExpr a loc -> [AST_Require ] <*> nc0 a <*> [loc] + ImportExpr a b loc -> [AST_Import ] <*> nc0 a <*> fi b <*> [loc] + TopScript a loc -> [AST_TopScript] <*> fi a <*> [loc] + EventExpr a b loc -> [AST_Event ] <*> [a] <*> [[]] <*> fi b <*> [loc] + +isAST_Attribute :: AST_TopLevel o -> Bool +isAST_Attribute o = case o of { AST_Require{} -> True; AST_Import{} -> True; _ -> False; } + +-- | Split a list of 'AST_TopLevel' items into a tripple, the "require" statements, the "import" +-- statements. This function scans the list lazily and returns as soon as an 'AST_TopLevel' item in +-- the list is found that is not one of 'AST_Require', 'AST_Import' or 'AST_TopComment'. +-- +-- Notice that this function takes an 'AST_TopLevel' and returns a list of 'AttributeExpr's, not a +-- list of 'AST_Attribute's. This is because this function is designed for assisting in evaluation +-- of the import statements of a Dao script file, specifically in order to generate a dependency +-- graph. +getRequiresAndImports :: [AST_TopLevel o] -> ([AttributeExpr], [(AttributeExpr, NamespaceExpr)]) +getRequiresAndImports = loop [] [] where + loop requires imports ox = case ox of + AST_Require a _ : ox -> loop (requires ++ uc0 a) imports ox + AST_Import a b _ : ox -> loop requires (imports ++ (pure (,) <*> uc0 a <*> toInterm b)) ox + AST_TopComment{} : ox -> loop requires imports ox + _ -> (requires, imports) + +instance NFData o => NFData (AST_TopLevel o) where + rnf (AST_Require a b ) = deepseq a $! deepseq b () + rnf (AST_Import a b c ) = deepseq a $! deepseq b $! deepseq c () + rnf (AST_TopScript a b ) = deepseq a $! deepseq b () + rnf (AST_Event a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + rnf (AST_TopComment a ) = deepseq a () + +instance HasNullValue (AST_TopLevel o) where + nullValue = AST_TopScript nullValue LocationUnknown + testNull (AST_TopScript a _) = testNull a + testNull _ = False + +instance HasLocation (AST_TopLevel o) where + getLocation o = case o of + AST_Require _ o -> o + AST_Import _ _ o -> o + AST_TopScript _ o -> o + AST_Event _ _ _ o -> o + AST_TopComment _ -> LocationUnknown + setLocation o loc = case o of + AST_Require a _ -> AST_Require a loc + AST_Import a b _ -> AST_Import a b loc + AST_TopScript a _ -> AST_TopScript a loc + AST_Event a b c _ -> AST_Event a b c loc + AST_TopComment a -> AST_TopComment a + delLocation o = case o of + AST_Require a _ -> AST_Require (delLocation a) LocationUnknown + AST_Import a b _ -> AST_Import (delLocation a) (delLocation b) LocationUnknown + AST_TopScript a _ -> AST_TopScript (delLocation a) LocationUnknown + AST_Event a b c _ -> AST_Event a b (delLocation c) LocationUnknown + AST_TopComment a -> AST_TopComment a + +instance PPrintable o => PPrintable (AST_TopLevel o) where + pPrint o = case o of + AST_Require a _ -> pWrapIndent [pString "require ", pPrint a, pString ";"] + AST_Import a b _ -> pWrapIndent [pString "import ", pPrint a, pPrint b, pString ";"] + AST_TopScript a _ -> pPrint a + AST_Event a b c _ -> pClosure (pShow a >> mapM_ pPrint b) " { " " }" (map pPrint (getAST_CodeBlock c)) + AST_TopComment a -> mapM_ (\a -> pPrint a >> pNewLine) a + +---------------------------------------------------------------------------------------------------- + +-- | A program is just a list of 'TopLevelExpr's. It serves as the 'Intermediate' +-- representation of a 'AST_SourceCode'. +newtype Program o = Program { topLevelExprs :: [TopLevelExpr o] } deriving (Eq, Ord, Typeable) + +instance Show o => Show (Program o) where { show (Program o) = unlines (map show o) } + +instance HasNullValue (Program o) where + nullValue = Program [] + testNull (Program p) = null p + +instance HasLocation (Program o) where + getLocation o = case topLevelExprs o of + [] -> LocationUnknown + [o] -> getLocation o + o:ox -> mappend (getLocation o) (getLocation (foldl (flip const) o ox)) + setLocation o _ = o + delLocation o = Program (fmap delLocation (topLevelExprs o)) + +---------------------------------------------------------------------------------------------------- + +-- | A 'SourceCode' is the structure loaded from source code. An 'ExecUnit' object is constructed from +-- 'SourceCode'. +data AST_SourceCode o + = AST_SourceCode + { sourceModified :: Int + , sourceFullPath :: UStr + -- ^ the URL (full file path) from where this source code was received. + , directives :: [AST_TopLevel o] + } + deriving (Eq, Ord, Typeable) + +instance NFData o => NFData (AST_SourceCode o) where + rnf (AST_SourceCode a b c) = deepseq a $! deepseq b $! deepseq c () + +instance HasNullValue (AST_SourceCode o) where + nullValue = (AST_SourceCode 0 nil []) + testNull (AST_SourceCode 0 a []) | a==nil = True + testNull _ = False + +instance PPrintable o => PPrintable (AST_SourceCode o) where + pPrint sc = do + let (attrs, dirs) = span isAST_Attribute (directives sc) + mapM_ pPrint attrs + pForceNewLine + mapM_ (\dir -> pPrint dir >> pForceNewLine) dirs + +instance Intermediate (Program o) (AST_SourceCode o) where + toInterm ast = [Program $ directives ast >>= toInterm] + fromInterm obj = return $ + AST_SourceCode + { sourceModified = 0 + , sourceFullPath = nil + , directives = topLevelExprs obj >>= fromInterm + } + diff --git a/src/Dao/Interpreter/Parser.hs b/src/Dao/Interpreter/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Interpreter/Parser.hs @@ -0,0 +1,831 @@ +-- "src/Dao/Interpreter/Parser.hs" makes use of "Dao.Parser" to parse +-- parse 'Dao.Interpreter.AST' expressions. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +{-# LANGUAGE MultiParamTypeClasses #-} + +module Dao.Interpreter.Parser where + +import Dao.String +import Dao.Token +import Dao.PPrint +import Dao.Interpreter hiding (opt) +import Dao.Interpreter.AST +import Dao.Interpreter.Tokenizer +import Dao.Predicate +import Dao.Parser + +import Control.Applicative +import Control.Monad +import Control.Monad.Error +import Control.Monad.State + +import Data.Monoid +import Data.Maybe +import Data.List +import Data.Char +import Data.Ratio +import Data.Complex + +maxYears :: Integer +maxYears = 99999 + +type DaoParser a = Parser DaoParState DaoTT a +type DaoTableItem a = TableItem DaoTT (DaoParser a) +type DaoPTable a = PTable DaoTT (DaoParser a) +type DaoParseErr = ParseError DaoParState DaoTT + +---------------------------------------------------------------------------------------------------- + +data DaoParState + = DaoParState + { bufferedComments :: Maybe [Comment] + , nonHaltingErrors :: [DaoParseErr] + , internalState :: Maybe (TokStreamState DaoParState DaoTT) + } + +instance Monoid DaoParState where + mappend a b = + b{ bufferedComments = bufferedComments a >>= \a -> bufferedComments b >>= \b -> return (a++b) + , nonHaltingErrors = nonHaltingErrors a ++ nonHaltingErrors b + , internalState = internalState b + } + mempty = + DaoParState + { bufferedComments = Nothing + , nonHaltingErrors = [] + , internalState = Nothing + } + +instance PPrintable DaoParState where { pPrint _ = return () } + +setCommentBuffer :: [Comment] -> DaoParser () +setCommentBuffer coms = modify $ \st -> + st{ bufferedComments = (if null coms then mzero else return coms) <> bufferedComments st } + +failLater :: String -> Location -> DaoParser () +failLater msg loc = catchError (fail msg) $ \err -> modify $ \st -> + st{nonHaltingErrors = + nonHaltingErrors st ++ [err{parseStateAtErr=Nothing, parseErrLoc=loc}]} + +---------------------------------------------------------------------------------------------------- + +spaceComPTab :: DaoPTable [Comment] +spaceComPTab = table $ + [ tableItem SPACE (return . const [] . as0) + , tableItem INLINECOM (\c -> return [InlineComment $ asUStr c]) + , tableItem ENDLINECOM (\c -> return [EndlineComment $ asUStr c]) + ] + +-- | Parses an arbitrary number of space and comment tokens, comments are returned. Backtracks if +-- there are no comments. +space :: DaoParser [Comment] +space = do + st <- Control.Monad.State.get + case bufferedComments st of + Just coms -> put (st{bufferedComments=mempty}) >> return coms + Nothing -> fmap concat $ many (joinEvalPTable spaceComPTab) + +-- The 'space' parser backtracks if there are no spaces, which is important to prevent infinite +-- recursion in some situations. The 'optSpace' evalautes 'space' but returns an empty list of +-- 'space' backtracks, so 'optSpace' never backtracks. +optSpace :: DaoParser [Comment] +optSpace = mplus space (return []) + +-- | Evaluates a 'DaoParser' within a cluster of optional spaces and comments, returning the result +-- of the parser wrapped in a 'Dao.Interpreter.Com' constructor. If the given 'DaoParser' backtracks, the +-- comments that were parsed before the 'DaoParser' was evaluated are buffered so a second call two +-- successive calls to this function return immediately. For example in an expression like: +-- > 'Control.Monad.msum' ['commented' p1, 'commented' p2, ... , 'commented' pN] +-- The spaces and comments occurring before the parsers @p1@, @p2@, ... , @pN@ are only being parsed +-- once, no matter how many parser are tried. +commented :: DaoParser a -> DaoParser (Com a) +commented parser = do + before <- mplus space (return []) + flip mplus (setCommentBuffer before >> mzero) $ do + result <- parser + after <- mplus space (return []) + return (com before result after) + +-- Take comments of the stream, but do not return them, instead just buffer them. This is a good way +-- to do a look-ahead past comments without deleting comments. If the next parser evaluated +-- immediately after this one is 'commented', the comments buffered by this function will be +-- returned with the object parsed by 'commented'. This is necessary in parse tables where the table +-- needs an operator token to select the next parser in the table, but the returned operator token +-- must be preceeded by possible comments. +bufferComments :: DaoParser () +bufferComments = mplus (space >>= setCommentBuffer) (return ()) + +---------------------------------------------------------------------------------------------------- + +rationalFromString :: Int -> Rational -> String -> Maybe Rational +rationalFromString maxValue base str = + if b<1 then fmap (b*) (fol (reverse str)) else fol str where + b = abs base + maxVal = abs maxValue + fol = foldl shiftAdd (return 0) + shiftAdd result nextChar = do + x <- result + y <- convertChar nextChar + if y>=maxVal then mzero else return (x*b + (toInteger y % 1)) + convertChar a = case a of + a | isDigit a -> return (ord a - ord '0') + a | isLower a -> return (ord a - ord 'a' + 10) + a | isUpper a -> return (ord a - ord 'A' + 10) + _ -> mzero + +numberFromStrs :: Int -> String -> Maybe String -> Maybe String -> Maybe String -> DaoParser Object +numberFromStrs base int maybFrac maybPlusMinusExp maybTyp = do + let frac = maybe "" id (maybFrac >>= stripPrefix ".") + strprfx = foldl (\f s t -> f (maybe t id (stripPrefix s t))) id . words + plusMinusExp = fromMaybe "" (fmap (strprfx ".e .E e E") maybPlusMinusExp) + typ = fromMaybe "" maybTyp + (exp, hasMinusSign) = case plusMinusExp of + "" -> ("" , False) + p:exp | p=='+' -> (exp, False) + | p=='-' -> (exp, True ) + exp -> (exp, False) + b = toInteger base % 1 + rational = do + x <- rationalFromString base b int + y <- rationalFromString base (recip b) frac + exp <- fmap (round . abs) (rationalFromString base b exp) :: Maybe Integer + let ibase = if hasMinusSign then recip b else b + result = (x+y)*(ibase^^exp) + return (round result % 1 == result, result) + (_r_is_an_integer, r) <- case rational of + Nothing -> fail ("incorrect digits used to form a base-"++show base++" number") + Just r -> return r + case typ of + "U" -> return $ OWord (round r) + "I" -> return $ OInt (round r) + "L" -> return $ OLong (round r) + "R" -> return $ ORatio r + "F" -> return $ OFloat (fromRational r) + "f" -> return $ OFloat (fromRational r) + "i" -> return $ OComplex $ Complex $ 0 :+ fromRational r + "j" -> return $ OComplex $ Complex $ 0 :+ fromRational r + "s" -> return $ ORelTime (fromRational r) + "" -> + return (OInt (round r)) +-- if r_is_an_integer && null frac +-- then +-- let i = round r +-- in if fromIntegral (minBound::T_int) <= i && i <= fromIntegral (maxBound::T_int) +-- then return $ OInt $ fromIntegral i +-- else return $ OLong i +-- else return (ORatio r) + typ -> fail ("unknown numeric type "++show typ) + +---------------------------------------------------------------------------------------------------- + +-- | Compute diff times from strings representing days, hours, minutes, and seconds. The seconds +-- value may have a decimal point. +diffTimeFromStrs :: String -> DaoParser T_diffTime +diffTimeFromStrs time = do + let [hours,minutes,secMils] = split [] time + (seconds, dot_mils) = break (=='.') secMils + miliseconds = dropWhile (=='.') dot_mils + hours <- check "hours" 24 hours + minutes <- check "minutes" 60 minutes + let sec = check "seconds" 60 + seconds <- + if null miliseconds + then sec seconds + else do + seconds <- sec seconds + return (seconds + rint miliseconds % (10 ^ length miliseconds)) + return $ fromRational (60*60*hours + 60*minutes + seconds) + where + split buf str = case break (==':') str of + (t, "" ) -> reverse $ take 3 $ (t:buf) ++ repeat "" + (t, ':':str) -> split (t:buf) str + (_, _ ) -> error "unexpected character while parsing time-literal expression" + rint str = if null str then 0 else (read str :: Integer) + integerToRational s = s % 1 :: Rational + check :: String -> Integer -> String -> DaoParser Rational + check typ maxVal s = do + let i = rint s + zero = return (0%1) + ok = return (integerToRational i) + err = fail $ concat ["time value expression with ", s, " ", typ, " is invalid"] + if null s then zero else if i do + frac <- optional (token DOTBASE10 id) + exp <- optional (token EXPONENT id) + typ <- optional (token NUMTYPE id) + done tok 10 (asString tok) (mstr frac) (mstr exp) (mstr typ) (return (asLocation tok) <> mloc frac <> mloc exp <> mloc typ) + , tableItem DOTBASE10 $ \tok -> do + exp <- optional (token EXPONENT id) + typ <- optional (token NUMTYPE id) + done tok 10 "" (Just (asString tok)) (mstr exp) (mstr typ) (return (asLocation tok) <> mloc exp <> mloc typ) + , tableItemBy "date" $ \startTok -> + expect "date/time value expression after \"date\" statement" $ do + token SPACE as0 + date <- token DATE id + let optsp tok = optional $ + token SPACE id >>= \s -> mplus (token tok id) (unshift s >> mzero) + time <- optsp TIME + zone <- optsp LABEL + let loc = asLocation startTok <> + maybe LocationUnknown id (fmap asLocation time <> fmap asLocation zone) + astr = (' ':) . asString + timeAndZone = maybe " 00:00:00" astr time ++ maybe "" astr zone + case readsPrec 0 (asString date ++ timeAndZone) of + [(o, "")] -> return (AST_Literal (OAbsTime o) loc) + _ -> fail "invalid UTC-time expression" + , tableItemBy "time" $ \startTok -> expect "UTC-time value after \"time\" statement" $ do + token SPACE as0 + tok <- token TIME id + time <- diffTimeFromStrs (asString tok) + return (AST_Literal (ORelTime time) (asLocation startTok <> asLocation tok)) + ] + where + mloc = fmap asLocation + mstr = fmap asString + base b t = tableItem t $ \tok -> do + typ <- optional (token NUMTYPE id) + done tok b (drop 2 (asString tok)) Nothing Nothing (mstr typ) (return (asLocation tok) <> mloc typ) + done tok base int frac exp typ loc = do + num <- numberFromStrs base int frac exp typ + let endLoc = asLocation tok + return (AST_Literal num (maybe endLoc id loc)) + +numberPTab :: DaoPTable (AST_Literal Object) +numberPTab = table numberPTabItems + +-- | Parsing numerical literals +number :: DaoParser (AST_Literal Object) +number = joinEvalPTable numberPTab + +singletonPTab :: DaoPTable (AST_Literal Object) +singletonPTab = table singletonPTabItems + +parenPTabItem :: DaoTableItem (AST_Paren Object) +parenPTabItem = tableItemBy "(" $ \tok -> do + o <- commented assignment + expect "closing parentheses" $ do + endloc <- tokenBy ")" asLocation + return (AST_Paren o (asLocation tok <> endloc)) + +paren :: DaoParser (AST_Paren Object) +paren = joinEvalPTableItem parenPTabItem + +metaEvalPTabItem :: DaoTableItem (AST_Object Object) +metaEvalPTabItem = tableItemBy "${" $ \startTok -> expect "object expression after open ${ meta-eval brace" $ do + scrp <- fmap (AST_CodeBlock . concat) (many script) + expect "closing } for meta-eval brace" $ do + endLoc <- tokenBy "}" asLocation + return (AST_MetaEval scrp (asLocation startTok <> endLoc)) + +singletonPTabItems :: [DaoTableItem (AST_Literal Object)] +singletonPTabItems = numberPTabItems ++ + [ tableItem STRINGLIT (literal $ OString . read . asString) + , tableItem CHARLIT (literal $ OChar . read . asString) + , trueFalse "null" ONull, trueFalse "false" ONull, trueFalse "true" OTrue + , reserved "operator", reserved "public", reserved "private" + ] + where + literal constr tok = return (AST_Literal (constr tok) (asLocation tok)) + trueFalse lbl obj = tableItemBy lbl $ \tok -> return (AST_Literal obj (asLocation tok)) + reserved key = tableItemBy key $ fail $ + "keyword "++show key++" is reserved for future use, not implemented in this version of Dao" + +-- Objects that are parsed as a single value, which includes all literal expressions and equtions in +-- parentheses. +singleton :: DaoParser (AST_Literal Object) +singleton = joinEvalPTable singletonPTab + +-- Returns an AST_ObjList, which is a constructor that contains leading whitespace/comments. However +-- this function is a 'DaoTableItem' parser, which means the first token parsed must be the opening +-- bracket. In order to correctly parse the leading whitespace/comments while also correctly +-- identifying the opening bracket token, it is expected that you have called 'bufferComments' +-- immediately before this function is evaluated. +commaSepdObjList :: String -> String -> String -> DaoTableItem (AST_ObjList Object) +commaSepdObjList msg open close = tableItemBy open $ \startTok -> do + let startLoc = asLocation startTok + coms <- optSpace -- the comments must have been buffered by this point, otherwise the parser behaves strangely. + (lst, endLoc) <- commaSepd ("arguments to "++msg) close (return . com [] nullValue) assignment id + return (AST_ObjList coms lst (startLoc<>endLoc)) + +ruleFuncPTab :: DaoPTable (AST_RuleFunc Object) +ruleFuncPTab = table $ + [ tableItemBy "rule" $ \startTok -> + expect "list of strings after \"rule\" statement" $ do + lst <- commented $ joinEvalPTable $ table $ + [ tableItem STRINGLIT $ \str -> return $ AST_RuleString (Com $ read $ uchars $ asUStr str) (asLocation str) + , fmap (\ (AST_ObjList coms lst loc) -> + if null lst then AST_NullRules coms loc else AST_RuleHeader lst loc + ) <$> commaSepdObjList "rule header" "(" ")" + ] + expect "bracketed expression after rule header" $ do + (scrpt, endLoc) <- bracketed ("script expression for \"rule\" statement") + return $ AST_Rule lst scrpt (asLocation startTok <> endLoc) + , lambdaFunc "func", lambdaFunc "function" + ] + where + lambdaFunc lbl = tableItemBy lbl $ \startTok -> + expect ("parameters and bracketed script after \""++lbl++"\" statement") $ do + constr <- mplus (pure AST_Func <*> optSpace <*> token LABEL asName) (return AST_Lambda) + params <- commented paramList + (scrpt, endLoc) <- bracketed ("script expression after \""++lbl++"\" statement") + return $ constr params scrpt (asLocation startTok <> endLoc) + +ruleFunc :: DaoParser (AST_RuleFunc Object) +ruleFunc = joinEvalPTable ruleFuncPTab + +-- Objects that are parsed as a single value but which are constructed from other object +-- expressions. This table excludes 'singletonPTab'. +containerPTab :: DaoPTable (AST_Object Object) +containerPTab = table [metaEvalPTabItem] + +-- None of the functions related to parameters and type checking parse with tables because there is +-- simply no need for it according to the Dao language syntax. +typeCheckParser :: a -> DaoParser (AST_TyChk a Object) +typeCheckParser a = flip mplus (return (AST_NotChecked a)) $ do + com1 <- commented (tokenBy "::" id) + let startLoc = asLocation (unComment com1) + expect "type expression after colon operator" $ arithmetic >>= \obj -> return $ + AST_Checked a (fmap as0 com1) obj (startLoc <> getLocation obj) + +typeCheckedName :: DaoParser (AST_TyChk Name Object) +typeCheckedName = token LABEL id >>= \tok -> + fmap (\tychk -> setLocation tychk (asLocation tok <> getLocation tychk)) $ + typeCheckParser (asName tok) + +parameter :: DaoParser (AST_Param Object) +parameter = msum $ + [ do startLoc <- tokenBy "$" asLocation + coms <- optional space + item <- typeCheckedName + return $ AST_Param coms item (startLoc <> getLocation item) + , typeCheckedName >>= \nm -> return $ AST_Param Nothing nm (getLocation nm) + ] + +paramList :: DaoParser (AST_ParamList Object) +paramList = do + startLoc <- tokenBy "(" asLocation + (lst, loc) <- commaSepd "parameter value" ")" (return . com [] AST_NoParams) parameter id + lst <- typeCheckParser lst + return (AST_ParamList lst (startLoc <> loc)) + +singletonOrContainerPTab :: DaoPTable (AST_Object Object) +singletonOrContainerPTab = fmap (fmap AST_ObjLiteral) singletonPTab <> containerPTab + +singletonOrContainer :: DaoParser (AST_Object Object) +singletonOrContainer = joinEvalPTable singletonOrContainerPTab + +---------------------------------------------------------------------------------------------------- + +commaSepd :: (UStrType str, UStrType errmsg) => + errmsg -> str -> ([Comment] -> b) -> DaoParser a -> ([Com a] -> b) -> DaoParser (b, Location) +commaSepd errMsg close voidVal parser constr = + msum [commented parser >>= loop . (:[]), parseComEmpty, parseClose [] [], err] where + parseComEmpty = space >>= parseClose [] + parseClose stack c = do + loc <- tokenBy close asLocation + return (if null stack && null c then constr stack else if null c then constr stack else voidVal c, loc) + loop stack = flip mplus (parseClose stack []) $ do + token COMMA as0 + o <- commented (expect errMsg parser) + loop (stack++[o]) + err = fail $ "unknown token while parsing list of items for "++uchars errMsg + +-- More than one parser has need of 'commaSepd' as a parameter to 'commented', but passing +-- 'commaSped' to 'commented' will return a value of type: +-- > 'Dao.Interpreter.Com' (['Dao.Interpreter.Com'], 'Dao.Parser.Location') +-- which is not useful for constructors of the abstract syntax tree. This function takes the +-- comments around the pair and maps the first item of the pair to the comments, returning an +-- uncommented pair. +commentedInPair :: DaoParser (a, Location) -> DaoParser (Com a, Location) +commentedInPair parser = do + comntd <- commented parser + let (a, loc) = unComment comntd + return (fmap (const a) comntd, loc) + +-- You MUST have evaluated 'bufferComments' before evaluating any of the parsers in this table. +-- 'refSuffix' does this. +refSuffixPTabItems :: [DaoTableItem (AST_RefSuffix Object)] +refSuffixPTabItems = + [ tableItemBy "." $ \tok -> do + comBefore <- optSpace -- get comments before dot that were buffered by 'bufferComments' + comAfter <- optSpace -- get comments after the dot + expect "valid identifier after dot token" $ do + name <- token LABEL id + suf <- refSuffix + let loc = asLocation tok <> getLocation suf + return $ AST_DotRef (com comBefore () comAfter) (asName name) suf loc + , p "subscript expression" "[" "]" AST_Subscript + , p "function call expression" "(" ")" AST_FuncCall + ] + where + p msg open close constr = bindPTableItem (commaSepdObjList msg open close) $ \olst -> + refSuffix >>= \suf -> return $ constr olst suf + +refSuffixPTab :: DaoPTable (AST_RefSuffix Object) +refSuffixPTab = table refSuffixPTabItems + +refSuffix :: DaoParser (AST_RefSuffix Object) +refSuffix = bufferComments >> joinEvalPTable refSuffixPTab <|> return AST_RefNull + +referencePTabItems :: [DaoTableItem (AST_Reference Object)] +referencePTabItems = + [ p "local" LOCAL, p "const" CONST, p "static" STATIC, p "global" GLOBAL, p "." GLODOT + , tableItem LABEL $ \name -> do + suf <- refSuffix + return $ AST_Reference UNQUAL [] (asName name) suf (asLocation name) + , bindPTableItem parenPTabItem $ \o -> refSuffix >>= \suf -> return $ + AST_RefObject o suf (getLocation o <> getLocation suf) + ] + where + p opstr op = tableItemBy opstr $ \tok -> + expect ("reference expression after "++show opstr++" qualifier") $ do + coms <- optSpace + name <- token LABEL id + suf <- refSuffix + return $ AST_Reference op coms (asName name) suf (asLocation tok <> asLocation name) + +referencePTab :: DaoPTable (AST_Reference Object) +referencePTab = table referencePTabItems + +referenceParser :: DaoParser (AST_Reference Object) +referenceParser = joinEvalPTable referencePTab + +refPrefixPTabItems :: [DaoTableItem (AST_RefPrefix Object)] +refPrefixPTabItems = [p "$" REF, p "@" DEREF] where + p opstr op = tableItemBy opstr $ \tok -> + expect ("reference expression after"++show opstr++" token") $ do + coms <- optSpace + ref <- refPrefixParser + return $ AST_RefPrefix op coms ref (asLocation tok <> getLocation ref) + +refPrefixPTab :: DaoPTable (AST_RefPrefix Object) +refPrefixPTab = table refPrefixPTabItems <> (fmap (\o -> AST_PlainRef o) <$> referencePTab) + +refPrefixParser :: DaoParser (AST_RefPrefix Object) +refPrefixParser = joinEvalPTable refPrefixPTab + +initPTab :: DaoPTable (AST_Object Object) +initPTab = bindPTable refPrefixPTab $ \o -> let single = return (AST_ObjSingle o) in case o of + AST_PlainRef ref -> case refToDotLabelAST ref of + Just (ref, inits) -> (bufferComments>>) $ flip mplus single $ do + olst <- joinEvalPTableItem $ commaSepdObjList "initializing expression" "{" "}" + coms <- optSpace + return $ AST_Init ref (AST_OptObjList coms inits) olst (getLocation o <> getLocation olst) + Nothing -> single + AST_RefPrefix{} -> single + +structPTabItems :: [DaoTableItem (AST_Object Object)] +structPTabItems = (:[]) $ tableItem HASHLABEL $ \nameTok -> do + bufferComments + let name = fromUStr $ ustr $ tail $ asString nameTok + let startLoc = asLocation nameTok + flip mplus (return $ AST_Struct name nullValue startLoc) $ do + objList <- joinEvalPTableItem $ commaSepdObjList "data structure initializer" "{" "}" + let objListLoc = getLocation objList + return $ AST_Struct name (AST_OptObjList [] (Just objList)) (startLoc<>objListLoc) + +structPTab :: DaoPTable (AST_Object Object) +structPTab = table structPTabItems + +arithPrefixPTab :: DaoPTable (AST_Object Object) +arithPrefixPTab = table $ (logicalNOT:) $ flip fmap ["~", "-", "+"] $ \pfxOp -> + tableItemBy pfxOp $ \tok -> optSpace >>= \coms -> object >>= \o -> + return (AST_ArithPfx (fromUStr (tokTypeToUStr (asTokType tok))) coms o (asLocation tok)) + where + logicalNOT = tableItemBy "!" $ \op -> do + coms <- optSpace + o <- object + return $ AST_ArithPfx (fromUStr $ tokTypeToUStr $ asTokType op) coms o (asLocation op) + +-- This table extends the 'funcCallArraySubPTab' table with the 'arithPrefixPTab' table. The +-- 'containerPTab' is also included at this level. It is the most complicated (and therefore lowest +-- prescedence) object expression that can be formed without making use of infix operators. +objectPTab :: DaoPTable (AST_Object Object) +objectPTab = mconcat [singletonOrContainerPTab, arithPrefixPTab, structPTab, initPTab] + +-- Evaluates 'objectPTab' to a 'DaoParser'. +object :: DaoParser (AST_Object Object) +object = joinEvalPTable objectPTab + +-- A constructor that basically re-arranges the arguments to the 'Dao.Interpreter.AST.AST_Eval' +-- constructor such that this function can be used as an argument to 'Dao.Parser.sinpleInfixed' +-- or 'Dao.Parser.newOpTableParser'. +arithConstr :: AST_Arith Object -> (Location, Com InfixOp) -> AST_Arith Object -> DaoParser (AST_Arith Object) +arithConstr left (loc, op) right = return $ AST_Arith left op right loc + +-- Parses a sequence of 'object' expressions interspersed with arithmetic infix opreators. +-- All infixed logical operators are included, assignment operators are not. The only prefix logical +-- operator. Logical NOT @(!)@ is not parsed here but in the 'arithmetic' function. +arithOpTable :: OpTableParser DaoParState DaoTT (Location, Com InfixOp) (AST_Arith Object) +arithOpTable = + newOpTableParser "arithmetic expression" False + (\tok -> do + op <- commented (shift (fromUStr . tokTypeToUStr . asTokType)) + return (asLocation tok, op) + ) + (object >>= \o -> bufferComments >> return (AST_Object o)) + arithConstr + ( opRight ["->"] arithConstr + : opRight ["**"] arithConstr + : fmap (\ops -> opLeft (words ops) arithConstr) + ["* / %", "+ -", "<< >>", "&", "^", "|", "< <= >= >", "== !="] + ++ [opRight ["&&"] arithConstr, opRight [ "||"] arithConstr] + ) + +arithmeticPTab :: DaoPTable (AST_Arith Object) +arithmeticPTab = bindPTable objectPTab $ \o -> + evalOpTableParserWithInit (bufferComments >> return (AST_Object o)) arithOpTable + +-- Evalautes the 'arithOpTable' to a 'DaoParser'. +arithmetic :: DaoParser (AST_Arith Object) +arithmetic = joinEvalPTable arithmeticPTab + +objTestPTab :: DaoPTable (AST_ObjTest Object) +objTestPTab = mappend (fmap AST_ObjRuleFunc <$> ruleFuncPTab) $ bindPTable arithmeticPTab $ \a -> do + bufferComments + flip mplus (return $ AST_ObjArith a) $ do + qmark <- commented (tokenBy "?" as0) + expect "arithmetic expression after (?) operator" $ do + b <- arithmetic + expect "(:) operator and arithmetic expression after (?) operator" $ do + coln <- commented (tokenBy ":" as0) + expect "arithmetic expression after (:) operator" $ do + c <- arithmetic + return $ AST_ObjTest a qmark b coln c (getLocation a <> getLocation c) + +objTest :: DaoParser (AST_ObjTest Object) +objTest = joinEvalPTable objTestPTab + +assignmentWithInit :: DaoParser (AST_Assign Object) -> DaoParser (AST_Assign Object) +assignmentWithInit init = + simpleInfixedWithInit "object expression for assignment operator" rightAssoc + (\left (loc, op) right -> return $ case left of + AST_Eval left -> AST_Assign left op right loc + left -> left + ) + (bufferComments >> init) + (fmap AST_Eval objTest) + (pure (,) <*> look1 asLocation <*> commented (joinEvalPTable opTab)) + where + opTab :: DaoPTable UpdateOp + opTab = table $ + fmap (flip tableItemBy (return . fromUStr . tokTypeToUStr . asTokType)) (words allUpdateOpStrs) + +assignmentPTab :: DaoPTable (AST_Assign Object) +assignmentPTab = bindPTable objTestPTab (assignmentWithInit . return . AST_Eval) + +-- | Evaluates a sequence arithmetic expressions interspersed with assignment operators. +assignment :: DaoParser (AST_Assign Object) +assignment = joinEvalPTable assignmentPTab + +---------------------------------------------------------------------------------------------------- + +bracketed :: String -> DaoParser (AST_CodeBlock Object, Location) +bracketed msg = do + startLoc <- tokenBy "{" asLocation + scrps <- concat <$> (many script <|> return []) + expect ("curly-bracket to close "++msg++" statement") $ do + _ <- look1 id + endLoc <- tokenBy "}" asLocation + return (AST_CodeBlock scrps, startLoc<>endLoc) + +script :: DaoParser [AST_Script Object] +script = joinEvalPTable scriptPTab + +ifWhilePTabItem :: String -> (AST_If Object -> a) -> DaoTableItem a +ifWhilePTabItem keyword constr = tableItemBy keyword $ \tok -> do + o <- commented paren + (thn, loc) <- bracketed keyword + return $ constr $ AST_If o thn (asLocation tok <> loc) + +whilePTabItem :: DaoTableItem (AST_While Object) +whilePTabItem = ifWhilePTabItem "while" AST_While + +ifPTabItem :: DaoTableItem (AST_If Object) +ifPTabItem = ifWhilePTabItem "if" id + +ifStatement :: DaoParser (AST_If Object) +ifStatement = joinEvalPTableItem ifPTabItem + +lastElseParser :: DaoParser (AST_LastElse Object) +lastElseParser = do + comTok <- commented $ tokenBy "else" asLocation + (els, endLoc) <- bracketed "else statement" + return $ AST_LastElse (fmap (const ()) comTok) els (unComment comTok <> endLoc) + +catchExprParser :: DaoParser (AST_Catch Object) +catchExprParser = do + bufferComments + startLoc <- tokenBy "catch" asLocation + expect "parameter variable name/type after \"catch\" statement" $ do + coms <- optSpace + param <- commented parameter + (scrpt, endLoc) <- bracketed "\"catch\" statement" + return $ AST_Catch coms param scrpt (startLoc <> endLoc) + +ifElsePTabItem :: DaoTableItem (AST_IfElse Object) +ifElsePTabItem = bindPTableItem ifPTabItem (loop []) where + loop elsx ifExpr = msum $ + [ do com1 <- optSpace + elsLoc <- tokenBy "else" asLocation + expect "bracketed expression, or another \"if\" expression after \"else\" statement" $ do + com2 <- optSpace + msum $ + [ do nextIf <- ifStatement + loop (elsx++[AST_Else (com com1 () com2) nextIf (elsLoc <> getLocation nextIf)] + ) ifExpr + , do (els, endLoc) <- bracketed "else statement" + return $ + AST_IfElse ifExpr elsx + (Just $ AST_LastElse (com com1 () com2) els (getLocation els <> endLoc)) + (getLocation ifExpr <> endLoc) + ] + , return (AST_IfElse ifExpr elsx Nothing (getLocation ifExpr)) + ] + +scriptPTab :: DaoPTable [AST_Script Object] +scriptPTab = comments <> objExpr <> table exprs where + -- Object expressions should end with a semi-colon. An exception to this rule is made for rule and + -- function constant expressions. + objExpr = bindPTable assignmentPTab $ \o -> case o of + AST_Eval (AST_ObjRuleFunc o) -> + flip mplus (return [AST_RuleFunc o]) $ do + coms <- optSpace + loc <- mappend (getLocation o) <$> tokenBy ";" asLocation + return [AST_EvalObject (AST_Eval $ AST_ObjRuleFunc o) coms loc] + o -> do + coms <- optSpace + expect "semicolon after object expression" $ do + endLoc <- tokenBy ";" asLocation + return [AST_EvalObject o coms (getLocation o <> endLoc)] + comments = bindPTable spaceComPTab $ \c1 -> optSpace >>= \c2 -> + let coms = c1++c2 in if null coms then return [] else return [AST_Comment coms] + exprs = + [ fmap (fmap (return . AST_WhileLoop)) whilePTabItem + , fmap (fmap (return . AST_IfThenElse)) ifElsePTabItem + , returnExpr "return" True + , returnExpr "throw" False + , continExpr "continue" True + , continExpr "break" False + , tableItemBy "try" $ \tok -> expect "bracketed script after \"try\" statement" $ do + coms <- optSpace + (try, endLoc) <- bracketed "\"try\" statement" + elsExprs <- many lastElseParser + catchExprs <- many catchExprParser + let finalLoc :: forall a . HasLocation a => [a] -> Location + finalLoc = foldl (\_ a -> getLocation a) endLoc + let loc = asLocation tok <> finalLoc elsExprs <> finalLoc catchExprs + return [AST_TryCatch coms try elsExprs catchExprs loc] + , tableItemBy "for" $ \tok -> expect "iterator label after \"for statement\"" $ do + comName <- commented (token LABEL asName) + expect "\"in\" statement after \"for\" statement" $ do + tokenBy "in" as0 + expect "object expression over which to iterate of \"for-in\" statement" $ do + o <- commented refPrefixParser + expect "bracketed script after \"for-in\" statement" $ do + (for, endLoc) <- bracketed "\"for\" statement" + return [AST_ForLoop comName o for (asLocation tok <> endLoc)] + , tableItemBy "with" $ \tok -> expect "reference expression after \"with\" statement" $ do + o <- commented paren + expect "bracketed script after \"with\" statement" $ do + (with, endLoc) <- bracketed "\"with\" statement" + return [AST_WithDoc o with (asLocation tok <> endLoc)] + ] + semicolon = tokenBy ";" asLocation + returnExpr key isReturn = tableItemBy key $ \tok -> do + o <- commented (assignment <|> return nullValue) + expect ("semicolon after \""++key++"\" statement") $ do + endLoc <- semicolon + return [AST_ReturnExpr isReturn o (asLocation tok <> endLoc)] + continExpr key isContin = tableItemBy key $ \tok -> do + let startLoc = asLocation tok + let msg e = concat [e, " after \"", key, "-if\" statement"] + coms <- optSpace + msum $ + [do endLoc <- semicolon + return [AST_ContinueExpr isContin coms (Com nullValue) (startLoc<>endLoc)] + ,do tokenBy "if" as0 + expect (msg "conditional expression") $ do + o <- commented assignment + expect (msg "semicolon") $ do + endLoc <- semicolon + return [AST_ContinueExpr isContin coms o (startLoc<>endLoc)] + , fail (msg "expecting optional object expression followed by a semicolon") + ] + +---------------------------------------------------------------------------------------------------- + +dotName :: DaoParser AST_DotName +dotName = return AST_DotName <*> commented (tokenBy "." as0) <*> token LABEL asName + +dotLabelTableItem :: DaoTableItem AST_DotLabel +dotLabelTableItem = tableItem LABEL $ \tok -> + return (AST_DotLabel (asName tok)) <*> many dotName <*> pure (asLocation tok) + +attributePTab :: DaoPTable AST_Attribute +attributePTab = table $ + [ fmap AST_AttribDotName <$> dotLabelTableItem + , tableItem STRINGLIT $ \tok -> return $ AST_AttribString (asUStr tok) (asLocation tok) + ] + +attribute :: DaoParser AST_Attribute +attribute = joinEvalPTable attributePTab + +namespace :: DaoParser AST_Namespace +namespace = do + tokenBy "as" as0 + nm <- commented $ token LABEL id + return $ AST_Namespace (fmap asName nm) (unComment $ fmap asLocation nm) + +---------------------------------------------------------------------------------------------------- + +toplevelPTab :: DaoPTable [AST_TopLevel Object] +toplevelPTab = table expr <> comments <> scriptExpr where + comments = bindPTable spaceComPTab $ \c1 -> optSpace >>= \c2 -> return $ + let coms = c1++c2 in if null coms then [] else [AST_TopComment (c1++c2)] + scriptExpr = bindPTable scriptPTab $ return . map (\o -> AST_TopScript o (getLocation o)) + expr = + [ event "BEGIN" , event "END" , event "EXIT" + , tableItemBy "require" $ \startTok -> needAttrib "require" $ do + attrib <- commented attribute + endTok <- needSemicolon "require" + return [AST_Require attrib $ asLocation startTok <> endTok] + , tableItemBy "import" $ \startTok -> needAttrib "import" $ do + attrib <- commented attribute + mplus + (do namesp <- namespace + endTok <- needSemicolon "import" + return [AST_Import attrib namesp $ asLocation startTok <> endTok] + ) + (return . AST_Import attrib nullValue . + mappend (asLocation startTok) <$> needSemicolon "import") + ] + needSemicolon msg = + expect ("expecting semicolon after \""++msg++"\" statement") $ tokenBy ";" asLocation + needAttrib msg = + expect ("expect string literal or logical module name after \""++msg++"\" statement") + event lbl = tableItemBy lbl $ \tok -> do + let exprType = show (asTokType tok) + coms <- optSpace + expect ("bracketed script after \""++exprType++"\" statement") $ do + (event, endLoc) <- bracketed ('"':exprType++"\" statement") + return [AST_Event (read lbl) coms event (asLocation tok <> endLoc)] + +toplevel :: DaoParser [AST_TopLevel Object] +toplevel = joinEvalPTable toplevelPTab + +---------------------------------------------------------------------------------------------------- + +daoParser :: DaoParser (AST_SourceCode Object) +daoParser = do + let loop dx = msum + [ isEOF >>= guard >> return dx + , toplevel >>= \d -> loop (dx++d) + , fail "syntax error on token" + ] + src <- loop [] + return (AST_SourceCode{sourceModified=0, sourceFullPath=nil, directives=src}) + +daoGrammar :: Language DaoParState DaoTT (AST_SourceCode Object) +daoGrammar = newLanguage 4 $ mplus daoParser $ fail "Parser backtracked without taking all input." + +---------------------------------------------------------------------------------------------------- + +testDaoLexer :: String -> IO () +testDaoLexer = testLexicalAnalysis (tokenDBLexer daoTokenDB) 4 + +testDaoParser :: String -> IO () +testDaoParser input = case parse daoGrammar mempty input of + OK a -> putStrLn ("Parser succeeded:\n"++prettyShow a) + Backtrack -> testDaoLexer input >> putStrLn "---- PARSER BACKTRACKED ----\n" + PFail err -> do + testDaoLexer input + putStrLn ("---- PARSER FAILED ----\n" ++ show err) + let st = parseStateAtErr err >>= internalState + putStrLn ("recentTokens = "++show (tokenQueue <$> st)) + putStrLn ("getLines = "++show (getLines <$> st)) + diff --git a/src/Dao/Interpreter/Tokenizer.hs b/src/Dao/Interpreter/Tokenizer.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Interpreter/Tokenizer.hs @@ -0,0 +1,136 @@ +-- "src/Dao/Interpreter/Tokenizer.hs" defines the +-- tokenizer for the Dao programming language. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +{-# LANGUAGE MultiParamTypeClasses #-} + +module Dao.Interpreter.Tokenizer where + +import Dao.String +import Dao.Interpreter.AST +import Dao.Parser + +import Control.Monad.Error hiding (Error) + +import Data.Monoid +import Data.Ix + +---------------------------------------------------------------------------------------------------- + +newtype DaoTT = DaoTT{ unwrapDaoTT :: TT } deriving (Eq, Ord, Ix) +instance TokenType DaoTT where { unwrapTT = unwrapDaoTT; wrapTT = DaoTT } +instance HasTokenDB DaoTT where { tokenDB = daoTokenDB } +instance MetaToken DaoTokenLabel DaoTT where { tokenDBFromMetaValue _ = tokenDB } +instance Show DaoTT where { show = deriveShowFromTokenDB daoTokenDB } + +type DaoLexer = Lexer DaoTT () + +daoTokenDB :: TokenDB DaoTT +daoTokenDB = makeTokenDB daoTokenDef + +data DaoTokenLabel + = SPACE | INLINECOM | ENDLINECOM | COMMA | LABEL | HASHLABEL | STRINGLIT | CHARLIT | DATE | TIME + | BASE10 | DOTBASE10 | NUMTYPE | EXPONENT | BASE16 | BASE2 + deriving (Eq, Enum, Show, Read) +instance UStrType DaoTokenLabel where { toUStr = derive_ustr; fromUStr = derive_fromUStr; } + +daoTokenDef :: LexBuilder DaoTT +daoTokenDef = do + ------------------------------------------ WHITESPACE ------------------------------------------- + let spaceRX = rxRepeat1(map ch "\t\n\r\f\v ") + space <- emptyToken SPACE $ spaceRX + + ------------------------------------------- COMMENTS -------------------------------------------- + closeInliner <- fullToken INLINECOM $ rxRepeat1(ch '*') . rx '/' + inlineCom <- fullToken INLINECOM $ rx "/*" . + fix (\loop -> closeInliner <> rxRepeat1(invert[ch '*']) . loop) + endlineCom <- fullToken ENDLINECOM $ rx "//" . rxRepeat(invert[ch '\n']) + + -------------------------------------------- LABELS --------------------------------------------- + let alpha = [from 'A' to 'Z', from 'a' to 'z', ch '_'] + labelRX = rxRepeat1 alpha . rxRepeat(from '0' to '9' : alpha) + label <- fullToken LABEL $ labelRX + hashlabel <- fullToken HASHLABEL $ rx '#' . labelRX + + ---------------------------------------- NUMERICAL TYPES ---------------------------------------- + let from0to9 = from '0' to '9' + plusMinus = rx[ch '+', ch '-'] + dot = rx '.' + number = rxRepeat1 from0to9 + base10 <- fullToken BASE10 $ number + dotBase10 <- fullToken DOTBASE10 $ dot . base10 + exponent <- fullToken EXPONENT $ rx[ch 'e', ch 'E'] . + cantFail "expecting exponent value after 'e' or 'E' character" . opt plusMinus . base10 + base2 <- fullToken BASE2 $ (rx "0b" <> rx "0B") . base10 + base16 <- fullToken BASE16 $ (rx "0x" <> rx "0X") . + rxRepeat[from0to9, from 'A' to 'F', from 'a' to 'f'] + numType <- fullToken NUMTYPE $ rx (map ch "UILRFfijs") + let base10Parser = mconcat $ + [ dotBase10 . opt exponent . opt numType + , base10 . opt dotBase10 . opt exponent . opt numType + , base10 . dot . exponent . opt numType + , base10 . opt exponent . opt numType + ] + ---------------------------------------- STRING LITERAL ---------------------------------------- + let litExpr op = rx op . (fix $ \loop -> + rxRepeat(invert [ch op, ch '\\']) . (rx "\\" . rx anyChar . loop <> rx op)) + stringLit <- fullToken STRINGLIT $ litExpr '"' + charLit <- fullToken CHARLIT $ litExpr '\'' + -------------------------------------- KEYWORDS AND GROUPING ------------------------------------ + openers <- operatorTable $ words "( [ { ${" + comma <- emptyToken COMMA (rx ',') + daoKeywords <- keywordTable LABEL labelRX $ words $ unwords $ + [ "local const static global" + , "null false true date time function func rule" + , "if else for in while with try catch continue break return throw" + , "BEGIN END EXIT import require" + , "struct union operator public private" -- other reserved keywords, but they don't do anything yet. + ] + let withKeyword key func = do + tok <- getTokID key :: LexBuilderM DaoTT + return (rx key . (label <> rxEmptyToken tok . func)) + closers <- operatorTable $ words "} ] )" + + ------------------------------------------- OPERATORS ------------------------------------------- + operators <- operatorTable $ words $ unwords $ + [allUpdateOpStrs, allPrefixOpStrs, allInfixOpStrs, ": ;"] + + ------------------------------------ DATE/TIME SPECIAL SYNTAX ----------------------------------- + -- makes use of token types that have already been created above + let year = rxLimitMinMax 4 5 from0to9 + dd = rxLimitMinMax 1 2 from0to9 + col = rx ':' + hy = rx '-' + timeRX = dd . col . dd . col . dd . opt(dot . number) + timeExpr <- fullToken TIME timeRX + -- time <- withKeyword "time" $ cantFail "time expression" . space . timeExpr + time <- withKeyword "time" $ space . timeExpr + dateExpr <- fullToken DATE $ year . hy . dd . hy . dd + -- date <- withKeyword "date" $ cantFail "date expression" . + date <- withKeyword "date" $ space . dateExpr . opt(space . timeExpr) . opt(space . label) + + ------------------------------------------- ACTIVATE -------------------------------------------- + -- activate $ + return $ regexToTableLexer $ + [ space, inlineCom, endlineCom, comma + , stringLit, charLit, base16, base2, base10Parser + , openers, hashlabel, operators, closers + , date, time, daoKeywords + ] + diff --git a/src/Dao/Interval.hs b/src/Dao/Interval.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Interval.hs @@ -0,0 +1,910 @@ +-- "src/Dao/SetM.hs" defines the Interval data type used to denote +-- a possibly infinite subset of contiguous elements of an Enum data type. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | This module provides what I believe to be a better implementation of mathematical intervals +-- than what is provided by the "interval" and "data-interval" packages, although more work has yet +-- to be done instantiating all of the classes in the "latices" package. +-- +-- This module improves on the concept of intervals by making them more general, specifically in +-- that intervals need only instantiate 'Prelude.Enum' rather than 'Prelude.Num'. This means +-- 'Prelude.Char' can now be used to create intervals, which is highly useful for constructing and +-- reasoning about regular expressions and parsers. +-- +-- Another improvement provided by this module over other interval modules is that non-contiguous +-- interval sets can be constructed. Thus there are two data types, 'Interval' which is never empty +-- and can be used to construct 'Set's, and 'Set's which may or may not be empty or infinite, and do +-- the work of what the @Data.Interval.Interval@ data type would otherwise do. +module Dao.Interval + ( -- * The 'Inf' data type + Inf(NegInf, PosInf, Finite) + , stepDown, stepUp, toPoint, enumIsInf + , InfBound, minBoundInf, maxBoundInf + -- * the 'Interval' data type + , Interval, startPoint, endPoint, segment, single, wholeInterval, negInfTo, toPosInf, enumInfSeg + , toBounded, toBoundedPair, segmentMember, singular, plural, segmentNub, segmentInvert + -- * Predicates on 'Interval's + , containingSet, numElems, isWithin, segmentHasEnumInf, segmentIsInfinite + -- * The 'SetM' monadic data type + , SetM, infiniteM, fromListM, rangeM, pointM + , toListM, defaultM, memberM, lookupM, nullM, isSingletonM + -- * Set Operators for monadic 'SetM's + , sieveM, invertM, setXUnionM, unionM, intersectM, deleteM + , setToSetM, setMtoSet + -- * The 'Set' non-monadic data type + , Set, whole, fromList, fromPairs, range, point + , toList, elems, member, Dao.Interval.null, isSingleton + -- * Set Operators for non-monadic 'Set's + , Dao.Interval.invert, setXUnion, Dao.Interval.union, Dao.Interval.intersect, Dao.Interval.delete + -- * Miscelaneous + , upperTriangular, nonAssociativeProduct + ) + where + +import Data.Monoid +import Data.List +import Data.Ratio + +import Control.Monad +import Control.Applicative +import Control.DeepSeq + +-- | Like 'Prelude.Bounded', except the bounds might be infiniteM, and return 'NegInf' or +-- 'PosInf' for the bounds. Using the GHC "flexible instances" and "undecidable instances" +-- feature, any data type that is an instance of 'Prelude.Bounded' is also a memberM of 'BoundInf'. +class InfBound c where + minBoundInf :: Inf c + maxBoundInf :: Inf c + +instance InfBound () where { minBoundInf = Finite (); maxBoundInf = Finite (); } +instance InfBound Int where { minBoundInf = Finite minBound; maxBoundInf = Finite maxBound; } +instance InfBound Char where { minBoundInf = Finite minBound; maxBoundInf = Finite maxBound; } +instance InfBound Integer where { minBoundInf = NegInf; maxBoundInf = PosInf; } +instance InfBound (Ratio Integer) where { minBoundInf = NegInf; maxBoundInf = PosInf; } +instance InfBound Float where { minBoundInf = NegInf; maxBoundInf = PosInf; } +instance InfBound Double where { minBoundInf = NegInf; maxBoundInf = PosInf; } + +-- | Enumerable elements with the possibility of infinity. +data Inf c + = NegInf -- ^ negative infinity + | PosInf -- ^ positive infinity + | Finite c -- ^ a single pointM + deriving Eq + +enumIsInf :: Inf c -> Bool +enumIsInf c = case c of + NegInf -> True + PosInf -> True + _ -> False + +instance Ord c => Ord (Inf c) where + compare a b = f a b where + f a b | a == b = EQ + f NegInf _ = LT + f _ NegInf = GT + f PosInf _ = GT + f _ PosInf = LT + f (Finite a) (Finite b) = compare a b + +instance Show c => Show (Inf c) where + show e = case e of + Finite c -> show c + NegInf -> "-infnt" + PosInf -> "+infnt" + +instance Functor Inf where + fmap f e = case e of + NegInf -> NegInf + PosInf -> PosInf + Finite e -> Finite (f e) + +-- | Increment a given value, but if the value is 'Prelude.maxBound', return 'PosInf'. In some +-- circumstances this is better than incrementing with @'Data.Functor.fmap' 'Prelude.succ'@ because +-- 'Prelude.succ' evaluates to an error when passing 'Prelude.maxBound' as the argument. This +-- function will never evaluate to an error. +stepUp :: (Eq c, Enum c, InfBound c) => Inf c -> Inf c +stepUp x = if x==maxBoundInf then PosInf else fmap succ x + +-- | Decrement a given value, but if the value is 'Prelude.minBound', returns 'NegInf'. In some +-- circumstances this is better than incrementing @'Data.Functor.fmap' 'Prelude.pred'@ because +-- 'Prelude.pred' evaluates to an error when passing 'Prelude.maxBound' as the argument. This +-- function will never evaluate to an error. +stepDown :: (Eq c, Enum c, InfBound c) => Inf c -> Inf c +stepDown x = if x==minBoundInf then NegInf else fmap pred x + +-- | Retrieve the value contained in an 'Inf', if it exists. +toPoint :: Inf c -> Maybe c +toPoint c = case c of + Finite c -> Just c + _ -> Nothing + +-- | A enumInfSeg of 'Inf' items is a subset of consectutive items in the set of all @c@ where @c@ +-- is any type satisfying the 'Prelude.Ix' class. To construct a 'Interval' object, use 'enumInfSeg'. +data Interval c + = Single { startPoint :: Inf c } + | Interval { startPoint :: Inf c, endPoint :: Inf c } + deriving Eq + -- NOTE: the constructor for this data type is not exported because all of the functions in this + -- module that operate on 'Interval's make the assumption that the first parameter *less than* the + -- second parameter. To prevent anyone from screwing it up, the constructor is hidden and + -- constructing a 'Interval' must be done with the 'enumInfSeg' function which checks the parameters. + +instance Ord c => Ord (Interval c) where + compare x y = case x of + Single a -> case y of + Single b -> compare a b + Interval b _ -> if a==b then LT else compare a b + Interval a b -> case y of + Single a' -> if a==b then GT else compare a a' + Interval a' b' -> if a==a' then compare b' b else compare a a' + +-- not exported +mkSegment :: Eq c => Inf c -> Inf c -> Interval c +mkSegment a b + | a==b = Single a + | otherwise = Interval a b + +-- | If the 'Interval' was constructed with 'single', return the pointM (possibly 'PosInf' or +-- 'NegInf') value used to construct it, otherwise return 'Data.Maybe.Nothing'. +singular :: Interval a -> Maybe (Inf a) +singular seg = case seg of + Interval _ _ -> mzero + Single a -> return a + +-- | If the 'Interval' was constructed with 'segment', return a pair of points (possibly 'PosInf' +-- or 'NegInf') value used to construct it, otherwise return 'Data.Maybe.Nothing'. +plural :: Interval a -> Maybe (Inf a, Inf a) +plural a = case a of + Interval a b -> return (a, b) + Single _ -> mzero + +showSegment :: Show c => Interval c -> String +showSegment seg = case seg of + Single a -> "at "++show a + Interval a b -> "from "++show a++" to "++show b + +-- | This gets rid of as many infiniteM elements as possible. All @'Single' 'PosInf'@ and +-- @'Single' 'NegInf'@ points are eliminated, and if an 'NegInf' or 'PosInf' can be +-- replaced with a corresponding 'minBoundInf' or 'maxBoundInf', then it is. This function is +-- intended to be used as a list monadic function, so use it like so: +-- @let myListOfSegments = [...] in myListOfSegments >>= 'delInfPoints'@ +canonicalSegment :: (Eq c, InfBound c) => Interval c -> [Interval c] +canonicalSegment seg = nonInf seg >>= \seg -> case seg of + Single a -> [Single a] + Interval a b -> nonInf (mkSegment (bounds a) (bounds b)) + where + nonInf seg = case seg of + Single NegInf -> [] + Single PosInf -> [] + Single a -> [Single a ] + Interval a b -> [Interval a b] + bounds x = case x of + NegInf -> minBoundInf + PosInf -> maxBoundInf + x -> x + +instance Show c => + Show (Interval c) where { show seg = showSegment seg } + +-- | A predicate evaluating whether or not a segment includes an 'PosInf' or 'NegInf' value. +-- This should not be confused with a predicate evaluating whether the set of elements included by +-- the rangeM is infiniteM, because types that are instances of 'Prelude.Bounded' may also contain +-- 'PosInf' or 'NegInf' elements, values of these types may be evaluated as "infintie" by +-- this function, even though they are 'Prelude.Bounded'. To check if a segment is infiniteM, use +-- 'segmentIsInfinite' instead. +segmentHasEnumInf :: Interval c -> Bool +segmentHasEnumInf seg = case seg of + Single c -> enumIsInf c + Interval a b -> enumIsInf a || enumIsInf b + +-- | A predicate evaluating whether or not a segment is infiniteM. Types that are 'Prelude.Bounded' +-- are always finite, and thus this function will always evaluate to 'Prelude.False' for these +-- types. +segmentIsInfinite :: InfBound c => Interval c -> Bool +segmentIsInfinite seg = case [Single minBoundInf, Single maxBoundInf, seg] of + [Single a, Single b, c] | enumIsInf a || enumIsInf b -> case c of + Single c -> enumIsInf c + Interval a b -> enumIsInf a || enumIsInf b + _ -> False + +-- | Construct a 'Interval' from two 'Inf' items. /NOTE/ if the 'Inf' type you are +-- constructing is an instance of 'Prelude.Bounded', use the 'boundedSegment' constructor instead of +-- this function. +enumInfSeg :: (Ord c, Enum c, InfBound c) => Inf c -> Inf c -> Interval c +enumInfSeg a b = seg a b where + seg a b = construct (ck minBoundInf NegInf a) (ck maxBoundInf PosInf b) + ck infnt subst ab = if infnt==ab then subst else ab + construct a b + | a == b = Single a + | a < b = Interval a b + | otherwise = Interval b a + +-- | Construct a 'Interval' from two values. +segment :: Ord c => c -> c -> Interval c +segment a b = mkSegment (Finite (min a b)) (Finite (max a b)) + +-- | Construct a 'Interval' that is only a single unit, i.e. it starts at X and ends at X. +single :: Ord c => c -> Interval c +single a = segment a a + +-- | Construct a 'Interval' from negative infinity to a given value. +negInfTo :: InfBound c => c -> Interval c +negInfTo a = Interval minBoundInf (Finite a) + +-- | Construct a 'Interval' from a given value to positive infinity. +toPosInf :: InfBound c => c -> Interval c +toPosInf a = Interval (Finite a) maxBoundInf + +-- | Construct the infiniteM 'Interval' +wholeInterval :: Interval c +wholeInterval = Interval NegInf PosInf + +-- | Tests whether an element is a memberM is enclosed by the 'Interval'. +segmentMember :: Ord c => Interval c -> c -> Bool +segmentMember seg c = case seg of + Single (Finite d) -> c == d + Interval lo hi -> let e = Finite c in lo <= e && e <= hi + _ -> False + +-- | Construct a 'Interval', like the 'enumInfSeg' constructor above, however does not require 'Inf' +-- parameters as inputs. This function performs the additional check of testing whether or not a +-- value is equivalent to 'Prelude.minBound' or 'Prelude.maxBound', and if it is, replaces that +-- value with 'NegInf' or 'PosInf' respectively. In other words, you can use +-- 'Prelude.minBound' in place of NegInf and 'Prelude.maxBound' in place of 'PosInf' without +-- changing the semantics of the data structure as it is used throughout the program. +-- boundedSegment :: (Ord c, Enum c, Bounded c) => c -> c -> Interval c +-- boundedSegment a b = if a>b then co b a else co a b where +-- co a b = enumInfSeg (f a minBound NegInf) (f b maxBound PosInf) +-- f x bound infnt = if x==bound then infnt else Finite x + +-- | If an 'Inf' is also 'Prelude.Bounded' then you can convert it to some value in the set of +-- 'Prelude.Bounded' items. 'NegInf' translates to 'Prelude.minBound', 'PosInf' translates +-- to 'Prelude.maxBound', and 'Finite' translates to the value at that pointM. +toBounded :: Bounded c => Inf c -> c +toBounded r = case r of + NegInf -> minBound + PosInf -> maxBound + Finite c -> c + +-- | Like 'toBounded', but operates on a segment and returns a pair of values. +toBoundedPair :: (Enum c, Bounded c) => Interval c -> (c, c) +toBoundedPair r = case r of + Single c -> (toBounded c, toBounded c) + Interval c d -> (toBounded c, toBounded d) + +enumBoundedPair :: (Enum c, Bounded c) => Interval c -> [c] +enumBoundedPair seg = let (lo, hi) = toBoundedPair seg in [lo..hi] + +-- | Computes the minimum 'Interval' that can contain the list of all given 'EnumRanges'. +-- 'Data.Maybe.Nothing' indicates the empty set. +containingSet :: (Ord c, Enum c, InfBound c) => [Interval c] -> Maybe (Interval c) +containingSet ex = foldl fe Nothing ex where + fe Nothing a = Just a + fe (Just a) c = Just $ case a of + Single a -> case c of + Single c -> enumInfSeg (min a c) (max a c) + Interval c d -> enumInfSeg (min a c) (max a d) + Interval a b -> case c of + Single c -> enumInfSeg (min a b) (max b c) + Interval c d -> enumInfSeg (min a c) (max b d) + +-- | Evaluates to the number of elements covered by this region. Returns 'Prelude.Nothing' if there +-- are an infiniteM number of elements. For data of a type that is not an instance of 'Prelude.Num', +-- for example @'Interval' 'Data.Char.Char'@, it is recommended you first convert to the type +-- @'Interval' 'Data.Int.Int'@ using @'Control.Functor.fmap' 'Prelude.fromEnum'@ before using this +-- function, then convert the result back using @'Control.Functor.fmap' 'Prelude.toEnum'@ if +-- necessary. +numElems :: (Integral c, Enum c) => Interval c -> Maybe Integer +numElems seg = case seg of + Single (Finite _) -> Just 1 + Interval (Finite a) (Finite b) -> Just (fromIntegral a - fromIntegral b + 1) + _ -> Nothing + +-- | Tests whether an 'Inf' is within the enumInfSeg. It is handy when used with backquote noation: +-- @enumInf `isWithin` enumInfSeg@ +isWithin :: (Ord c, Enum c) => Inf c -> Interval c -> Bool +isWithin pointM seg = case seg of + Single x -> pointM == x + Interval NegInf hi -> pointM <= hi + Interval lo PosInf -> lo <= pointM + Interval lo hi -> lo <= pointM && pointM <= hi + +-- | Returns true if two 'Interval's are intersecting. +areIntersecting :: (Ord c, Enum c) => Interval c -> Interval c -> Bool +areIntersecting a b = case a of + Single aa -> case b of + Single bb -> aa == bb + Interval _ _ -> aa `isWithin` b + Interval x y -> case b of + Single bb -> bb `isWithin` a + Interval x' y' -> x' `isWithin` a || y' `isWithin` a || x `isWithin` b || y `isWithin` b + +-- | Returns true if two 'Interval's are consecutive, that is, if the end is the 'Prelude.pred'essor +-- of the start of the other. +areConsecutive :: (Ord c, Enum c, InfBound c) => Interval c -> Interval c -> Bool +areConsecutive a b = case a of + Single a -> case b of + Single b + | a < b -> consec a b + | otherwise -> consec b a + Interval x y + | a < x -> consec a x + | otherwise -> consec y a + Interval x y -> case b of + Single a + | a < x -> consec a x + | otherwise -> consec y a + Interval x' y' + | y < x' -> consec y x' + | otherwise -> consec y' x + where { consec a b = stepUp a == b || a == stepDown b } + +-- | Performs a set union on two 'Interval's of elements to create a new enumInfSeg. If the elements of +-- the new enumInfSeg are not contiguous, each enumInfSeg is returned separately and unchanged. The first +-- item in the pair of items returned is 'Prelude.True' if any of the items were modified. +segmentUnion :: (Ord c, Enum c, InfBound c) => Interval c -> Interval c -> (Bool, [Interval c]) +segmentUnion a b + | areIntersecting a b = case a of + Single _ -> case b of + Single _ -> (True, [a]) + Interval _ _ -> (True, [b]) + Interval x y -> case b of + Single _ -> (True, [a]) + Interval x' y' -> (True, [enumInfSeg (min x x') (max y y')]) + | areConsecutive a b = case a of + Single aa -> case b of + Single bb -> (True, [enumInfSeg aa bb ]) + Interval x y -> (True, [enumInfSeg (min aa x) (max aa y)]) + Interval x y -> case b of + Single bb -> (True, [enumInfSeg (min bb x) (max bb y)]) + Interval x' y' -> (True, [enumInfSeg (min x x') (max y y')]) + | otherwise = (False, [a, b]) + +-- | Performs a set intersection on two 'Interval's of elements to create a new enumInfSeg. If the +-- elements of the new enumInfSeg are not contiguous, this function evaluates to an empty list. +segmentIntersect :: (Ord c, Enum c, InfBound c) => Interval c -> Interval c -> (Bool, [Interval c]) +segmentIntersect a b = if areIntersecting a b then joined else (False, []) where + joined = case a of + Single aa -> case b of + Single aa -> (True, [Single aa]) + Interval _ _ -> (True, [Single aa]) + Interval x y -> case b of + Single aa -> (True, [Single aa]) + Interval x' y' -> (True, [enumInfSeg (max x x') (min y y')]) + +-- | Performs a set "delete" operation, deleteing any elements selected by the first enumInfSeg if +-- they are contained in the second enumInfSeg. This operation is not associative, i.e. +-- @'segmentDelete' a b /= 'segmentDelete' b a@. +segmentDelete :: (Ord c, Enum c, InfBound c) => + Interval c -> Interval c -> (Bool, [Interval c]) +segmentDelete a b = if not (areIntersecting a b) then (False, [a]) else del where + del = case a of + Single _ -> case b of + Single _ -> (True, []) + Interval _ _ -> (True, []) + Interval x y -> case b of + Single x' + | x==x' -> (True, [enumInfSeg (stepUp x) y ]) + | y==x' -> (True, [enumInfSeg x (stepDown y)]) + | otherwise -> (True, [enumInfSeg x (stepDown x'), enumInfSeg (stepUp x') y]) + Interval x' y' + | x' > x && y' < y -> (True, [enumInfSeg x (stepDown x'), enumInfSeg (stepUp y') y]) + | x' <= x && y' >= y -> (True, []) + | x' <= x && y' < y -> (True, [enumInfSeg (stepUp y') y]) + | x' > x && y' >= y -> (True, [enumInfSeg x (stepDown x')]) + | otherwise -> error "segmentDelete" + +-- | Evaluates to the set of all elements not selected by the given 'Interval'. +segmentInvert :: (Ord c, Enum c, InfBound c) => Interval c -> [Interval c] +segmentInvert seg = canonicalSegment =<< case seg of + Single x -> case x of + NegInf -> [] -- [Single PosInf] + PosInf -> [] -- [Single NegInf] + Finite _ -> [mkSegment NegInf (stepDown x), mkSegment (stepUp x) PosInf] + Interval x y -> case x of + NegInf -> case y of + NegInf -> [] -- [Single PosInf] + PosInf -> [] -- [] + Finite _ -> [mkSegment (stepUp y) PosInf] + PosInf -> case y of + PosInf -> [] -- [Single NegInf] + NegInf -> [] -- [] + Finite _ -> [mkSegment NegInf (stepDown y)] + Finite _ -> case y of + NegInf -> [mkSegment (stepUp x) PosInf ] + PosInf -> [mkSegment NegInf (stepDown x)] + Finite _ -> + [ mkSegment NegInf (min (stepDown x) (stepDown y)) + , mkSegment (max (stepUp x) (stepUp y)) PosInf + ] + +-- | Eliminate overlapping and duplicate 'Interval's from a list of segments. +segmentNub :: (Ord c, Enum c, InfBound c) => [Interval c] -> [Interval c] +segmentNub = toList . fromList + +---------------------------------------------------------------------------------------------------- + +-- | This function is used by 'associativeProduct' to generate the list of pairs on which to execute the +-- inner production function. It is a general function that may come in handy, but otherwise does +-- not specifically relate to 'SetM' or 'Interval' types. +-- +-- What it does is, Given two lists of items, returns every possible unique combination of two +-- items. For example the pair (1,2) and (2,1) are considered to be the same combination, so only +-- (1,2) is selected. The selected items are returned as a list. The name of this function derives +-- from a similar matrix operation were all possible pairs are placed in a matrix and the +-- upper-triangluar elements are selected and returned. Pass 'Prelude.True' as the first parameter +-- to select items on the main diagonal of the matrix. Passing 'Prelude.False' is handy when you are +-- trying to evaluate a function on every possible 2-element combination of elements from a single +-- list, but don't need to evaluate each element with itself. +upperTriangular :: Bool -> [a] -> [b] -> [(a, b)] +upperTriangular mainDiag ax bx = do + let iter bx = if Data.List.null bx then [] else bx : iter (tail bx) + (a, bx) <- zip ax (if mainDiag then iter bx else if Data.List.null bx then [] else iter (tail bx)) + map (\b -> (a, b)) bx + +-- Used by the various set operations, including 'unionWithM', 'intersectWithM', and 'deleteWithM', to +-- compute a new set from two parameter sets and a single operation on the compnent 'Interval's. What +-- it does is, given two lists of elements, the largest possible upper triangular matrix (using +-- 'upperTriangular') of all possible pairs of elements from a and b is formed, and on each pair a +-- given inner product function is executed. The first parameter, the product function, is intended +-- to be a function like 'segmentUnion', 'segmentIntersect', or 'segmentDelete'. +associativeProduct + :: (Ord c, Enum c, InfBound c) + => (Interval c -> Interval c -> (Bool, [Interval c])) + -> [Interval c] -> [Interval c] -> [Interval c] +associativeProduct reduce a b = + let f a b = upperTriangular True a b >>= snd . uncurry reduce + in segmentNub (if length b > length a then f a b else f b a) + +-- not for export +-- This equation assumes list arguments passed to it are already sorted list. This alrorithm works +-- in O(log (n^2)) time. Pass two functions, a function for combining intersecting items, and a +-- function for converting non-intersecting items in the list of @a@ to the list of @b@. +exclusiveProduct :: (a -> b -> (Bool, [a])) -> [a] -> [b] -> [a] +exclusiveProduct product ax bx = ax >>= loop False bx where + loop hitOne bx a = case bx of + [] -> if hitOne then [] else [a] + b:bx -> + let (hit, ax) = product a b + in if hit + then ax >>= loop False bx + else if hitOne then [] else loop False bx a + -- The logic is this: we are deleting or XOR-ing items bounded by segments in B from items + -- bounded by segments in A. Both A and B are sorted. For every segment 'a' in A, the following + -- evaluations take place: every element 'b' in B is checked against 'a' until we find a segment + -- 'b[first]' that hits (intersects with) 'a'. The 'hitOne' boolean is set to True as soon as + -- 'b[first]' is found. Now we continue with every 'b' segment after 'b[first]' until we find a + -- segment 'b[missed]' that does not hit (intersect with) 'a'. Since 'b[missed]' does not + -- intersect, every element 'b' above 'b[missed]' will also miss (not intersect with) 'a', + -- assuming 'b' elements are sorted. Therefore, we can stop scanning for further elements in B, + -- we know they will all miss (not intersect). If every element in B misses (does not intersect + -- with) 'a', then the segment 'a' is returned unmodified (because of the definition of XOR). + -- However if even one segment in B hit this 'a', the only the segments produced by + -- 'segmentDelete' are returned. + +-- | Unlike inner product, which works with associative operators, 'segmentExclusive' +-- works with non-associative operators, like 'segmentDelete' and 'segmentXOR'. Lists of elements +-- passed to this function are sorted. Lists that are already sorted can be multiplied in +-- in O(log (n*m)) time. The product function you pass will return @(Prelude.True, result)@ if the +-- two arguments passed to it "react" with each other, that is, if they can be multiplied to a +-- non-null or non-zero result. This function is used to implement set deletion. +nonAssociativeProduct :: Ord c => (c -> c -> (Bool, [c])) -> [c] -> [c] -> [c] +nonAssociativeProduct product ax bx = exclusiveProduct product (sort ax) (sort bx) + +---------------------------------------------------------------------------------------------------- + +-- | A set-union of serveral 'Interval's, each segment being paired with a list of arbitrary value +-- @x@. It is like an extension of the list monad, except lists may be divided up and assigned to +-- ranges of integral values (or any type that instantiates 'InfBound'). +data SetM c x + = EmptySetM + | InfiniteM{ setValue :: [x] } + | SetM { setSegmentsM :: [(Interval c, [x])], setValue :: [x] } + deriving Eq +instance (Ord c, Enum c, InfBound c, Monoid x) => + Monoid (SetM c x) where + mempty = EmptySetM + mappend a b = foldValueSetM mappend (unionM a b) +instance + Functor (SetM c) where + fmap f a = case a of + EmptySetM -> EmptySetM + InfiniteM x -> InfiniteM (fmap f x) + SetM a x -> SetM (fmap (fmap (fmap f)) a) (fmap f x) +instance (Ord c, Enum c, InfBound c) => + Monad (SetM c) where + return = InfiniteM . (:[]) + a >>= b = case a of + EmptySetM -> EmptySetM + InfiniteM x -> msum (map b x) + SetM a x -> msum (map segs a ++ map deflts x) where + segs (a, x) = msum (map (sieveM a . b) x) + deflts x = case b x of + EmptySetM -> EmptySetM + InfiniteM x -> InfiniteM x + SetM _ x -> InfiniteM x +instance (Ord c, Enum c, InfBound c) => + MonadPlus (SetM c) where { mzero = EmptySetM; mplus = unionM; } +instance (Ord c, Enum c, InfBound c) => + Applicative (SetM c) where { pure = return; (<*>) = ap; } +instance (Ord c, Enum c, InfBound c) => + Alternative (SetM c) where { empty = mzero; (<|>) = mplus; } + +-- | Remove any component segment within the set that does not intersect with the given segment. +sieveM :: (Ord c, Enum c, InfBound c) => Interval c -> SetM c x -> SetM c x +sieveM b a = case a of + EmptySetM -> EmptySetM + InfiniteM x -> SetM [(b, x)] [] + SetM a x -> case filter (areIntersecting b . fst) a of + [] -> EmptySetM + [(a, x)] | a==wholeInterval -> InfiniteM x + a -> SetM a x + +-- | 'SetM' monads contain values accumulate into lists. This function will reduce these lists to a +-- single element using a folding function. +foldValueSetM :: (x -> x -> x) -> SetM c x -> SetM c x +foldValueSetM f s = case s of + EmptySetM -> EmptySetM + InfiniteM x -> InfiniteM (fol x) + SetM s x -> + SetM + { setSegmentsM = map (\ (s, x) -> (s, fol x)) s + , setValue = fol x + } + where + fol x = case x of + (a:b:x) -> [foldl f a (b:x)] + [x] -> [x] + [] -> [] + +-- not for export +-- Used to create a function useful to 'unionM' and 'intersectM' when those functions call +-- 'exclusiveProduct' to determine which component segments are overlaping, and what to do with 1. +-- segments on the low end do not overlap, 2. segments that overlap, and 3. segments on the high end +-- that do not overlap. The first parameter to this function is a function that takes three lists +-- for each of (1) (2) and (3), and returns a new list that combines the three. In the case of +-- 'intersectionM', (1) and (3) (the non-overlapping parts) are disgarded and only (2) (the +-- overlapping part) is returned. In the case of 'unionM', (1) (2) and (3) are simply concatenated. +joinSegments + :: (Ord c, Enum c, InfBound c) + => ([(Interval c, [x])] -> [(Interval c, [x])] -> [(Interval c, [x])] -> [(Interval c, [x])]) + -> (Interval c, [x]) -> (Interval c, [x]) + -> (Bool, [(Interval c, [x])]) +joinSegments joiner (a, ax) (b, bx) = + let (isecting, andAB) = segmentIntersect a b + (_ , delAB) = segmentDelete a b + (_ , delBA) = segmentDelete b a + newA = map (\s -> (s, ax )) delAB + newAB = map (\s -> (s, ax++bx)) andAB + newB = map (\s -> (s, bx )) delBA + in if not isecting + then (False, [(a, ax), (b, bx)]) + else (,) True $ case (newA, newB) of + ([], [lo, hi]) -> joiner [lo] newAB [hi] + ([lo, hi], []) -> joiner [lo] newAB [hi] + ([lo], [hi]) -> joiner [lo] newAB [hi] + _ -> error "joinSegments" + +unionM :: (Ord c, Enum c, InfBound c) => SetM c x -> SetM c x -> SetM c x +unionM a b = case a of + EmptySetM -> b + InfiniteM ax -> case b of + EmptySetM -> InfiniteM ax + InfiniteM bx -> InfiniteM (ax++bx) + SetM b bx -> SetM b (ax++bx) + SetM a ax -> case b of + EmptySetM -> SetM a ax + InfiniteM bx -> SetM a (ax++bx) + SetM b bx -> + SetM (exclusiveProduct (joinSegments (\lo mid hi -> lo++mid++hi)) a b) (ax++bx) + +intersectM :: (Ord c, Enum c, InfBound c) => SetM c x -> SetM c x -> SetM c x +intersectM a b = case a of + EmptySetM -> b + InfiniteM ax -> case b of + EmptySetM -> InfiniteM ax + InfiniteM bx -> InfiniteM (ax++bx) + SetM b bx -> SetM b (ax++bx) + SetM a ax -> case b of + EmptySetM -> SetM a ax + InfiniteM bx -> SetM a (ax++bx) + SetM b bx -> + SetM (exclusiveProduct (joinSegments (\_ mid _ -> mid)) a b) (ax++bx) + +deleteM :: (Ord c, Enum c, InfBound c) => SetM c x -> SetM c x -> SetM c x +deleteM a b = case a of + EmptySetM -> EmptySetM + InfiniteM ax -> case b of + EmptySetM -> InfiniteM ax + InfiniteM _ -> EmptySetM + SetM b _ -> invertM (SetM b []) ax + SetM a ax -> case b of + EmptySetM -> SetM a ax + InfiniteM _ -> EmptySetM + SetM b _ -> flip SetM ax $ nubBy (\a b -> fst a == fst b) $ + exclusiveProduct (joinSegments (\lo _ hi -> lo++hi)) a b + +setXUnionM :: (Ord c, Enum c, InfBound c) => SetM c x -> SetM c x -> SetM c x +setXUnionM a b = unionM (deleteM a b) (deleteM b a) + +invertM :: (Ord c, Enum c, InfBound c) => SetM c x -> [y] -> SetM c y +invertM a y = case a of + EmptySetM -> InfiniteM y + InfiniteM _ -> EmptySetM + SetM a _ -> + SetM (map (flip (,) y) $ toList $ invert $ fromList $ map fst a) [] + +-- | Initialize a new intinite 'SetM', that is, the set that contains all possible elements. +infiniteM :: (Ord c, Enum c, InfBound c) => [x] -> SetM c x +infiniteM = InfiniteM + +-- | Initialize a new 'SetM' object with a list of 'Interval's, which are 'segmentUnion'ed +-- together to create the set. +fromListM :: (Ord c, Enum c, InfBound c) => [Interval c] -> [x] -> SetM c x +fromListM a ax = case segmentNub a of + [a] | a==wholeInterval -> InfiniteM ax + [] -> EmptySetM + a -> SetM (map (flip (,) ax) a) [] + +-- | Create a set with a single rangeM of elements, no gaps. +rangeM :: (Ord c, Enum c, InfBound c) => c -> c -> [x] -> SetM c x +rangeM a b x = SetM [(segment a b, x)] [] + +-- | Create a set with a single element. +pointM :: (Ord c, Enum c, InfBound c) => c -> [x] -> SetM c x +pointM c x = rangeM c c x + +-- | Tests if an element is a memberM of the set. +memberM :: Ord c => SetM c x -> c -> Bool +memberM a c = case a of + EmptySetM -> False + InfiniteM _ -> True + SetM a _ -> or (map (flip segmentMember c . fst) a) + +-- | Test if a set encompases only one element, and if so, returns that one element. +isSingletonM :: (Ord c, Enum c, InfBound c) => SetM c x -> Maybe (c, [x]) +isSingletonM a = case a of + SetM a _ -> case a of + [(Single (Finite a), x)] -> Just (a, x) + _ -> Nothing + _ -> Nothing + +-- | Tests if a set is empty. +nullM :: SetM c x -> Bool +nullM a = case a of + EmptySetM -> True + SetM [] _ -> True + _ -> False + +lookupM :: (Ord c, Enum c, InfBound c) => SetM c x -> c -> [x] +lookupM a c = case a of + EmptySetM -> [] + InfiniteM x -> x + SetM a x -> case concatMap snd (filter (isWithin (Finite c) . fst) a) of { [] -> x; x -> x; } + +toListM :: SetM c x -> [(Interval c, [x])] +toListM set = case set of + EmptySetM -> [] + InfiniteM _ -> [] + SetM a _ -> a + +defaultM :: SetM c x -> [x] +defaultM set = case set of + EmptySetM -> [] + InfiniteM x -> x + SetM _ x -> x + +setToSetM :: (Ord c, Enum c, InfBound c) => Set c -> [x] -> SetM c x +setToSetM a x = case a of + EmptySet -> EmptySetM + InfiniteSet -> InfiniteM x + InverseSet a -> setToSetM (forceInvert a) x + Set a -> SetM (map (flip (,) x) a) [] + +setMtoSet :: SetM c x -> Set c +setMtoSet a = case a of + EmptySetM -> EmptySet + InfiniteM _ -> InfiniteSet + SetM a _ -> Set (map fst a) + +---------------------------------------------------------------------------------------------------- + +data Set c + = EmptySet + | InfiniteSet + | InverseSet (Set c) + | Set [Interval c] +instance (Ord c, Enum c, InfBound c) => Eq (Set c) where + a == b = case a of + EmptySet -> case b of + EmptySet -> True + Set [] -> True + _ -> False + InfiniteSet -> case b of + InfiniteSet -> True + Set [s] | s==wholeInterval -> True + _ -> False + InverseSet a -> case b of + InverseSet b -> a==b + _ -> forceInvert a == b + Set a -> case b of + Set b -> a==b + _ -> False + +instance (Ord c, Enum c, InfBound c) => Monoid (Set c) where + mempty = EmptySet + mappend = Dao.Interval.union + +instance Show c => Show (Set c) where + show s = case s of + EmptySet -> "enumSet()" + InfiniteSet -> "enumSet(-Inf to +Inf)" + InverseSet s -> "!enumSet("++show s++")" + Set s -> "enumSet("++intercalate ", " (map show s)++")" + +whole :: Set c +whole = InfiniteSet + +-- not exported, creates a list from segments, but does not clean it with 'segmentNub' +fromListNoNub :: (Ord c, Enum c, InfBound c) => [Interval c] -> Set c +fromListNoNub a = + if Data.List.null a + then EmptySet + else if a==[wholeInterval] then InfiniteSet else Set a + +fromList :: (Ord c, Enum c, InfBound c) => [Interval c] -> Set c +fromList a = if Data.List.null a then EmptySet else fromListNoNub a + +fromPairs :: (Ord c, Enum c, InfBound c) => [(c, c)] -> Set c +fromPairs = fromList . map (uncurry segment) + +range :: (Ord c, Enum c, InfBound c) => c -> c -> Set c +range a b = Set [segment a b] + +point :: (Ord c, Enum c, InfBound c) => c -> Set c +point a = Set [single a] + +toList :: (Ord c, Enum c, InfBound c) => Set c -> [Interval c] +toList s = case s of + EmptySet -> [] + InfiniteSet -> [wholeInterval] + InverseSet s -> toList (forceInvert s) + Set s -> s + +elems :: (Ord c, Enum c, Bounded c, InfBound c) => Set c -> [c] +elems = concatMap enumBoundedPair . toList + +member :: (Ord c, InfBound c) => Set c -> c -> Bool +member s b = case s of + EmptySet -> False + InfiniteSet -> True + InverseSet s -> not (member s b) + Set [] -> False + Set s -> or (map (flip segmentMember b) s) + +null :: Set c -> Bool +null s = case s of + EmptySet -> True + InfiniteSet -> False + InverseSet s -> not (Dao.Interval.null s) + Set [] -> True + Set _ -> False + +isSingleton :: (Ord c, Enum c, InfBound c) => Set c -> Maybe c +isSingleton s = case s of + InverseSet s -> isSingleton (forceInvert s) + Set [Single c] -> toPoint c + _ -> mzero + +invert :: (Ord c, Enum c, InfBound c) => Set c -> Set c +invert s = case s of + EmptySet -> InfiniteSet + InfiniteSet -> EmptySet + InverseSet s -> s + Set s -> InverseSet (Set s) + +-- not for export +forceInvert :: (Ord c, Enum c, InfBound c) => Set c -> Set c +forceInvert s = case s of + EmptySet -> InfiniteSet + InfiniteSet -> EmptySet + InverseSet s -> s + Set [] -> InfiniteSet + Set [s] | s==wholeInterval -> EmptySet + Set s -> fromListNoNub (loop NegInf s >>= canonicalSegment) where + loop mark s = case s of + [] -> [mkSegment (stepUp mark) PosInf] + [Interval a PosInf] -> [mkSegment (stepUp mark) (stepDown a)] + Interval NegInf b : s -> loop b s + Interval a b : s -> mkSegment (stepUp mark) (stepDown a) : loop b s + Single a : s -> mkSegment (stepUp mark) (stepDown a) : loop a s + +setXUnion :: (Ord c, Enum c, InfBound c) => Set c -> Set c -> Set c +setXUnion a b = Dao.Interval.delete (Dao.Interval.union a b) (Dao.Interval.intersect a b) + +union :: (Ord c, Enum c, InfBound c) => Set c -> Set c -> Set c +union a b = case a of + EmptySet -> b + InfiniteSet -> InfiniteSet + InverseSet a -> Dao.Interval.union (forceInvert a) b + Set [] -> b + Set a -> case b of + EmptySet -> Set a + InfiniteSet -> InfiniteSet + InverseSet b -> Dao.Interval.union (Set a) (forceInvert b) + Set [] -> Set a + Set b -> fromListNoNub (associativeProduct segmentUnion a b) + +intersect :: (Ord c, Enum c, InfBound c) => Set c -> Set c -> Set c +intersect a b = case a of + EmptySet -> EmptySet + InfiniteSet -> b + InverseSet a -> Dao.Interval.intersect (forceInvert a) b + Set [] -> EmptySet + Set a -> case b of + EmptySet -> EmptySet + InfiniteSet -> Set a + InverseSet b -> Dao.Interval.intersect (Set a) (forceInvert b) + Set [] -> EmptySet + Set b -> fromListNoNub (associativeProduct segmentIntersect a b) + +delete :: (Ord c, Enum c, InfBound c) => Set c -> Set c -> Set c +delete a b = case b of + EmptySet -> a + InfiniteSet -> EmptySet + InverseSet b -> Dao.Interval.delete a (forceInvert b) + Set [] -> a + Set b -> case a of + EmptySet -> EmptySet + InfiniteSet -> forceInvert (Set b) + InverseSet a -> Dao.Interval.delete (forceInvert a) (Set b) + Set [] -> EmptySet + Set a -> fromList (exclusiveProduct segmentDelete a b) + -- Here we call 'fromList' instead of 'fromListNoNub' because an additional 'segmentNub' + -- operation is required. + +---------------------------------------------------------------------------------------------------- + +instance NFData a => + NFData (Inf a) where + rnf NegInf = () + rnf PosInf = () + rnf (Finite c) = deepseq c () + +instance NFData a => + NFData (Interval a) where + rnf (Single a ) = deepseq a () + rnf (Interval a b) = deepseq a $! deepseq b () + +instance (NFData a, NFData x) => + NFData (SetM a x) where + rnf a = case a of + EmptySetM -> () + InfiniteM ax -> deepseq ax () + SetM a ax -> deepseq a $! deepseq ax () + +instance NFData a => NFData (Set a) where + rnf EmptySet = () + rnf InfiniteSet = () + rnf (Set a) = deepseq a () + rnf (InverseSet a) = deepseq a () + diff --git a/src/Dao/Lib/Array.hs b/src/Dao/Lib/Array.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Lib/Array.hs @@ -0,0 +1,165 @@ +-- "src/Dao/Lib/Array.hs" built-in array object +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +-- | This module provides the Dao programming language implementation of the 'Array' built-in data +-- type. 'Array's can be indexed from zero to (n-1) where n is the number of elements in the array. +-- Reads and updates are O(n). Resizing an array is not possible. +module Dao.Lib.Array where + +import Dao.String +import Dao.Predicate +import Dao.Interpreter + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.State + +import Data.Array.IO +import Data.Monoid +import Data.Typeable + +import qualified Data.IntMap as I + +---------------------------------------------------------------------------------------------------- + +-- | The Dao programming language wrapper around Haskell's 'Data.Array.IO.IOArray' data type. +-- To inspect elements of the array outside of the IO monad, the only way for pure functions like +-- 'Dao.PPrint.PPrint' and 'Dao.Binary.Put' to work without being unsafe is to lazily evaluate these +-- functions after every update to the array. These functions are evaluated extra-lazily to ensure +-- that nothing actually happens until it becomes absolutely necessary to use them, if it ever is +-- necessary. +newtype Array = Array { toObjArray :: IOArray Int Object } deriving (Eq, Typeable) + +arrayFromList :: Int -> [(Int, Object)] -> IO Array +arrayFromList len ox = do + arr <- newArray (0, len) ONull + forM_ ox $ \ (i, o) -> writeArray arr i o + return $ Array{ toObjArray=arr } + +arraySize :: Array -> IO Int +arraySize arr = uncurry subtract <$> getBounds (toObjArray arr) + +arrayElems :: Array -> IO [Object] +arrayElems = getElems . toObjArray + +arrayCheckIndex :: Array -> Int -> IO (Predicate ExecControl ()) +arrayCheckIndex arr i = do + bounds <- getBounds (toObjArray arr) + return $ + if inRange bounds i + then OK () + else PFail $ newError{ execErrorMessage=ustr "array index out of bounds" } + +arrayLookup :: Array -> Int -> IO (Predicate ExecControl Object) +arrayLookup arr i = arrayCheckIndex arr i >>= \result -> case result of + PFail err -> return (PFail err) + Backtrack -> return Backtrack + OK () -> OK <$> readArray (toObjArray arr) i + +arrayUpdate :: Array -> Int -> Object -> IO (Predicate ExecControl ()) +arrayUpdate arr i o = arrayCheckIndex arr i >>= \result -> case result of + PFail err -> return $ PFail err + Backtrack -> return Backtrack + OK () -> OK <$> writeArray (toObjArray arr) i o + +instance ReadIterable Array Object where + readForLoop (Array arr) f = liftIO (getBounds arr) >>= + flip execForM_ (liftIO . readArray arr >=> f) . range + +instance UpdateIterable Array (Maybe Object) where + updateForLoop a@(Array arr) f = do + let err = "for loop iteration attempted to delete an item from an Array" + liftIO (getBounds arr) >>= + flip execForM_ (\i -> liftIO (readArray arr i) >>= f . Just >>= + maybe (fail err) return >>= liftIO . writeArray arr i) . range + return a + +instance ObjectFunctor Array Int where + objectFMap f = do + arr <- get + let a = toObjArray arr + (bounds, elems) <- liftIO $ return (,) <*> getBounds a <*> getElems a + forM_ (zip (range bounds) elems) $ \ (i, o) -> focalPathSuffix (Subscript [obj i] NullRef) $ + withInnerLens [] (f i o) >>= \ (_, (changed, ox)) -> + when changed $ forM_ ox (liftIO . uncurry (writeArray $ toObjArray arr)) + +instance ObjectFunctor Array Object where { objectFMap f = objectFMap (\i -> f (obj i)) } +instance ObjectFunctor Array [Object] where { objectFMap f = objectFMap (\i -> f [obj i]) } + +_objToInt :: [Object] -> Exec Int +_objToInt ix = case ix of + [i] -> (derefObject i >>= xmaybe . fromObj) <|> + throwBadTypeError "Array index value cannot be cast to integer" i [] + ix -> throwArityError "Array index is not one-dimensional" 1 ix [] + +arrayFromArgs :: [Object] -> IO Array +arrayFromArgs lists = + forM lists + (\o -> maybe (return (1, [o])) id $ msum $ + [ fromObj o >>= \ox -> Just $ return (length ox, ox) + , fromObj o >>= \arr -> Just $ return (,) <*> arraySize arr <*> arrayElems arr + ] + ) >>= uncurry arrayFromList . (\ (ix, ox) -> (sum ix, zip [0..] $ concat ox)) . unzip + +loadLibrary_Array :: DaoSetup +loadLibrary_Array = do + daoClass (haskellType::Array) + daoFunction "Array" $ + daoFunc + { funcAutoDerefParams=True + , daoForeignFunc = \ () -> fmap (flip (,) () . Just . obj) . liftIO . arrayFromArgs + } + +instance ObjectClass Array where { obj=new; fromObj=objFromHata; } + +instance HataClass Array where + haskellDataInterface = interface "Array" $ do + autoDefEquality >> autoDefReadIterable >> autoDefUpdateIterable >> autoDefTraverse + defSizer (fmap OInt . liftIO . arraySize) + defIndexer $ \arr i -> _objToInt i >>= liftIO . arrayLookup arr >>= predicate + defIndexUpdater $ \i f -> focusLiftExec (_objToInt i) >>= \i -> do + arr <- get + (_arr, (changed, o)) <- focusLiftExec (liftIO (arrayLookup arr i) >>= predicate) >>= + flip withInnerLens f . Just + case o of + Nothing -> fail "cannot delete items from array" + Just o -> when changed (liftIO $ writeArray (toObjArray arr) i o) >> return (Just o) + let init ox = case ox of -- initializer list in round-brackets must be empty + [] -> return (Array $ error "uninitialized Array") -- SUCCESS: return an uninitialized Array + _ -> execThrow "cannot initialize array with parameters" ExecErrorUntyped [] -- FAIL + let fromList m i maxbnd arr ox = case ox of + [] -> liftIO $ arrayFromList maxbnd (I.assocs m) + o:ox -> case o of + InitAssign ref op o -> do + i <- derefObject ref >>= _objToInt . return + if i<0 + then execThrow "assigned to negative index value" op [(assertFailed, OInt i)] + else do + ref <- pure $ fromObj ref <|> Just (RefObject ref NullRef) + o <- evalUpdateOp ref op o (I.lookup i m) + case o of + Just o -> do + a <- fromList (I.insert i o m) (i+1) (max i maxbnd) arr ox + return $ arr{ toObjArray=toObjArray a } + Nothing -> execThrow "index to Array evaluated to void" op $ + maybe [] (\ref -> [(errOfReference, obj ref)]) ref + InitSingle o -> fromList (I.insert i o m) (i+1) (max i maxbnd) arr ox + defInitializer init (fromList mempty 0 0) + diff --git a/src/Dao/Lib/File.hs b/src/Dao/Lib/File.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Lib/File.hs @@ -0,0 +1,208 @@ +-- "src/Dao/Lib/File.hs" built-in plain file object +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +module Dao.Lib.File where + +import Dao.String +import Dao.Predicate +import Dao.PPrint +import qualified Dao.Binary as B +import Dao.Interpreter + +import qualified Data.ByteString.Lazy as B +import qualified Data.Map.Lazy as M +import Data.Typeable + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.State + +import System.IO + +data File = File { filePath :: UStr, fileHandle :: Maybe Handle } deriving Typeable + +instance Eq File where { a==b = filePath a == filePath b } + +instance Ord File where { compare a b = compare (filePath a) (filePath b) } + +instance Show File where { show a = "File("++show (filePath a)++")" } + +instance HasNullValue File where + nullValue = File{ filePath=nil, fileHandle=Nothing } + testNull (File{ filePath=name, fileHandle=Nothing }) = nil==name + testNull (File{}) = False + +instance PPrintable File where { pPrint = pShow } + +instance B.Binary File MethodTable where + get = return File <*> B.get <*> pure Nothing + put f = B.put (filePath f) + +errFilePath :: Name +errFilePath = ustr "filePath" + +_openParamFail :: String -> [Object] -> Exec ig +_openParamFail func ox = + throwArityError "expecting a file path as the only parameter" 1 ox [(errInFunc, obj (ustr func :: Name))] + +_paramPath :: String -> [Object] -> Exec UStr +_paramPath func ox = case ox of + [path] -> xmaybe (fromObj path <|> (filePath <$> fromObj path)) <|> _openParamFail func ox + ox -> _openParamFail func ox + +_catchIOException :: String -> File -> IO a -> Exec a +_catchIOException func file f = execCatchIO (liftIO f) $ + [ newExecIOHandler $ \e -> execThrow "" (ExecIOException e) $ + [(errInFunc, obj (ustr func :: Name)), (errFilePath, obj $ filePath file)] + ] + +_openFile :: String -> File -> IOMode -> Exec File +_openFile func file mode = _catchIOException func file $ + (\o -> file{ fileHandle=Just o}) <$> openFile (uchars $ filePath file) mode + +_getHandle :: String -> File -> Exec Handle +_getHandle func file = case fileHandle file of + Just h -> return h + Nothing -> + execThrow "function evaluated on a file handle which has not been opened" ExecErrorUntyped + [(errInFunc, obj (ustr func :: Name)), (errFilePath, obj $ filePath file)] + +_withClosedHandle :: String -> File -> Exec () +_withClosedHandle func file = case fileHandle file of + Nothing -> return () + Just _ -> execThrow "function cannot operate on open file handle" ExecErrorUntyped + [(errInFunc, obj (ustr func :: Name)), (errFilePath, obj $ filePath file)] + +_withContents :: (String -> IO Object) -> DaoFunc File +_withContents f = + daoFunc + { daoForeignFunc = \file ox -> case ox of + [] -> do + _withClosedHandle "read" file + _catchIOException "read" file $ fmap (flip (,) file . Just) $ readFile (uchars $ filePath file) >>= f + ox -> throwArityError "" 0 ox [(errInFunc, obj (ustr "read" :: Name))] + } + +gGetErrToExecError :: B.GGetErr -> ExecControl +gGetErrToExecError (B.GetErr{ B.gGetErrOffset=offset, B.gGetErrMsg=msg }) = + newError + { execErrorMessage = msg + , execErrorInfo = M.fromList [(ustr "byteOffset", OLong (toInteger offset))] + } + +loadLibrary_File :: DaoSetup +loadLibrary_File = do + let fileOpener func mode = daoFunction func $ + daoFunc + { daoForeignFunc = \ () -> + _paramPath func >=> fmap (flip (,) () . Just . obj) . flip (_openFile func . flip File Nothing) mode + } + fileOpener "readFile" ReadMode + fileOpener "writeFile" WriteMode + fileOpener "appendFile" AppendMode + daoClass (haskellType::File) + daoFunction "File" $ + daoFunc + { daoForeignFunc = \ () -> fmap (flip (,) () . Just . obj . flip File Nothing) . _paramPath "File" + } + +instance ObjectClass File where { obj=new; fromObj=objFromHata; } + +instance HataClass File where + haskellDataInterface = interface "File" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest + autoDefPPrinter >> autoDefBinaryFmt + let fileOpener func mode = defMethod func $ + daoFunc + { funcAutoDerefParams = False + , daoForeignFunc = \file ox -> + case ox of + [] -> do + _withClosedHandle func file + f <- _openFile func file mode + return (Just $ obj f, f) + ox -> throwArityError "" 0 ox [(errInFunc, obj (ustr "File" :: Name))] + } + fileOpener "openRead" ReadMode + fileOpener "openWrite" WriteMode + fileOpener "openAppend" AppendMode + defMethod "close" $ + daoFunc + { funcAutoDerefParams = False + , daoForeignFunc = \file ox -> fmap (flip (,) (file{ fileHandle=Nothing })) $ do + case ox of + [] -> _getHandle "close" file >>= + _catchIOException "close" file . liftIO . hClose >> return Nothing + ox -> throwArityError "" 0 ox [(errInFunc, obj (ustr "close" :: Name))] + } + defMethod "writeBinary" $ + daoFunc + { daoForeignFunc = \file ox -> do + mtab <- gets globalMethodTable + handl <- _getHandle "writeBinary" file + forM_ ox $ \o -> do + bin <- execCatchIO (liftIO $ return (B.encode mtab o)) $ + [ newExecIOHandler $ \e -> execThrow "while encoding object" (ExecHaskellError e) $ + [ (errInFunc, obj (ustr "writeBinary" :: Name)) + , (errFilePath, obj $ filePath file) + ] + ] + _catchIOException "writeBinary" file (B.hPutStr handl bin) + return (Nothing, file) + } + defMethod "readBinary" $ + daoFunc + { daoForeignFunc = \file ox -> case ox of + [] -> do + _withClosedHandle "readBinary" file + mtab <- gets globalMethodTable + bin <- _catchIOException "readBinary" file (liftIO $ B.readFile $ uchars $ filePath file) + result <- execCatchIO (return $ fmapPFail gGetErrToExecError $ B.decode mtab bin) $ + [ newExecIOHandler $ \e -> execThrow "while decoding object" (ExecHaskellError e) $ + [(errInFunc, obj (ustr "readBinary" :: Name)), (errFilePath, obj $ filePath file)] + ] + predicate result + ox -> throwArityError "" 0 ox [(errInFunc, obj (ustr "readBinary" :: Name))] + } + let writeFunc func putstr = defMethod func $ + daoFunc + { daoForeignFunc = \file ox -> do + ox <- requireAllStringArgs func ox + handl <- _getHandle func file + forM_ ox $ _catchIOException "write" file . putstr handl . uchars + return (Nothing, file) + } + writeFunc "write" hPutStr + defMethod "read" $ _withContents (return . obj) + defMethod "readAllLines" $ _withContents (return . obj . fmap obj . lines) + writeFunc "writeLine" hPutStrLn + defMethod "readLine" $ + daoFunc + { daoForeignFunc = \file ox -> case ox of + [] -> do + handl <- _getHandle "readLine" file + _catchIOException "readLine" file (flip (,) file . Just . obj <$> hGetLine handl) + ox -> throwArityError "" 0 ox [(errInFunc, obj (ustr "readLine" :: Name))] + } + let defPrinter func print = defMethod func $ + makePrintFunc $ \file str -> _getHandle func file >>= \h -> liftIO (print h str) + defPrinter "print" hPutStr + defPrinter "println" hPutStrLn + diff --git a/src/Dao/Lib/ListEditor.hs b/src/Dao/Lib/ListEditor.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Lib/ListEditor.hs @@ -0,0 +1,222 @@ +-- "src/Dao/Lib/ListEditor.hs" built-in object for Dao programs that can +-- functions like a line editor, but for arbitrary types, not just strings. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +-- | This is a line-editor object, but it works with arbitrary lists of objects, but this will work +-- for editing arbitrary lists. You could use it to create an ordinary line editor by representing a +-- file as be a list of strings representing a file. each string could further be converted to a +-- StepList containing characters to edit the line. +module Dao.Lib.ListEditor where + +import Dao.String +import Dao.StepList +import Dao.Predicate +import Dao.PPrint +import qualified Dao.Binary as B +import Dao.Interpreter +import Dao.Interpreter.AST + +import Control.Applicative +import Control.Monad +import Control.Monad.State + +import Data.Monoid +import qualified Data.IntMap as I +import Data.Typeable + +---------------------------------------------------------------------------------------------------- + +newtype ListEditor = ListEditor { listEditor :: StepList Object } deriving (Eq, Ord, Show, Typeable) + +loadLibrary_ListEditor :: DaoSetup +loadLibrary_ListEditor = do + daoClass (haskellType::ListEditor) + +instance Monoid ListEditor where + mempty = ListEditor mempty + mappend (ListEditor a) (ListEditor b) = ListEditor (a<>b) + +instance HasNullValue ListEditor where + nullValue = mempty + testNull (ListEditor sl) = slNull sl + +instance ToDaoStructClass ListEditor where + toDaoStruct = renameConstructor "ListEditor" $ do + "left" .=@ slLeftOfCursor . listEditor + "right" .=@ slRightOfCursor . listEditor + +instance FromDaoStructClass ListEditor where + fromDaoStruct = do + constructor "ListEditor" + left <- optList "left" + right <- optList "right" + return $ ListEditor $ slFromLeftRight left right + +instance PPrintable ListEditor where { pPrint = pPrintStructForm } + +instance B.Binary ListEditor MethodTable where + put (ListEditor sl) = B.put (slCursor sl) >> B.put (slLeftOfCursor sl ++ slRightOfCursor sl) + get = B.get >>= \cur -> + ListEditor . slCursorTo cur . uncurry slFromLeftRight . splitAt cur <$> B.get + +instance ReadIterable ListEditor Object where + readForLoop (ListEditor sl) = execForM_ (slToList sl) + +instance UpdateIterable ListEditor (Maybe Object) where + updateForLoop (ListEditor sl) = fmap (ListEditor . slFromList (slCursor sl) . + concatMap (maybe [] return)) . execForM (fmap Just $ slToList sl) + +instance ObjectClass ListEditor where { obj=new; fromObj=objFromHata; } + +_getIndex :: [Object] -> Predicate err Int +_getIndex ix = case ix of + [i] -> xmaybe (fromObj i) + _ -> fail "must index ListEditor with a 1-dimentional integer value" + +_withRange :: String -> (Int -> Int -> Exec a) -> [Object] -> Exec a +_withRange func f ox = do + let err = throwArityError "expecting one or two integer parameters" 2 ox $ + [(errInFunc, obj (ustr func :: Name))] + case ox of + [] -> err + [a] -> do + a <- xmaybe (fromObj a) <|> + throwBadTypeError "index parameter received is not an integer value" a + [(errInFunc, obj (ustr func :: Name))] + f (min 0 a) (max 0 a) + [a, b] -> do + let param n a = xmaybe (fromObj a) <|> + (throwBadTypeError "in range to ListEditor" a $ + [(errInConstr, obj (ustr func :: Name)), (argNum, OInt n)] + ) + param 1 a >>= \a -> param 2 b >>= \b -> f (min a b) (max a b) + _ -> err + +instance ObjectLens ListEditor Int where + updateIndex i f = do + sl <- slCursorTo i . listEditor <$> get + (o, right) <- pure $ case slRightOfCursor sl of + [] -> (Nothing, []) + o:ox -> (Just o, ox) + (result, (changed, o)) <- withInnerLens o f + when changed $ put $ ListEditor $ case o of + Nothing -> sl{slRightOfCursor=right, slLength=slLength sl - 1} + Just o -> sl{slRightOfCursor=o:right } + return result + +instance ObjectFunctor ListEditor Int where + objectFMap f = do + (ListEditor sl) <- get + o <- mapM (fmap snd . withInnerLens [] . uncurry f) $ concat $ + [ reverse $ + if slCursor sl > 0 + then zip (map negate [1..slCursor sl]) (slLeftOfCursor sl) + else [] + , zip [0..] (slRightOfCursor sl) + ] + (changed, o) <- return $ unzip o + when (or changed) $ + put $ ListEditor $ slCursorTo (slCursor sl) $ slFromIntMap $ I.fromList $ concat o + +instance ObjectFunctor ListEditor [Object] where { objectFMap f = objectFMap (\i -> f [obj i]) } + +instance Sizeable ListEditor where { getSizeOf = return . obj . slLength . listEditor } + +instance HataClass ListEditor where + haskellDataInterface = interface "ListEditor" $ do + autoDefEquality >> autoDefOrdering >> autoDefNullTest + autoDefPPrinter >> autoDefToStruct >> autoDefFromStruct + autoDefSizeable >> return () + autoDefReadIterable >> autoDefUpdateIterable >> autoDefTraverse + defIndexer $ \ (ListEditor sl) -> fmap (flip slIndex sl) . predicate . _getIndex >=> xmaybe + defIndexUpdater (\ix f -> predicate (_getIndex ix) >>= flip updateIndex f) + defInitializer + (\ox -> + if null ox + then return mempty + else predicate $ (\i -> ListEditor $ mempty{ slCursor=i }) <$> _getIndex ox + ) + (\ (ListEditor sl) ox -> do + let loop im ox = case ox of + [] -> return $ ListEditor $ slCursorTo (slCursor sl) $ slFromIntMap im + (i, o):ox -> case o of + InitSingle o -> loop (I.insert i o im) ox + InitAssign ref op o -> do + i <- (fromObj <$> derefObject ref >>= xmaybe) <|> + (throwBadTypeError "ListEditor constructor assigns value to non-integer type" ref $ + [(errInFunc, obj (ustr "ListEditor" :: Name))] + ) + o <- evalUpdateOp (Just $ RefObject ref NullRef) op o (I.lookup i im) + loop (I.alter (const o) i im) ox + loop mempty (zip [(slCursor sl)..] ox) + ) + let deref sl = case slRightOfCursor sl of { [] -> Nothing; o:_ -> Just o; } + defDeref (return . deref . listEditor) + defInfixOp SHL $ \ _ (ListEditor sl) o -> case o of + OList ox -> return $ obj $ ListEditor (ox<++sl) + o -> return $ obj $ ListEditor (o <| sl) + defInfixOp SHR $ \ _ (ListEditor sl) o -> case o of + OList ox -> return $ obj $ ListEditor (ox++>sl) + o -> return $ obj $ ListEditor (o |>sl) + defInfixOp ADD $ \ _ (ListEditor a) o -> do + (ListEditor b) <- xmaybe (fromObj o) <|> fail "added ListEditor object to non-ListEditor object" + return $ obj $ ListEditor (a<>b) + defMethod "insertLeft" $ + daoFunc + { daoForeignFunc = \ (ListEditor sl) ox -> pure (snd (objConcat ox) <++ sl) >>= \sl -> return $ + (Just $ obj $ ListEditor sl, ListEditor sl) + } + defMethod "insertRight" $ + daoFunc + { daoForeignFunc = \ (ListEditor sl) ox -> pure (snd (objConcat ox) ++> sl) >>= \sl -> return $ + (Just $ obj $ ListEditor sl, ListEditor sl) + } + defMethod "cursorTo" $ + daoFunc + { daoForeignFunc = \ (ListEditor sl) ox -> predicate (_getIndex ox) >>= \i -> + pure (slCursorTo i sl) >>= \sl -> return (deref sl, ListEditor sl) + } + defMethod "shift" $ + daoFunc + { daoForeignFunc = \ (ListEditor sl) ox -> predicate (_getIndex ox) >>= \i -> + pure (slCursorShift i sl) >>= \sl -> return (deref sl, ListEditor sl) + } + defMethod "copy" $ + daoFunc + { daoForeignFunc = \ (ListEditor sl) -> _withRange "copy" $ \a b -> return $ + (Just $ obj $ ListEditor $ slCopyRelRange (a, b) sl, ListEditor sl) + } + defMethod "cut" $ + daoFunc + { daoForeignFunc = \ (ListEditor sl) -> _withRange "cut" $ \a b -> return $ + (Just $ obj $ ListEditor $ slCopyRelRange (a, b) sl, ListEditor $ slDeleteRelRange (a, b) sl) + } + defMethod "copyRange" $ + daoFunc + { daoForeignFunc = \ (ListEditor sl) -> _withRange "copyRange" $ \a b -> return $ + (Just $ obj $ ListEditor $ slCopyAbsRange (a, b) sl, ListEditor sl) + } + defMethod "cutRange" $ + daoFunc + { daoForeignFunc = \ (ListEditor sl) -> _withRange "cut" $ \a b -> return $ + (Just $ obj $ ListEditor $ slCopyAbsRange (a, b) sl, ListEditor $ slDeleteAbsRange (a, b) sl) + } + defInfixOp ADD $ \ _ (ListEditor sl) -> + xmaybe . fromObj >=> \ (ListEditor o) -> return (obj $ ListEditor $ sl <> o) + diff --git a/src/Dao/PPrint.hs b/src/Dao/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Dao/PPrint.hs @@ -0,0 +1,358 @@ +-- "src/Dao/PPrintM.hs" a pretty-printer designed especially for +-- printing Dao script code. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Dao.PPrint where + +import Dao.String +import qualified Dao.Tree as T + +import qualified Data.Map as M + +import Control.Monad.State + +import Data.List +import Data.Char +import Data.Monoid + +---------------------------------------------------------------------------------------------------- + +-- | This is the function you will probably care about most: take a value of any data type that +-- instantiates 'PPrintable', and a maximum text-wrapping width value, and a tab string, and will +-- convert that value to a 'Prelude.String'. +prettyPrint :: PPrintable a => Int -> String -> a -> String +prettyPrint maxWidth tab = showPPrint maxWidth tab . pPrint + +-- | Calls 'prettyPrint' with the default values @80@ for the text-wrapping width, and a tab string +-- consisting of four single-space characters (four ASCII @0x20@ characters). +prettyShow :: PPrintable a => a -> String +prettyShow = prettyPrint 80 " " + +---------------------------------------------------------------------------------------------------- + +-- | Remove trailing whitespace, I stole the idea from the Perl language. +chomp :: String -> String +chomp = foldl (\ out (spc, str) -> if null str then out else out++spc++str) "" . spcstr where + spcstr cx = case cx of + "" -> [] + cx -> (spc, str) : spcstr cx' where + (spc, more) = span isSpace cx + (str, cx' ) = break isSpace more + +-- | like 'Prelude.map', but doesn't touch the last item in the list. +mapAlmost :: (a -> a) -> [a] -> [a] +mapAlmost fn ax = case ax of + [] -> [] + [a] -> [a] + a:ax -> fn a : mapAlmost fn ax + +-- | like 'Prelude.map', but doesn't touch the first item in the list. +mapTail :: (a -> a) -> [a] -> [a] +mapTail fn ax = case ax of + [] -> [] + a:ax -> a : map fn ax + +---------------------------------------------------------------------------------------------------- + +class PPrintable a where { pPrint :: a -> PPrintM () } +type PPrint = PPrintM () + +-- | Put a new line regardless of whether or not we are aleady on a new line. +pNewLine :: PPrint +pNewLine = modify $ \st -> + st{ printerCol = 0 + , printerBuf = "" + , printerOut = printerOut st ++ [printerOutputTripple st] + , lineCount = lineCount st + 1 + , printerTab = nextTab st + } + +-- | Like 'pNewLine' but also indicates that there *must* be a new line here (like after a comment) +-- to prevent lines from being joined. +pForceNewLine :: PPrint +pForceNewLine = modify (\st -> st{forcedNewLine=True}) + +-- | Place a new line unless we are already on a new line. +pEndLine :: PPrint +pEndLine = gets printerCol >>= \col -> + if col==0 then modify (\st -> st{printerTab=nextTab st}) else pNewLine + + +pIndent :: PPrint -> PPrint +pIndent indentedPrinter = do + tab <- gets nextTab + modify (\st -> st{nextTab=tab+1}) + indentedPrinter + modify (\st -> st{nextTab=tab}) + +instance PPrintable () where { pPrint = return } +instance PPrintable UStr where { pPrint = pUStr } +instance PPrintable Name where { pPrint = pUStr . toUStr } +instance PPrintable t => PPrintable (T.Tree Name t) where + pPrint t = case t of + T.Void -> pString "tree" + T.Leaf o -> leaf o + T.Branch ox -> pList (pString "tree") "{ " ", " " }" (branch ox) + T.LeafBranch o ox -> pList (leaf o) " { " ", " " }" (branch ox) + where + leaf o = pWrapIndent [pString "tree(", pPrint o, pString ")"] + branch = map (\ (lbl, o) -> pMapAssoc (lbl, o)) . M.assocs + +instance PPrintable Base16String where { pPrint = pShow } +instance PPrintable Base64String where { pPrint = pShow } + +pMapAssoc :: (PPrintable a, PPrintable o) => (a, o) -> PPrint +pMapAssoc (a, o) = pWrapIndent [pPrint a, pString " = ", pPrint o] + +-- not for export +appendString :: Int -> String -> PPrint +appendString len str = modify $ \st -> + st{ printerCol = printerCol st + len + , printerBuf = printerBuf st ++ str + , charCount = charCount st + len + } + +-- | Print a 'Dao.String.UStr' as a single line. +pUStr :: UStr -> PPrint +pUStr u = if nil==u then return () else appendString (ulength u) (uchars u) + +-- | Print a 'Prelude.String' as a single line. +pString :: String -> PPrint +pString s = if null s then return () else appendString (length s) s + +-- | Print any value that instantiates 'Prelude.Show'. +pShow :: Show a => a -> PPrint +pShow = pString . show + +-- | Shortcut for @('pPrint' . 'Data.List.concat')@ +pConcat :: [String] -> PPrint +pConcat = pString . concat + +-- | Just keep printing items along the line without wrapping until a 'pNewLine' or 'pEndLine' +-- occurs. Actually, this function simply a synonym for 'Control.Monad.sequence_'. +pNoWrap :: [PPrint] -> PPrint +pNoWrap = sequence_ + +-- | Try to print with the given function, but if the printed text runs past the 'maxWidth', or if +-- the printed text results in multiple lines of output, end the current line of text before +-- placing the text from the given function. +pWrap :: PPrint -> PPrint +pWrap fn = do + st <- get + let trySt = execState fn (subprint st) + if printerCol st + charCount trySt > maxWidth st then pEndLine else return () + appendState trySt + +-- | Evaluate the 'PPrintM' printer, and every line of output will be used as an item in a list and +-- printed across a line, wrapping on to the next line if the line goes past the width limit. +pInline :: [PPrint] -> PPrint +pInline = sequence_ . map pWrap + +-- | Like 'pInline' but if the line wraps, every line after the first will be indented. +pWrapIndent :: [PPrint] -> PPrint +pWrapIndent px = do + st <- get + let trySt = execState (pInline px) (subprint st) + case printerOut trySt of + [] -> appendState trySt + p:px -> + let ind (tab, len, str) = (tab+1, len, str) + in appendState (trySt{printerOut = p : map ind px, printerTab = printerTab trySt + 1}) + +-- | Will evaluate a 'PPrintM' function to create a block of text, and if the block of text can be +-- fit into a single line, it will be placed inline with the text precceding and succeeding it. +-- If it cannot be placed into a single line, it will be preceeded and succeeded by a 'pEndLine'. +-- Passing 'Prelude.False' as the first parameter means 'pEndLine' will not succeed the block of +-- text, which can come in handy (for example) when you need to follow an item with a closing +-- punctuation mark like a comma or semicolon, and you don't want that closing punctuation on the +-- next line. +pGroup :: Bool -> PPrint -> PPrint +pGroup after fn = do + st <- get + let trySt = execState (pEndLine >> fn) (subprint st) + if charCount trySt > maxWidth st || forcedNewLine trySt + then pEndLine >> appendState trySt >> (if after then pEndLine else return ()) + else appendState (stateJoinLines trySt) + +pList :: PPrint -> String -> String -> String -> [PPrint] -> PPrint +pList header open separator close px = do + let sep = ustr separator + pGroup False $ do + header >> pString open >> pEndLine + pIndent $ pInline $ map (pGroup True) $ mapAlmost (>>(pUStr sep)) px + pEndLine >> pString close + +-- | Like 'pList' but there is no need to pass the first @'PPrintM' ()@ header parameter, this +-- parameter is set to @'Prelude.return' ()@. +pList_ :: String -> String -> String -> [PPrint] -> PPrint +pList_ = pList (return ()) + +pClosure :: PPrint -> String -> String -> [PPrint] -> PPrint +pClosure header open close px = do + st <- get + let content = do + header >> pString open >> pEndLine + pIndent (sequence_ $ mapAlmost (>>pEndLine) px) + pEndLine >> pString close + trySt = execState content (subprint st) + if charCount trySt + printerCol st > maxWidth st then pEndLine else return () + appendState trySt + +-- | A commonly used pattern, like 'pClosure' but the contents of it is always a list of items which +-- can be pretty-printed by the given @(o -> 'PPrintM' ())@ function. +pContainer :: String -> (o -> PPrint) -> [o] -> PPrint +pContainer label prin ox = pList (pString label) "{ " ", " " }" (map prin ox) + +---------------------------------------------------------------------------------------------------- + +type PPrintM a = State Printer a +type POutput = (Int, Int, UStr) + +-- not for export +data Printer + = Printer + { printerTab :: Int -- how many indentation marks should preceed this line + , printerCol :: Int -- how many non-indentation characters are in the buffer + , printerOut :: [POutput] -- all lines before the current line in the buffer + , printerBuf :: String -- buffers the current line + , nextTab :: Int + , lineCount :: Int -- how many lines have been printed + , charCount :: Int -- how many characters have been printed + , maxWidth :: Int + , forcedNewLine :: Bool + } + +initPrinter :: Int -> Printer +initPrinter width = + Printer + { printerTab = 0 + , printerCol = 0 + , printerOut = [] + , printerBuf = "" + , maxWidth = width + , lineCount = 0 + , charCount = 0 + , nextTab = 0 + , forcedNewLine = False + } + +printerOutputTripple :: Printer -> (Int, Int, UStr) +printerOutputTripple st = (printerTab st, printerCol st, ustr (printerBuf st)) + +instance Monoid Printer where + mempty = initPrinter 80 + mappend origSt st = case printerOut st of + [] -> + (combine origSt st) + { printerBuf = printerBuf origSt ++ printerBuf st + , printerCol = printerCol origSt + printerCol st + } + (_, col, buf):out -> + (combine origSt st) + { printerOut = printerOut origSt ++ + (printerTab origSt, printerCol origSt + col, ustr (printerBuf origSt ++ uchars buf)) : out + , printerBuf = printerBuf st + , printerCol = printerCol st + } + where + combine origSt st = + origSt + { charCount = charCount origSt + charCount st + , lineCount = lineCount origSt + lineCount st + , maxWidth = maxWidth origSt + , printerTab = printerTab st + , nextTab = nextTab st + , forcedNewLine = forcedNewLine origSt || forcedNewLine st + } + +-- | Force a string into the 'printerBuf' buffer without modifying anything else. This should allow +-- you to put markers into the output without effecting any of the metrics used to control how the +-- output is indented or wrapped. +pDebug :: (Printer -> String) -> PPrint +pDebug fn = do + st <- get + let msg = "["++fn st++"]" + put (st{printerBuf=printerBuf st ++ seq msg msg}) + +stateJoinLines :: Printer -> Printer +stateJoinLines st = + st{printerBuf = str ++ printerBuf st, printerCol = len + printerCol st, printerOut=[]} where + (len, str) = foldl joinln (0, "") (printerOut st) + joinln (len0, str0) (_, len1, str1) = (len0+len1, str0 ++ uchars str1) + +appendState :: Printer -> PPrint +appendState = modify . flip mappend + +-- | A kind of pre-conversion, the 'PPrintState' is broken into a list of strings, each string +-- preceeded by it's indentation factor. +linesFromPPrintState :: Int -> PPrint -> [(Int, String)] +linesFromPPrintState maxWidth ps = end (execState ps (initPrinter maxWidth)) where + end st = flip map (printerOut st ++ [printerOutputTripple st]) $ \ (a, _, b) -> + (a, dropWhile isSpace (chomp (uchars b))) + +printAcross :: [PPrint] -> PPrint +printAcross px = case px of + [] -> return () + p:px -> do + st <- get + st <- return (st{printerBuf = printerBuf st}) + let trySt = execState p (subprint st) + if withinMaxWidth st trySt + then put (mappend st trySt) + else pEndLine >> modify (\st -> mappend st trySt) + printAcross px + +withinMaxWidth :: Printer -> Printer -> Bool +withinMaxWidth st trySt = null (printerOut trySt) && printerCol st + printerCol trySt <= maxWidth st + +subprint :: Printer -> Printer +subprint st = st{printerBuf="", printerCol=0, printerOut=[], charCount=0, lineCount=0} + +tabAll :: Bool -> [POutput] -> [POutput] +tabAll alsoTabFinalLine ax = case ax of + [] -> [] + [(tab, len, str)] -> if alsoTabFinalLine then [(tab+1, len, str)] else [(tab, len, str)] + (tab, len, str):ax -> (tab+1, len, str) : tabAll alsoTabFinalLine ax + +-- | Given a list of strings, each prefixed with an indentation count, and an indentation string, +-- concatenate all strings into a one big string, with each string being indented and on it's own +-- line. +linesToString :: String -> [(Int, String)] -> String +linesToString indentStr = intercalate "\n" . + map (\ (indentCount, content) -> concat (replicate indentCount indentStr) ++ content) + +-- Given an indentation string and a maximum width value, construct a string from the 'PPrintState'. +-- The maximum width value is used to call 'linesFromPPrintState', and the indentation string is +-- used to call 'linesToString'. +showPPrint :: Int -> String -> PPrint -> String +showPPrint maxWidth indentStr ps = linesToString indentStr (linesFromPPrintState maxWidth ps) + +---------------------------------------------------------------------------------------------------- + +-- | Statements like "if" or "while" take a condition, and the Dao languages does not require these +-- conditions be enclosed in parenthases. The question is, should there be a space after the "if" or +-- "while" statement? This function resolves that question by checking if an object expression +-- already is enclosed in parentheses, and if so, does not put a space. Otherwise, a space will be +-- printed between the "if" tag or "while" tag and the condition. +class PrecedeWithSpace a where { precedeWithSpace :: a -> Bool } +instance PrecedeWithSpace Name where { precedeWithSpace _ = True } + diff --git a/src/Dao/Parser.hs b/src/Dao/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Parser.hs @@ -0,0 +1,1927 @@ +-- "src/Dao/Parser.hs" a parser for defining general context-free +-- grammars that are parsed in two phases: the lexical and the +-- syntactic analysis phases. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +module Dao.Parser where + +import Dao.String +import Dao.Token +import Dao.Predicate +import qualified Dao.Interval as Iv + +import Control.Applicative +import Control.Monad +import Control.Monad.Cont +import Control.Monad.State +import Control.Monad.Error.Class + +import Data.Data +import Data.Tuple +import Data.Monoid +import Data.Maybe +import Data.Word +import Data.Char hiding (Space) +import Data.List +import Data.Array.IArray +import qualified Data.Map as M + +---------------------------------------------------------------------------------------------------- +-- $Lexer_builder +-- When defining a computer language, one essential step will be to define your keywords and +-- operators, and define tokens for these keywords and operators. +-- +-- However, it might be more convenient if there was a way to simply declare to your program "here +-- are my keywords, here are my operators, here is how you lex comments, here is how you lex white +-- spaces", stated simply using Haskell functions, and then let the token types be derived from +-- these declarations. The functions in this section intend to provide you with this ability. + +-- | Here is class that allows you to create your own token type from a Haskell newtype, like so: +-- > newtype MyToken = MyToken{ unwrapMyToken :: TT } +-- > instance TokenType MyToken where +-- > 'wrapTT' = MyToken +-- > 'unwrapTT' = unwrapMyToken +-- > +-- > myTokenDB = 'makeTokenDB' $ do +-- > .... +class (Ix a, Show a) => TokenType a where { wrapTT :: TT -> a; unwrapTT :: a -> TT; } +instance TokenType TT where { wrapTT = id; unwrapTT = id; } + +-- | An actual value used to symbolize a type of token is a 'TT'. For example, an integer token +-- might be assigned a value of @('TT' 0)@ a keyword might be @('TT' 1)@, an operator might be +-- @('TT' 2)@, and so on. You do not define the numbers representing these token types, these +-- numbers are defined automatically when you construct a 'LexBuilderM'. +-- +-- A 'TT' value is just an integer wrapped in an opaque newtype and deriving 'Prelude.Eq', +-- 'Prelude.Ord', 'Prelude.Show', and 'Data.Ix.Ix'. The constructor for 'TT' is not exported, so you +-- can rest assured any 'TT' objects in your program can only be generated during construction of a +-- 'LexBuilderM'. +-- +-- It is also a good idea to wrap this 'TT' type in your own newtype and define your parser over +-- your newtype, which will prevent you from confusing the same 'TT' type in two different parsers. +-- For example: +-- > newtype MyToken { myTokenTT :: TT } +-- > myLexer :: 'Lexer' MyToken () +-- > myLexer = ... +-- If you instantiate your newtype into the 'TokenType' class, you can also very easily instantiate +-- 'Prelude.Read' and 'Prelude.Show' for your tokens. +newtype TT = MkTT{ intTT :: Int } deriving (Eq, Ord, Ix, Typeable) +instance Show TT where { show (MkTT tt) = "TT"++show tt } + +-- Not for export, wouldn't want people making arbitrary 'TT's now, would we? +enumTTFrom :: TT -> TT -> [TT] +enumTTFrom (MkTT a) (MkTT b) = map MkTT [a..b] + +-- | The data type constructed from the 'LexBuilderM' monad, used to build a 'Lexer' for your +-- programming language, and also can be used to define the 'Prelude.Show' instance for your token +-- type using 'deriveShowFromTokenDB'. +data TokenDB tok = + TokenDB + { tableTTtoUStr :: Array TT UStr + , tableUStrToTT :: M.Map UStr TT + , tokenDBLexer :: Lexer tok () + } + +-- | A state for the 'LexBuilderM' monad, used to declaring the regular expressions for a lexer. This +-- state is converted to a 'TokenDB' which is used by the parser to identify tokens. +-- > myTokens :: 'LexBuilderM' +-- > myTokens = do +-- > let keyword = 'stringTable' . 'Prelude.unwords' +-- > keyword "if then else case of let in where" +-- > key "() == /= -> \\ : :: ~ @" +-- > lexer "string.literal" 'lexStringLiteral' +-- > lexer "comment.endline" 'lexEndlineC_Comment' +-- > lexer "comment.inline" 'lexInlineC_Comment' +-- > -- (The dots in the token type name do not mean anything, it just looks nicer.) +data LexBuilderState + = LexBuilderState + { regexItemCounter :: TT + , stringToIDTable :: M.Map UStr TT + -- ^ contains all simple lexers which do not establish loops. This would be any lexer that + -- takes a keyword or operator, or a lexer constructed from a 'Regex' (which might or might + -- not loop) but produces only one kind of token. + } + +newtype LexBuilderM a = LexBuilderM{ runLexBuilder :: State LexBuilderState a } +type LexBuilder tok = LexBuilderM (Lexer tok ()) + +instance Monad LexBuilderM where + return = LexBuilderM . return + (LexBuilderM a) >>= b = LexBuilderM (a >>= runLexBuilder . b) +instance Functor LexBuilderM where { fmap f (LexBuilderM m) = LexBuilderM (fmap f m) } +instance Applicative LexBuilderM where { pure = return; (<*>) = ap; } +instance Monoid a => + Monoid (LexBuilderM a) where { mempty = return mempty; mappend = liftM2 mappend; } + +-- | This class exists to make 'emptyToken', 'fullToken', and 'activate' functions polymorphic over +-- two different types: the 'RegexBaseType's and 'Regex' and @['Regex']@ types. +class RegexType rx where { toRegex :: rx -> Regex } +instance RegexType Char where { toRegex = rx } +instance RegexType String where { toRegex = rx } +instance RegexType UStr where { toRegex = rx } +instance RegexType (Iv.Set Char) where { toRegex = rx } +instance RegexType [Iv.Set Char] where { toRegex = rx } +instance RegexType Regex where { toRegex = id } +instance RegexType [Regex] where { toRegex = mconcat } +instance RegexType (Char, Char) where { toRegex = rx } +instance RegexType [(Char, Char)] where { toRegex = rx } + +-- example :: Regex +-- example = regex 'a' "hello" ('0', '9') + +-- not for export +initLexBuilder :: LexBuilderState +initLexBuilder = LexBuilderState (MkTT 1) mempty + +-- not for export +newTokID :: UStr -> State LexBuilderState TT +newTokID u = do + tok <- fmap (M.lookup u) (gets stringToIDTable) + case tok of + Nothing -> do + tok <- gets regexItemCounter + modify $ \st -> + st{ regexItemCounter = MkTT (intTT tok + 1) + , stringToIDTable = M.insert u tok (stringToIDTable st) + } + return tok + Just tok -> return tok + +-- not for export +makeRegex :: RegexType rx => Bool -> UStr -> rx -> LexBuilderM Regex +makeRegex keep u re = LexBuilderM $ newTokID u >>= \tok -> + return (toRegex re . (if keep then rxToken else rxEmptyToken) tok) + +-- | The 'tokenHold' function creates a token ID and associates it with a type that is used to +-- construct a 'Regex', and returns the 'Regex' to the 'LexBuilderM' monad. However this does not +-- actually 'activate' the 'Regex', it simply allows you to use the returned 'Regex' in more +-- complex expressions that might construct multiple tokens. You can 'tokenHold' expressions in any +-- order, ordering is not important. +fullToken :: (UStrType str, RegexType rx) => str -> rx -> LexBuilderM Regex +fullToken s = makeRegex True (toUStr s) + +-- | 'token' has identical behavior as 'tokenHold', except the 'Regex' created will produce an empty +-- token, that is, a token that only indicates it's type and contains none of the string that +-- matched the regular expression. This can be done when it is clear (or you do not care) what +-- string was lexed when the token was created just by knowing the type of the token, for example +-- whitespace tokens, or keyword tokens which have the text used to create the token easily +-- retrievable by converting token to a string. Making use of 'token' can greatly improveme +-- performance as compared to using 'tokenHold' exclusively. +emptyToken :: (UStrType str, RegexType rx) => str -> rx -> LexBuilderM Regex +emptyToken s = makeRegex False (toUStr s) + +-- | Activating a regular expression actually converts the regular expression to a 'Lexer'. The +-- /order of activation is important/, expressions that are defined first will have the first try at +-- lexing input strings, followed by every expression activated after it in order. It is also NOT +-- necessary to define an expression with 'regex' or 'regexHold' before activating it, however +-- expressions that have not been associated with a token type will simply consume input without +-- producing any tokens. This might be desireable for things like whitespace, but it is usually not +-- what you want to do. +activate :: (TokenType tok, RegexType rx) => rx -> LexBuilder tok +activate = return . regexToLexer . toRegex + +-- | An array of tokenizers with every tokenizer indexed by the very first character they accept. +data LexTable lexFunc + = LexNoTable{ lexFinal :: lexFunc } + | LexTable{ lexTableArray :: Array Char (lexFunc), lexFinal :: lexFunc } + +-- | Create a 'LexTable' array with the given list of 'Regex's, the indecies of the array created +-- are determined by the lowest and highest possible characters that of all of the 'Regex's you +-- provide. If your parser works with UTF characters beyond the ASCII range, the arrays can get +-- pretty big if you are not careful. Try to group parsers together that are near each other in the +-- UTF table, which involves making sure the 'Prelude.Int' value returned by 'Data.Char.ord' for the +-- characters that the tokenizer can match are all near each other on the number line. If your +-- parser only works on ASCII characters, you have nothing to worry about, your tokenizer array will +-- not be larger than 128 indecies. +makeRegexTable :: RegexType rx => rx -> LexTable Regex +makeRegexTable regex = case regexToLexerPairs (toRegex regex) of + ([] , final) -> LexNoTable final + (elems, final) -> LexTable (accumArray mappend mempty bounds elems) final where + bounds = foldl (\ (lo, hi) c -> (min lo c, max hi c)) (initIdx, initIdx) (map fst elems) + initIdx = fst (head elems) + +lexTableRegexToLexer :: TokenType tok => LexTable Regex -> LexTable (Lexer tok ()) +lexTableRegexToLexer table = case table of + LexNoTable regex -> LexNoTable (regexToLexer regex) + LexTable table regex -> LexTable (amap regexToLexer table) (regexToLexer regex) + +makeLexTable :: (TokenType tok, RegexType rx) => rx -> LexTable (Lexer tok ()) +makeLexTable = lexTableRegexToLexer . makeRegexTable + +lexTableToLexer :: TokenType tok => LexTable (Lexer tok ()) -> Lexer tok () +lexTableToLexer table = case table of + LexNoTable final -> final + LexTable table final -> do + cx <- gets lexInput + case cx of + [] -> mzero + c:_ -> if inRange (bounds table) c then table!c else final + +-- | If you don't care about the 'LexTable' value but want to convert the 'Regex' to a 'Lexer' using a +-- 'LexTable', use this function. The array will be allocated in memory and used to perform lexing, +-- but your code will never see a reference to the 'LexTable' as it is passed directly to +-- 'lexTableToLexer'. This function is defined as: +-- > 'lexTableToLexer' . 'lexTableRegexToLexer' . 'makeRegexTable' +regexToTableLexer :: (RegexType rx, TokenType tok) => rx -> Lexer tok () +regexToTableLexer = lexTableToLexer . lexTableRegexToLexer . makeRegexTable + +-- | Once you have defined your 'LexBuilderM' function using monadic notation, convert the value of +-- this function to a 'TokenDB' value. The 'TokenDB' is mostly handy for retreiving the string +-- values associated with each token ID created by the 'newTokenType' function, for example when +-- using 'dervieShowFromTokenDB' which uses a 'TokenDB' to produce a function suitable for +-- instantiating your @'TokenType'@ into the 'Prelude.Show' class. +makeTokenDB :: TokenType tok => LexBuilderM (Lexer tok ()) -> TokenDB tok +makeTokenDB builder = + TokenDB + { tableTTtoUStr = array (MkTT 1, regexItemCounter st) $ + fmap swap $ fmap (fmap unwrapTT) $ M.assocs tabmap + , tokenDBLexer = mplus (void (many lexer)) (return ()) + , tableUStrToTT = tabmap + } + where + tabmap = stringToIDTable st + (lexer, st) = runState (runLexBuilder builder) $ + LexBuilderState{regexItemCounter=MkTT 1, stringToIDTable=mempty} + +-- | This function lets you easily "derive" the instance for 'Prelude.Show' for a given 'TokenType' +-- associated with a 'TokenDB'. It should be used like so: +-- > newtype MyToken = MyToken{ unwrapMyToken :: TT } +-- > instance 'TokenType' MyToken where{ wrapTT = MyToken; unwrapTT = unwrapMyToken; } +-- > instance 'Prelude.Show' MyToken where{ show = 'deriveShowFromTokenDB' myTokenDB } +-- > myTokenDB :: 'TokenDB' MyToken +-- > myTokenDB = 'makeTokenDB' $ .... +deriveShowFromTokenDB :: TokenType tok => TokenDB tok -> tok -> String +deriveShowFromTokenDB tokenDB tok = + let str = uchars (tableTTtoUStr tokenDB ! unwrapTT tok) + in if or (map (not . isAlphaNum) str) then show str else str + +tokTypeToUStr :: (TokenType tok, HasTokenDB tok) => tok -> UStr +tokTypeToUStr tok = + let arr = (tableTTtoUStr (tokenDBFromToken tok)) + tt = unwrapTT tok + in if inRange (bounds arr) tt + then arr!tt + else error ("no registered identifier "++show tt++" in tokenDB") + +tokTypeToString :: (TokenType tok, HasTokenDB tok) => tok -> String +tokTypeToString = uchars . tokTypeToUStr + +tokenToUStr :: (TokenType tok, HasTokenDB tok) => TokenAt tok -> UStr +tokenToUStr tok = case asToken tok of + EmptyToken t -> tokTypeToUStr t + CharToken _ c -> ustr [c] + Token _ u -> u + +tokenToString :: (TokenType tok, HasTokenDB tok) => TokenAt tok -> String +tokenToString tok = case asToken tok of + EmptyToken t -> uchars (tokTypeToUStr t) + CharToken _ c -> [c] + Token _ u -> uchars u + +-- | Get token from a 'TokenDB' that was associated with the 'Dao.String.UStrType'. +maybeLookupToken :: (UStrType str, TokenType tok) => TokenDB tok -> str -> Maybe tok +maybeLookupToken tokenDB = fmap wrapTT . flip M.lookup (tableUStrToTT tokenDB) . toUStr + +-- | Like 'maybeLookupToken' but evaluates to 'Prelude.error' if no such token was defined. +lookupToken :: (UStrType str, TokenType tok) => TokenDB tok -> str -> tok +lookupToken tokenDB str = + fromMaybe (error $ "internal: token "++show (toUStr str)++" was never defined") $ + maybeLookupToken tokenDB str + +mk_keyword :: UStrType str => Regex -> str -> LexBuilderM (UStr, TT) +mk_keyword regex key = do + let ukey = toUStr key + keyChars = uchars ukey + if fst (runRegex regex keyChars :: (Bool, ([TokenAt TT], String))) + then LexBuilderM (newTokID ukey) >>= return . (,) ukey + else error ("keyword token "++show keyChars++"does not match it's own keyword Regex") + +-- | Create a single keyword 'Regex'. 'Control.Monad.mapM'-ing over this function is not the same as +-- using 'keywordTable', 'keywordTable' creates an actual table when evalauting to a 'Lexer'. This +-- function creates no table, it will simply evaluate to a lexer that returns a token of the keyword +-- type if the keyword matches the input, or else it returns the default token type. +keyword :: (UStrType str, UStrType key) => str -> Regex -> key -> LexBuilderM Regex +keyword deflt regex key = do + deflt <- LexBuilderM (newTokID (toUStr deflt)) + (ukey, tt) <- mk_keyword regex key + return (regex . rxMakeToken (\str -> if ustr str==ukey then (False, tt) else (True, deflt))) + +-- | To construct a keyword table, you must provide three parameters: the first two are a default +-- 'TokenType' and a 'Regex' used to split non-keyword words out of the character stream. The third +-- parameter is a list of keywords strings. Every keyword string will become it's own token type. +-- The resultant 'Regex' will, when evaluated as a 'Lexer', first try to split a non-keyword string +-- off of the stream. But if that string matches a keyword, a keyword token of it's own type is +-- emitted. Otherwise, it will emit a non-keyword token of the 'TokenType' given here. Keyword +-- tokens are empty, non-keyword contain the characters that matched the regex. +-- +-- A common way to use this function is with the 'Data.List.words' function: +-- > 'keywordTable' MyVarNameType ('rx' ('from' @'@a@'@ 'to' @'@z@'@)) $ +-- > 'Data.List.words' $ 'Data.List.unwords' $ +-- > [ "while for if then else goto return break continue" +-- > "class instance new delete super typeof" ] +keywordTable :: (UStrType str, UStrType key) => str -> Regex -> [key] -> LexBuilderM Regex +keywordTable deflt regex keys = do + deflt <- LexBuilderM (newTokID (toUStr deflt)) + keyDict <- fmap M.fromList (forM keys (mk_keyword regex)) + return (regex . rxMakeToken (maybe (True, deflt) ((,) False) . flip M.lookup keyDict . ustr)) + +-- | Creates a token type with 'regex' where the text lexed from the input is identical to name of +-- the token. The difference between an operator and a keyword is that operators will be lexed +-- regardless of the characters following it in the stream, which means if you have an operator "op" +-- and the next characters in the stream are @"open()"@, then the lexical analysis will split this +-- into @["op", "en()"]@, the remainder @"en()"@ characters must be lexed by some other lexer, +-- and @"op"@ will be treated as a single operator token. Keywords do not work this way. +operator :: UStrType str => str -> LexBuilderM Regex +operator str = do + let u = toUStr str + case ulength u of + 0 -> return id + 1 -> makeRegex False u (head (uchars u)) + _ -> makeRegex False u u + +-- | Creates a 'TokenTable' using a list of keywords or operators you provide to it. Use this +-- function to ensure operators do not interfear with each other. For example, if you have two +-- operators @"=="@ and @"="@, the lexer must try to split the @"=="@ operator from the stream +-- before it tries splitting @"="@. This function ensures that the order in which operators are +-- tried is the correct order. +-- +-- Every string provided becomes it's own token type. For example: +-- > myKeywords = 'tokenTable' $ 'Data.List.words' $ 'Data.List.unwords' $ +-- > [ "** * / % + - & | ^", +-- > "= *= /= %= += -= &= |= ^=", +-- > "== != <= >= < >" ] +operatorTable :: UStrType str => [str] -> LexBuilderM Regex +operatorTable = fmap mconcat . mapM operator . + sortBy (\a b -> compare (ulength b) (ulength a)) . map toUStr + +-- | Retrieve a 'TokenType' from a 'UStrType' (or a subclass of 'UStrType' like 'MetaToken') value. +-- This is necesary for building tokenizing regular expressions that are more complicated than a +-- typeical keyword or operator. You must declare in the 'Regex' when to create a token from the +-- given token types returned to the 'LexBuilderM' monad by this function. +getTokID :: (UStrType tokID, TokenType tok) => tokID -> LexBuilderM tok +getTokID tokID = fmap wrapTT (LexBuilderM (newTokID (toUStr tokID))) + +---------------------------------------------------------------------------------------------------- +-- $Regular_expressions +-- Provides a very simple data type for constructing expressions that can match strings. This type +-- is used in a 'LexBuilderM' to and are associated with token types such than when the 'LexBuilderM' +-- is converted to a 'Lexer', a token of the associated type is generated when a regex matches +-- the beginning of the input string that is being lexically analyzed. + +-- | Any function with a type @'RegexUnit' -> 'RegexUnit'@ or 'Regex' can be used in a +-- dot-operator-separated sequence of expressions. But the 'rx' function provided by this class +-- introduces a kind of constant expression that can be used in sequences of 'RegexUnit's. For +-- example, suppose you have defined a regular expression @digit@ of type +-- @'RegexUnit' -> 'RegexUnit'@ to match an arbitrarily long sequence of numeric characters, and a +-- regular expression @space@ of type 'Regex' to match an arbitrarily long sequence of whitespace +-- characters. You could then define a regular expression with a sequence like so: +-- > myRegex :: Regex +-- > myRegex = 'rx' "first" . space . digit . space . 'rx' "second" . space . digit +-- Here, we take advantage of the fact that 'Prelude.String' is instnatiated into the +-- 'RegexBaseType' class, because this allows us to write @'rx' "first"@ and @'rx' "second"@, which +-- will match the strings "first" and "second" if they occur in the input string to be matched. This +-- expression is equivalent to the POSIX regular expression +-- @first[[:space:]]+[[:digit:]]+[[:space:]]+second[[:space:]]+[[:digit:]]+@ +-- which would match strings like the following: +-- > "first 1231 second 99" +-- > "first 0 second 1233491202" +-- +-- /To create a choice/ you can use 'Data.Monoid.mappend', 'Data.Monoid.mconcat', or the infix +-- operator equivalent of 'Data.Monoid.mappend', which is 'Data.Monoid.<>'. The reason is, +-- 'Data.Monoid.Monoid' instantiates functions of type @a -> b@, and this provides a default +-- instnatiation for functions of type 'Regex'. For example, +-- suppose you have two regular expressions, @regexA@ and @regexB@. If you want to construct a +-- 'Regex' that tries matching @regexA@, and if it fails, then tries @regexB@, you would write: +-- > matchAorB = regexA 'Data.Monoid.<>' regexB +-- You can use 'Data.Monoid.concat' to create larger choices: +-- > 'Data.Monoid.mconcat' ['rx' "tryThis", 'rx' "thenThis", regexA, regexB] +-- or equivalently: +-- > 'rx' 'Data.Monoid.<>' "tryThis" 'Data.Monoid.<>' 'rx' "thenThis" 'Data.Monoid.<>' regexA 'Data.Monoid.<>' regexB +-- +-- Another advantage of 'Regex' being a function of type @'RegexUnit' -> 'RegexUnit'@ is that any +-- function of the type @a -> a@ can easily be used with the 'Prelude.fix' function to create loops, +-- for example, to lex an arbitrarily long sequence of numbers separated by spacecs: +-- > do space <- 'newTokenType' "SPACE" +-- > number <- 'newTokenType' "NUMBER" +-- > 'regex' $ 'Prelude.fix' $ \loop -> +-- > ('rxRepeat1'('ch' ' ') . 'rxEmptyToken' space 'Data.Monoid.<>' 'rxRepeat1'('from' '0' 'to' '9') . 'rxToken' number) . loop +type Regex = RegexUnit -> RegexUnit + +-- Not for export, this is a type used in the 'RxMakeToken' constructor, it is a basically a data +-- representing a function that can convert a string to a 'TT', but could be a constant function. +data MakeToken = MakeToken (String -> (Bool, TT)) | ConstToken Bool TT +instance Eq MakeToken where + ConstToken kA ttA == ConstToken kB ttB = kA==kB && ttA==ttB + _ == _ = False +instance Show MakeToken where + show (ConstToken kA ttA) = (if kA then "full " else "empty ")++show ttA + show _ = "MakeToken" + +evalMakeToken :: TokenType tok => MakeToken -> String -> Lexer tok () +evalMakeToken mkt withStr = (if keep then makeToken else makeEmptyToken) (wrapTT tt) where + (keep, tt) = case mkt of + ConstToken keep tt -> (keep, tt) + MakeToken make -> make withStr + +-- | This is an intermediate type for constructing 'Regex's. You will not be using it directly. You +-- will instead use any function that evaluates to a 'Regex', which is a function of this data type. +data RegexUnit + = RxBacktrack + | RxSuccess + | RxChoice { getSubRegexes :: [RegexUnit] } + | RxStep { rxStepUnit :: RxPrimitive , subRegex :: RegexUnit } + | RxExpect { rxErrMsg :: UStr , subRegex :: RegexUnit } + | RxDontMatch{ subRegex :: RegexUnit } + | RxMakeToken{ rxMakeFunc :: MakeToken , subRegex :: RegexUnit } + deriving Eq +instance Show RegexUnit where + show rx = loop rx where + loop rx = case rx of + RxBacktrack -> "RxBacktrack" + RxSuccess -> "RxSuccess" + RxChoice c -> "RxChoice "++show c + RxStep p _ -> "RxStep ("++showRegexPrim p++") ..." + RxExpect e _ -> "RxExpect "++show e++" ..." + RxDontMatch _ -> "RxDontMatch ..." + RxMakeToken t _ -> "RxMakeToken ("++show t++") ..." +instance Show (RegexUnit -> RegexUnit) where { show rx = show (rx RxSuccess) } +instance Monoid RegexUnit where + mempty = RxBacktrack + mappend a b = case a of + RxBacktrack -> b + RxSuccess -> a + RxExpect _ _ -> a + RxStep a' ax -> case b of + RxStep b' bx -> if a' == b' then RxStep a' (ax<>bx) else RxChoice [a,b] + b -> RxChoice [a,b] + RxDontMatch ax -> case b of + RxDontMatch bx -> RxDontMatch (ax<>bx) + b -> RxChoice [a,b] + RxChoice ax -> case b of + RxChoice bx -> reduce (loop ax bx) + b -> reduce (loop ax [b]) + RxMakeToken ta ax -> case b of + RxMakeToken tb bx | ta==tb -> RxMakeToken ta (ax<>bx) + b -> RxChoice [a,b] + where + reduce list = case list of + [] -> RxBacktrack + [item] -> item + list -> RxChoice list + loop ax bx = case ax of + [] -> bx + [a] -> case bx of + [] -> [a] + b:bx -> case a<>b of + RxChoice ax -> ax++bx + b -> b : loop ax bx -- NEEDS TO BE TESTED, changed from (a:b:ax) + a:ax -> a : loop ax bx + +-- | Convert a 'Regex' function to a 'Lexer'. The resulting 'Lexer' will not call 'makeToken' or +-- 'makeEmptyToken', it will only match the beginning of the input string according to the 'Regex', +-- leaving the matched characters in the 'lexBuffer'. +-- +-- /BUG FIX:/ 'regexToLexer' should be distributive over 'Data.Monoid.mappend'ed 'Regex's, i.e the +-- statement: +-- > 'regexToLexer' (regex1 'Data.Monoid.<>' regex2) +-- should be identical to: +-- > 'regexToLexer' regex1 'Data.Monoid.<>' 'regexToLexer' regex2 +-- however I have discovered that this is not the case for all possible 'Regex's. I need to write a +-- QuickCheck test to figure out why and correct this problem. +regexToLexer :: TokenType tok => Regex -> Lexer tok () +regexToLexer re = loop (re RxSuccess) where + loop re = case re of + RxBacktrack -> lexBacktrack + RxSuccess -> return () +-- RxMakeToken tt re -> gets lexBuffer >>= evalMakeToken tt >> loop re + RxMakeToken tt re -> case re of + RxMakeToken tt re -> loop (RxMakeToken tt re) + _ -> gets lexBuffer >>= evalMakeToken tt >> loop re + -- if there are two 'RxMakeToken's in a row, use the later one. This makes for more + -- intuitive regular expressions. -- TODO, maybe lets not do this. + RxChoice re -> msum $ map loop re + RxStep r re -> do + keep <- gets lexBuffer + clearBuffer + mplus (regexPrimToLexer r >> modify (\st -> st{lexBuffer = keep ++ lexBuffer st})) + (modify (\st -> st{lexBuffer=keep, lexInput = lexBuffer st ++ lexInput st}) >> mzero) + loop re + RxExpect err re -> mplus (loop re) (fail (uchars err)) + RxDontMatch re -> case re of + RxDontMatch re -> loop re -- double negative means succeed on match + re -> do + keep <- gets lexBuffer + matched <- clearBuffer >> mplus (loop re >> return True) (return False) + if matched + then do -- fail if matched + modify $ \st -> + st{ lexBuffer = "" + , lexInput = keep ++ lexBuffer st ++ lexInput st + } + mzero + else do -- success if not matched + modify $ \st -> + st{ lexBuffer = keep + , lexInput = lexBuffer st ++ lexInput st + } + return () + +-- Evaluate a 'Regex' to a 'Lexer' using 'regexToLexer', but also create a list of pairs, every pair +-- containing a character in the set of characters that this 'Regex' accepts. So, for example, if +-- the 'Regex' passed to this function is created from an 'Dao.Interval.EnumSet' with characters from +-- @a@ to @z@, this function will evaluate to a list of 26 pairs with every character from @a@ to +-- @z@ as the first element and the 'Lexer' as the second element. Every pair has the exact same +-- lexer function. This function returns 'Data.Maybe.Nothing' if the 'Regex' given does not evaluate +-- to a 'RxChoice' or 'RxStep' regex. +-- +-- Evaluates to a pair, the first element being a list of paris mapping characters to lexers, the +-- second being the lexers which cannot be mapped to characters but should be tried if any of the +-- character lexers backtrack. Lexers that cannot be mapped to characters but occur in the middle of +-- the list of 'RegexUnit's list are bunched together and prepended to the lexers that can be mapped +-- to characters. +regexToLexerPairs :: Regex -> ([(Char, Regex)], Regex) +regexToLexerPairs regex = case regex RxSuccess of + RxChoice [] -> (mzero, mempty) + RxChoice [r] -> regexToLexerPairs (const r) + RxChoice rx -> loop mempty [] (flatten rx) + RxStep p r -> loop mempty [] [RxStep p r] + _ -> (mzero, mempty) + where + flatten = concatMap $ \r -> case r of + RxChoice rx -> flatten rx + r -> [r] + done pre stk = (stk, const pre) + loop :: RegexUnit -> [(Char, Regex)] -> [RegexUnit] -> ([(Char, Regex)], Regex) + loop pre stk rx = case rx of + [] -> done pre stk + r:rx -> case r of + RxSuccess -> done (pre<>RxSuccess) stk + RxBacktrack -> loop pre stk rx + RxStep p _ -> loopStep r p where + loopStep r p = case p of + RxDelete -> loop (pre<>r) stk rx + RxString u -> case uchars u of + "" -> done (pre<>RxSuccess) stk + c:_ -> loop mempty (create pre stk [c] r) rx + RxCharSet cs -> case Iv.elems cs of + [] -> loop pre stk rx + cx -> loop mempty (create pre stk cx r) rx + RxRepeat _ _ p -> loopStep r p + r -> loop (pre<>r) stk rx + create pre stk cx r = let fn = const (pre<>r) in stk ++ map (\c -> (c, fn)) cx + +-- Not for export +data RxPrimitive + = RxDelete + | RxString { rxString :: UStr } + | RxCharSet { rxCharSet :: Iv.Set Char } + | RxRepeat { rxLowerLim :: Iv.Inf Int, rxUpperLim :: Iv.Inf Int, subRegexUnit :: RxPrimitive } + deriving Eq + +showRegexPrim :: RxPrimitive -> String +showRegexPrim re = case re of + RxDelete -> "(delete)" + RxString str -> show str + RxCharSet ch -> show ch + RxRepeat lo hi re -> "repeat("++show lo++".."++show hi++", "++showRegexPrim re++")" + +regexPrimToLexer :: TokenType tok => RxPrimitive -> Lexer tok () +regexPrimToLexer re = case re of + RxDelete -> clearBuffer + RxString str -> lexString (uchars str) + RxCharSet set -> lexCharP (Iv.member set) + RxRepeat lo hi re -> rept lo hi re + where + rept lo hi re = fromMaybe (seq (error "internal error") $! return ()) $ do + getLo <- mplus (Iv.toPoint lo >>= return . lowerLim re) (return (return ())) + getHi <- mplus (Iv.toPoint hi >>= return . upperLim re) (return (noLimit re)) + return (getLo >> mplus getHi (return ())) + lowerLim re lo = case re of + RxDelete -> clearBuffer + RxString str -> lowerLimLex lo (lexString (uchars str)) + RxCharSet set -> do + keep <- gets lexBuffer + clearBuffer >> lexWhile (Iv.member set) + got <- gets lexBuffer + if length got < lo + then do + modify (\st -> st{lexInput = keep ++ got ++ lexInput st, lexBuffer = ""}) + mzero + else modify (\st -> st{lexBuffer = keep ++ got}) + RxRepeat lo' hi' re -> lowerLimLex lo (rept lo' hi' re) + lowerLimLex lo lex = replicateM_ lo lex + upperLim re hi = case re of + RxDelete -> clearBuffer + RxString str -> replicateM_ hi (lexString (uchars str)) + RxCharSet set -> lexWhile (Iv.member set) + RxRepeat lo' hi' re -> replicateM_ hi (rept lo' hi' re) + noLimit re = case re of + RxDelete -> clearBuffer + RxString str -> forever (lexString (uchars str)) + RxCharSet set -> lexWhile (Iv.member set) + RxRepeat lo hi re -> forever (rept lo hi re) + +-- | Any type which instantiates the 'RegexBaseType' class can be used to with the 'rx' function to +-- construct a part of a 'Regex' which can be used in a sequence of 'Regex's. +-- +-- Probably the most useful instance of this class apart from that of 'Prelude.String' is the +-- instance for the type @['Dao.Interval.Set' 'Data.Char.Char']@, which allows you to union ranges of +-- character sets like so: +-- > 'rx'['from' '0' 'to' '9', from @'A'@ 'to' @'Z'@, 'from' '@a@' 'to' '@z@', 'ch' '@_@'] +-- which would be equivalent to the POSIX regular expression @[0-9A-Za-z_]@, a regular expression +-- that matches any single alphabetic, numeric, of underscore character. +class RegexBaseType t where + rxPrim :: t -> RxPrimitive + rx :: t -> Regex + rx = RxStep . rxPrim +instance RegexBaseType Char where { rxPrim = RxCharSet . Iv.point } +instance RegexBaseType String where { rxPrim = RxString . ustr } +instance RegexBaseType UStr where { rxPrim = RxString } +instance RegexBaseType (Iv.Set Char) where { rxPrim = RxCharSet } +instance RegexBaseType [Iv.Set Char] where { rxPrim = RxCharSet . foldl Iv.union mempty } +instance RegexBaseType (Char, Char) where { rxPrim = RxCharSet . Iv.fromPairs . (:[]) } +instance RegexBaseType [(Char, Char)] where { rxPrim = RxCharSet . Iv.fromPairs } + +-- | The type of the 'from' and 'to' functions are specially defined so that you can write ranges of +-- characters. For example, if you want to match upper-case characters, you would simply write: +-- > from 'A' to 'Z' +-- or equivalently: +-- > 'A' `to` 'Z' +-- but I prefer to use 'from' because the use of single quotes and back-quotes together in the same +-- expression is tedius. This would be equivalent to the POSIX regular expressions: @[A-Z]@ +from :: Char -> (Char -> Char -> Iv.Set Char) -> Char -> Iv.Set Char +from a to b = to a b + +-- | The type of the 'from' and 'to' functions are specially defined so that you can write ranges of +-- characters. For example, if you want to match upper-case characters, you would simply write: +-- > from 'A' to 'Z' +-- or equivalently: +-- > 'A' `to` 'Z' +-- but I prefer to use 'from' because the use of single quotes and back-quotes together in the same +-- expression is tedius. This would be equivalent to the POSIX regular expressions: @[A-Z]@ +to :: Char -> Char -> Iv.Set Char +to toch frch = Iv.range frch toch + +-- | Create a character set that matches only a single character. For example if you want to match +-- just a single lowercase letter-A character: +-- > ch 'a' +-- This would b equivalent to the POSIX regular expression @[a]@ +-- Be careful not to confuse this function with the 'rx' function, which is instantiated to create +-- 'Regex' functions from 'Prelude.Char's. The expression @'rx' @'@@a@@'@ cannot be used in a +-- set of other @'Dao.Interval.Set' 'Prelude.Char'@ types to create a larger set: +-- > badRegex = 'repeat' ['from' '0' 'to' '9', 'rx' @'@.@'@] -- /COMPILE-TIME ERROR!!!/ +-- > +-- > -- This matches strings ending in dots, like "98765.", "123.", and "0." +-- > -- but does not match "0.0" or ".123" +-- > numberEndingWithDot 'repeat' ['from' '0' 'to' '9'] . 'rx' '.' +-- > +-- > -- This matches strings like "0.0.0.0", "123.", ".99", "...", "0.0" and "1..20" +-- > dotsOrDigits = 'repeat' ['from' '0' 'to' '9', 'ch' '.'] +-- This function is also useful with the 'Prelude.map' function to create a set of characters from a +-- 'Prelude.String': +-- > stringOfVowels = 'rxRepeat' ('Prelude.map' 'ch' "AEIOUaeiou") +ch :: Char -> Iv.Set Char +ch = Iv.point + +-- | Produces a character set that matches any character, like the POSIX regular expression dot +-- (@.@). /NEVER use this in a 'rxRepeat' function/ unless you really want to dump the entire +-- remainder of the input string into the 'lexBuffer'. +anyChar :: Iv.Set Char +anyChar = Iv.whole + +-- | Invert a character set: this 'Regex' will match any characters not in the union of the sets +-- provided. +invert :: [Iv.Set Char] -> Iv.Set Char +invert = Iv.invert . foldl Iv.union mempty + +-- | An optional regex, tries to match, but succeeds regardless of whether or not the given +-- actually matches. In fact, this 'Regex' is exactly identical to the equation: +-- > \regex -> regex 'Data.Monoid.<>' 'Prelude.id' +opt :: Regex -> Regex +opt = (<>id) + +-- | This 'Regex' matches nothing and succeeds, and deletes any 'Regex' appended to it with the dot +-- operator. Any 'Regex' occurring after a 'halt' will not be evaluated. +halt :: Regex +halt = const RxSuccess + +-- | Marks a point in a 'Regex' sequence where the matching must not fail, and if it does fail, the +-- resulting 'Lexer' to which this 'Regex' evaluates will evaluate to 'Control.Monad.fail' with an +-- error message provided as a paramater to this function. For example: +-- > decimalPoint = digits . 'rx' '.' . 'cantFail' "must have digits after a decimal point" . digits +cantFail :: String -> Regex +cantFail msg = RxExpect (ustr msg) + +-- | This is a look-ahead 'Regex' that matches if the 'Regex' parameter provided does not match. An +-- extremely inefficient function, you should avoid using it and consider re-designing your +-- 'LexBuilderM' if you rely on this function too often. This function is designed to occur only at +-- the end of your 'Regex', that is, every 'Regex' that occurs after 'rxDont' is part of the 'Regex' +-- to not match. For example: +-- > myRegex = 'rx' "else" . spaces . 'rxDont' . 'rx' "if" . spaces . rx "end" +-- will succeed only if the string else is not followed by a string @"if end"@. There is no way to +-- make the 'Regex' first check if the next string is not @"if"@ and if it is not then continue +-- matching with @spaces@ and @'rx' "end"@ after that. +dont :: Regex +dont = RxDontMatch + +-- | Clear the 'lexBuffer' without creating a token, effectively deleting the characters from the +-- input stream, ignoring those characters. +rxClear :: Regex +rxClear = RxStep RxDelete + +-- | Force an error to occur. +rxErr :: String -> Regex +rxErr msg = cantFail msg . mempty + +-- | Repeat a regular 'RegexBaseType' regular expression a number of times, with the number of times +-- repeated being limited by an upper and lower bound. Fails to match if the minimum number of +-- occurences cannot be matched, otherwise continues to repeat as many times as possible (greedily) +-- but not exceeding the upper bound given. +rxLimitMinMax :: RegexBaseType rx => Int -> Int -> rx -> Regex +rxLimitMinMax lo hi = RxStep . RxRepeat (Iv.Finite lo) (Iv.Finite hi) . rxPrim + +-- | Repeats greedily, matching the 'RegexBaseType' regular expression as many times as possible, +-- but backtracks if the regex cannot be matched a minimum of the given number of times. +rxLimitMin :: RegexBaseType rx => Int -> rx -> Regex +rxLimitMin lo = RxStep . RxRepeat (Iv.Finite lo) Iv.PosInf . rxPrim + +-- | Match a 'RegexBaseType' regex as many times as possible (greedily) but never exceeding the +-- maximum number of times given. Must match at least one character, or else backtracks. +rxLimitMax :: RegexBaseType rx => Int -> rx -> Regex +rxLimitMax hi = RxStep . RxRepeat Iv.NegInf (Iv.Finite hi) . rxPrim + +-- | Like 'rx' but repeats, but must match at least one character. It is similar to the @*@ operator +-- in POSIX regular expressions. /WARNING:/ do not create regex loops using only regexs of this +-- type, your regex will loop indefinitely. +rxRepeat :: RegexBaseType rx => rx -> Regex +rxRepeat = RxStep . RxRepeat Iv.NegInf Iv.PosInf . rxPrim + +-- | Defined as @'rxLimitMin' 1@, matches a primitive 'RegexBaseType' one or more times, rather than +-- zero or more times. It is imilar to the @+@ operator in POSIX regular expressions. +rxRepeat1 :: RegexBaseType rx => rx -> Regex +rxRepeat1 = rxLimitMin 1 + +-- | Create a token, keep the portion of the string that has matched the regex up to this point, but +-- clear the match buffer once the token has been created. +rxToken :: TokenType tok => tok -> Regex +rxToken tok = RxMakeToken (ConstToken True $ unwrapTT tok) + +-- | Create a token, disgarding the portion of the string that has matched the regex up to this point. +rxEmptyToken :: TokenType tok => tok -> Regex +rxEmptyToken tok = RxMakeToken (ConstToken False $ unwrapTT tok) + +rxMakeToken :: TokenType tok => (String -> (Bool, tok)) -> Regex +rxMakeToken make = RxMakeToken (MakeToken (fmap (fmap unwrapTT) make)) + +---------------------------------------------------------------------------------------------------- +-- $Lexical_Analysis +-- There is only one type used for lexical analysis: the 'Lexer'. This monad is used to analyze +-- text in a 'Prelude.String', and to emit 'Token's. Internally, the 'Token's +-- emitted are automatically stored with their line and column number information in a 'TokenAt' +-- object. +-- +-- Although lexical analysis and syntactic analysis are both separate stages, keep in mind that +-- Haskell is a lazy language. So when each phase is composed into a single function, syntactic +-- analysis will occur as tokens become available as they are emitted the lexical analyzer. So what +-- tends to happen is that lexical and syntactic analysis will occur in parallel. +-- +-- Although if your syntactic analysis does something like apply 'Data.List.reverse' to the entire +-- token stream and then begin parsing the 'Data.List.reverse'd stream, this will force the entire +-- lexical analysis phase to complete and store the entire token stream into memory before the +-- syntactic analyse can begin. Any parser that scans forward over tokens will consume a lot of +-- memory. But through use of 'Parser' it is difficult to make this mistake. + +-- | This is the state used by every 'Lexer'. It keeps track of the line number and column +-- number, the current input string, and the list of emitted 'Token's. +data LexerState tok + = LexerState + { lexTabWidth :: TabWidth + -- ^ When computing the column number of tokens, the number of spaces a @'\TAB'@ character + -- counts for should be configured. The default set in 'newLexerState' is 4. + , lexCurrentLine :: LineNum + , lexCurrentColumn :: ColumnNum + , lexTokenCounter :: Word + -- ^ some algorithms would like to know if you lexed any tokens at all, and will fail if you + -- did not. There needs to be some way of knowing how many tokens your 'Lexer' created. + , tokenStream :: [TokenAt tok] + , lexBuffer :: String + -- ^ stores the characters consumed by 'Lexer's. This buffer is never cleared until + -- 'makeToken' is evaluated. Retrieve this string using: + -- > 'Control.Monad.State.gets' 'lexBuffer' + , lexInput :: String + -- ^ contains the remainder of the input string to be analyzed. Retrieve this string using: + -- > 'Control.Monad.State.gets' 'lexInput' + } +instance HasLineNumber (LexerState tok) where { lineNumber = lexCurrentLine } +instance HasColumnNumber (LexerState tok) where { columnNumber = lexCurrentColumn } + +-- | Create a new lexer state using the given input 'Prelude.String'. This is only realy useful if +-- you must evaluate 'runLexerState'. +newLexerState :: String -> LexerState tok +newLexerState input = + LexerState + { lexTabWidth = 4 + , lexTokenCounter = 0 + , lexCurrentLine = 1 + , lexCurrentColumn = 1 + , tokenStream = [] + , lexBuffer = "" + , lexInput = input + } + +-- | 'parse' will evaluate the 'Lexer' over the input string first. If the 'Lexer' fails, it +-- will evaluate to a 'Dao.Prelude.PFail' value containing a 'Error' value of type: +-- > 'Error' ('LexerState') +-- However the 'Parser's evaluate to 'Error's containing type: +-- > 'Error' ('TokStreamState' st) +-- This function provides an easy way to convert between the two 'Error' types, however since +-- the state value @st@ is polymorphic, you will need to insert your parser state into the error +-- value after evaluating this function. For example: +-- > case tokenizerResult of +-- > 'Dao.Predicate.PFail' lexErr -> 'Dao.Predicate.PFail' (('lexErrToParseErr' lexErr){'parseStateAtErr' = Nothing}) +-- > .... +lexErrToParseErr :: TokenType tok => ParseError (LexerState tok) tok -> ParseError (TokStreamState st tok) tok +lexErrToParseErr (lexErr@ParseError{parseStateAtErr=st}) = + lexErr + { parseStateAtErr = mzero + , parseErrLoc = maybe LocationUnknown (\st -> atPoint (lexCurrentLine st) (lexCurrentColumn st)) st + , parseErrMsg = return (ustr "Lexical analysis failed on ") <> parseErrMsg lexErr <> + (do st <- st + return $ ustr $ concat $ concat $ + [ do guard (not (null (lexBuffer st))) + ["\nBuffered token string: ", show (lexBuffer st)] + , ["\nString failed on: ", show (take 20 (lexInput st))] + ] + ) + } + +lexCurrentLocation :: LexerState tok -> Location +lexCurrentLocation st = atPoint (lineNumber st) (columnNumber st) + +-- | The 'Lexer' is very similar in many ways to regular expressions, however 'Lexer's always +-- begin evaluating at the beginning of the input string. The lexical analysis phase of parsing +-- must generate 'Token's from the input string. 'Lexer's provide you the means to do with +-- primitive functions like 'lexString', 'lexChar', and 'lexUntil', and combinators like 'defaultTo' +-- and 'lexUntilTermChar'. These primitive functions collect characters into a buffer, and you can +-- then empty the buffer and use the buffered characters to create a 'Token' using the +-- 'makeToken' function. +-- +-- The 'Control.Monad.fail' function is overloaded such that it halts 'lexecialAnalysis' with a +-- useful error message about the location of the failure. 'Control.Monad.Error.throwError' can +-- also be used, and 'Control.Monad.Error.catchError' will catch errors thrown by +-- 'Control.Monad.Error.throwError' and 'Control.Monad.fail'. 'Control.Monad.mzero' causes +-- backtracking. Be careful when recovering from backtracking using 'Control.Monad.mplus' because +-- the 'lexBuffer' is not cleared. It is usually better to backtrack using 'lexBacktrack' (or don't +-- backtrack at all, because it is inefficient). However you don't need to worry too much; if a +-- 'Lexer' backtracks while being evaluated in lexical analysis the 'lexInput' will not be +-- affected at all and the 'lexBuffer' is ingored entirely. +newtype Lexer tok a = Lexer{ + lexerToPredicateT :: PredicateT (ParseError (LexerState tok) tok) (State (LexerState tok)) a + } + deriving (Functor, Applicative, Alternative, MonadPlus) + +instance TokenType tok => + Monad (Lexer tok) where + (Lexer fn) >>= mfn = Lexer (fn >>= lexerToPredicateT . mfn) + return = Lexer . return + fail msg = do + st <- get + throwError $ + (parserErr (lexCurrentLocation st)){parseErrMsg = Just (ustr msg), parseStateAtErr=Just st} + +instance TokenType tok => MonadState (LexerState tok) (Lexer tok) where + get = Lexer (lift get) + put = Lexer . lift . put + +instance TokenType tok => MonadError (ParseError (LexerState tok) tok) (Lexer tok) where + throwError = Lexer . throwError + catchError (Lexer try) catcher = Lexer (catchError try (lexerToPredicateT . catcher)) + +instance TokenType tok => MonadPlusError (ParseError (LexerState tok) tok) (Lexer tok) where + catchPredicate (Lexer try) = Lexer (catchPredicate try) + predicate = Lexer . predicate + +instance (TokenType tok, Monoid a) => Monoid (Lexer tok a) where + mempty = return mempty + mappend a b = liftM2 mappend a b + +-- | Append the first string parameter to the 'lexBuffer', and set the 'lexInput' to the value of +-- the second string parameter. Most lexers simply takes the input, breaks it, then places the two +-- halves back into the 'LexerState', which is what this function does. *Be careful* you don't pass +-- the wrong string as the second parameter. Or better yet, don't use this function. +lexSetState :: TokenType tok => String -> String -> Lexer tok () +lexSetState got remainder = modify $ \st -> + st{lexBuffer = lexBuffer st ++ got, lexInput = remainder} + +-- | Unlike simply evaluating 'Control.Monad.mzero', 'lexBacktrack' will push the contents of the +-- 'lexBuffer' back onto the 'lexInput'. This is inefficient, so if you rely on this too often you +-- should probably re-think the design of your lexer. +lexBacktrack :: TokenType tok => Lexer tok ig +lexBacktrack = modify (\st -> st{lexBuffer = "", lexInput = lexBuffer st ++ lexInput st}) >> mzero + +-- | Single character look-ahead, never consumes any tokens, never backtracks unless we are at the +-- end of input. +lexLook1 :: TokenType tok => Lexer tok Char +lexLook1 = gets lexInput >>= \input -> case input of { "" -> mzero ; c:_ -> return c } + +-- | Arbitrary look-ahead, creates a and returns copy of the portion of the input string that +-- matches the predicate. This function never backtracks, and it might be quite inefficient because +-- it must force strict evaluation of all characters that match the predicate. +lexCopyWhile :: TokenType tok => (Char -> Bool) -> Lexer tok String +lexCopyWhile predicate = fmap (takeWhile predicate) (gets lexInput) + +-- | A fundamental 'Lexer', uses 'Data.List.break' to break-off characters from the input string +-- until the given predicate evaluates to 'Prelude.True'. Backtracks if no characters are lexed. +lexWhile :: TokenType tok => (Char -> Bool) -> Lexer tok () +lexWhile predicate = do + (got, remainder) <- fmap (span predicate) (gets lexInput) + if null got then mzero else lexSetState got remainder + +-- | Like 'lexUnit' but inverts the predicate, lexing until the predicate does not match. This +-- function is defined as: +-- > \predicate -> 'lexUntil' ('Prelude.not' . predicate) +lexUntil :: TokenType tok => (Char -> Bool) -> Lexer tok () +lexUntil predicate = lexWhile (not . predicate) + +-- lexer: update line/column with string +lexUpdLineColWithStr :: TokenType tok => String -> Lexer tok () +lexUpdLineColWithStr input = do + st <- get + let tablen = lexTabWidth st + countNLs lns cols input = case break (=='\n') input of + ("" , "" ) -> (lns, cols) + (_ , '\n':after) -> countNLs (lns+1) 1 after + (before, after ) -> (lns, cols + foldl (+) 0 (map charPrintWidth (before++after))) + charPrintWidth c = case c of + c | c=='\t' -> tablen + c | isPrint c -> 1 + _ -> 0 + (newLine, newCol) = countNLs (lineNumber st) (columnNumber st) input + put (st{lexCurrentLine=newLine, lexCurrentColumn=newCol}) + +-- | Create a 'Token' using the contents of the 'lexBuffer', then clear the 'lexBuffer'. This +-- function backtracks if the 'lexBuffer' is empty. If you pass "Prelude.False' as the first +-- parameter the tokens in the 'lexBuffer' are not stored with the token, the token will only +-- contain the type. +makeGetToken :: TokenType tok => Bool -> tok -> Lexer tok (Token tok) +makeGetToken storeChars typ = do + st <- get + let str = lexBuffer st + token <- case str of + [] -> mzero + [c] | storeChars -> return $ CharToken{tokType=typ, tokChar=c} + _ | storeChars -> return $ Token{tokType=typ, tokUStr=ustr str} + _ -> return $ EmptyToken{tokType=typ} + put $ + st{ lexBuffer = "" + , tokenStream = tokenStream st ++ + [ TokenAt + { tokenAtLineNumber = lineNumber st + , tokenAtColumnNumber = columnNumber st + , getTokenValue = token + } ] + , lexTokenCounter = lexTokenCounter st + 1 + } + lexUpdLineColWithStr str + return token + +-- | Create a token in the stream without returning it (you usually don't need the token anyway). If +-- you do need the token, use 'makeGetToken'. +makeToken :: TokenType tok => tok -> Lexer tok () +makeToken = void . makeGetToken True + +-- | Create a token in the stream without returning it (you usually don't need the token anyway). If +-- you do need the token, use 'makeGetToken'. The token created will not store any characters, only +-- the type of the token. This can save a lot of memory, but it requires you have very descriptive +-- token types. +makeEmptyToken :: TokenType tok => tok -> Lexer tok () +makeEmptyToken = void . makeGetToken False + +-- | Clear the 'lexBuffer' without creating a token. +clearBuffer :: TokenType tok => Lexer tok () +clearBuffer = get >>= \st -> lexUpdLineColWithStr (lexBuffer st) >> put (st{lexBuffer=""}) + +-- | A fundamental lexer using 'Data.List.stripPrefix' to check whether the given string is at the +-- very beginning of the input. +lexString :: TokenType tok => String -> Lexer tok () +lexString str = gets lexInput >>= maybe mzero return . stripPrefix str >>= lexSetState str + +-- | A fundamental lexer succeeding if the next 'Prelude.Char' in the 'lexInput' matches the +-- given predicate. See also: 'charSet' and 'unionCharP'. +lexCharP :: TokenType tok => (Char -> Bool) -> Lexer tok () +lexCharP predicate = gets lexInput >>= \input -> case input of + c:input | predicate c -> lexSetState [c] input + _ -> mzero + +-- | Succeeds if the next 'Prelude.Char' on the 'lexInput' matches the given 'Prelude.Char' +lexChar :: TokenType tok => Char -> Lexer tok () +lexChar c = lexCharP (==c) + +-- | Backtracks if there are still characters in the input. +lexEOF :: TokenType tok => Lexer tok () +lexEOF = fmap (=="") (gets lexInput) >>= guard + +-- | Takes a 'tokenStream' resulting from the evaulation of lexical analysis and breaks it into +-- 'Line's. This makes things a bit more efficient because it is not necessary to store a line +-- number with every single token. It is necessary for initializing a 'Parser'. +tokenStreamToLines :: [TokenAt tok] -> [Line tok] +tokenStreamToLines toks = loop toks where + makeLine num toks = + Line + { lineLineNumber = num + , lineTokens = map (\t -> (tokenAtColumnNumber t, getToken t)) toks + } + loop toks = case toks of + [] -> [] + t:toks -> + let num = tokenAtLineNumber t + (line, toks') = span ((==num) . tokenAtLineNumber) (t:toks) + in makeLine num line : loop toks' + +-- | The 'Lexer's analogue of 'Control.Monad.State.runState', runs the lexer using an existing +-- 'LexerState'. +lexicalAnalysis + :: TokenType tok + => Lexer tok a -> LexerState tok -> (Predicate (ParseError (LexerState tok) tok) a, LexerState tok) +lexicalAnalysis lexer st = runState (runPredicateT (lexerToPredicateT lexer)) st + +-- | Perform a simple evaluation of a 'Lexer' against the beginning of a string, returning the +-- tokens and the remaining string. Evaluates to @('Prelude.True', (tokens, remainder))@ if the +-- lexer succeeded, evaluates to @('Prelude.False', (tokens, remainder))@ if the lexer failed or +-- backtracked, where @tokens@ are the tokens produced and @remainder@ is the portion of the string +-- that was not tokenized. +runLexer :: TokenType tok => Lexer tok a -> String -> (Bool, ([TokenAt tok], String)) +runLexer lexer inputStr = + let (lexResult, st) = lexicalAnalysis lexer (newLexerState inputStr) + in (case lexResult of { OK _ -> True; _ -> False; }, (tokenStream st, lexInput st)) + +-- | Convert a 'Regex' to a 'Lexer' and match a string against it using 'runLexer', so it only +-- matches at the beginning of a string, not at any arbitrary point in the middle of the string. +runRegex :: TokenType tok => Regex -> String -> (Bool, ([TokenAt tok], String)) +runRegex lexer inputStr = + let (a, (b, c)) = runLexer (regexToLexer lexer) inputStr in (a, (fmap (fmap wrapTT) b, c)) + +testLexicalAnalysis_withFilePath + :: (Show tok, TokenType tok) + => Lexer tok () -> FilePath -> TabWidth -> String -> IO () +testLexicalAnalysis_withFilePath tokenizer filepath tablen input = putStrLn report where + (result, st) = lexicalAnalysis tokenizer ((newLexerState input){lexTabWidth=tablen}) + lines = tokenStreamToLines (tokenStream st) + more = take 21 (lexInput st) + remain = "\nremaining: "++(if length more > 20 then show (take 20 more)++"..." else show more) + loc = show (lineNumber st) ++ ":" ++ show (lexCurrentColumn st) + report = (++remain) $ intercalate "\n" (map showLine lines) ++ '\n' : case result of + OK _ -> "No failures during lexical analysis." + Backtrack -> reportFilepath ++ ": lexical analysis evalauted to \"Backtrack\"" + PFail err -> show (fmapParseErrorState (const ()) err) + showLine line = unlines $ ["----------", show line] + reportFilepath = (if null filepath then "" else filepath)++":"++loc + +-- | Run the 'lexicalAnalysis' with the 'Lexer' on the given 'Prelude.String' and print out +-- every token created. +testLexicalAnalysis + :: (Show tok, TokenType tok) + => Lexer tok () -> TabWidth -> String -> IO () +testLexicalAnalysis a b c = testLexicalAnalysis_withFilePath a "" b c + +-- | Run the 'lexicalAnalysis' with the 'Lexer' on the contents of the file at the the given +-- 'System.IO.FilePath' 'Prelude.String' and print out every token created. +testLexicalAnalysisOnFile + ::(Show tok, TokenType tok) + => Lexer tok () -> TabWidth -> FilePath -> IO () +testLexicalAnalysisOnFile a b c = readFile c >>= testLexicalAnalysis_withFilePath a c b + +---------------------------------------------------------------------------------------------------- +-- $Fundamental_parser_data_types +-- A parser is defined as a stateful monad for analyzing a stream of tokens. A token stream is +-- represented by a list of 'Line' structures, and the parser monad's jobs is to look at the +-- current line, and extract the current token in the current line in the state, and use the tokens +-- to construct data. 'TokStream' is the fundamental parser, but it might be very tedious to use. It +-- is better to construct parsers using 'TokStream' which is a higher-level, easier to use data type +-- that is converted into the lower-level 'TokStream' type. + +-- | The 'TokStreamState' contains a stream of all tokens created by the 'lexicalAnalysis' phase. +-- This is the state associated with a 'TokStream' in the instantiation of +-- 'Control.Monad.State.MonadState', so 'Control.Monad.State.get' returns a value of this data type. +data TokStreamState st tok + = TokStreamState + { userState :: st + , getLines :: [Line tok] + , tokenQueue :: [TokenAt tok] + -- ^ single look-ahead is common, but the next token exists within the 'Prelude.snd' value + -- within a pair within a list within the 'lineTokens' field of a 'Line' data structure. + -- Rather than traverse that same path every time 'nextToken' or 'withToken' is called, the + -- next token is cached here. + , finalLocation :: Location -- ^ the line and column number marking the end of the file. + } +instance Functor (TokStreamState st) where + fmap f s = + TokStreamState + { userState = userState s + , getLines = fmap (fmap f) (getLines s) + , tokenQueue = fmap (fmap f) (tokenQueue s) + , finalLocation = finalLocation s + } + +newTokStream :: TokenType tok => st -> [Line tok] -> TokStreamState st tok +newTokStream userState lines = + TokStreamState + { userState = userState + , getLines = lines + , tokenQueue = [] + , finalLocation = LocationUnknown + } + +newTokStreamFromLexer :: TokenType tok => st -> LexerState tok -> TokStreamState st tok +newTokStreamFromLexer userState lexerState = + (newTokStream userState $ tokenStreamToLines $ tokenStream lexerState) + { finalLocation = + atPoint (lexCurrentColumn lexerState) (lexCurrentColumn lexerState) + } + +-- The 'TokStreamState' data structure has a field of a polymorphic type reserved for containing +-- arbitrary stateful information. 'TokStream' instantiates 'Control.Monad.State.Class.MonadState' +-- usch that 'Control.Monad.State.Class.MonadState.get' and +-- 'Control.Monad.State.Class.MonadState.put' return the 'TokStreamState' type, however if you wish +-- to modify the arbitrary state value using a function similar to how the +-- 'Control.Monad.State.Class.MonadState.modify' would do, you can use this function. +--modifyUserState :: TokenType tok => (st -> st) -> TokStream st tok () +--modifyUserState fn = modify (\st -> st{userState = fn (userState st)}) + +-- | The task of the 'TokStream' monad is to look at every token in order and construct syntax trees +-- in the 'syntacticAnalysis' phase. +-- +-- This function instantiates all the useful monad transformers, including 'Data.Functor.Functor', +-- 'Control.Monad.Monad', 'Control.MonadPlus', 'Control.Monad.State.MonadState', +-- 'Control.Monad.Error.MonadError' and 'Dao.Predicate.MonadPlusError'. Backtracking can be done +-- with 'Control.Monad.mzero' and "caught" with 'Control.Monad.mplus'. 'Control.Monad.fail' and +-- 'Control.Monad.Error.throwError' evaluate to a control value containing a 'Error' value +-- which can be caught by 'Control.Monad.Error.catchError', and which automatically contain +-- information about the location of the failure and the current token in the stream that caused the +-- failure. +newtype TokStream st tok a + = TokStream{ + parserToPredicateT :: + PredicateT (ParseError (TokStreamState st tok) tok) (State (TokStreamState st tok)) a + } +instance Functor (TokStream st tok) where { fmap f (TokStream a) = TokStream (fmap f a) } +instance TokenType tok => + Monad (TokStream st tok) where + (TokStream ma) >>= mfa = TokStream (ma >>= parserToPredicateT . mfa) + return a = TokStream (return a) + fail msg = do + tok <- optional (nextToken False) + st <- get + throwError $ + ParseError + { parseErrLoc = maybe LocationUnknown asLocation tok + , parseErrMsg = Just (ustr msg) + , parseErrTok = fmap getToken tok + , parseStateAtErr = Just st + } +instance TokenType tok => + MonadPlus (TokStream st tok) where + mzero = TokStream mzero + mplus (TokStream a) (TokStream b) = TokStream (mplus a b) +instance TokenType tok => + Applicative (TokStream st tok) where { pure = return ; (<*>) = ap; } +instance TokenType tok => + Alternative (TokStream st tok) where { empty = mzero; (<|>) = mplus; } +instance TokenType tok => + MonadState (TokStreamState st tok) (TokStream st tok) where + get = TokStream (PredicateT (fmap OK get)) + put = TokStream . PredicateT . fmap OK . put +instance TokenType tok => + MonadError (ParseError (TokStreamState st tok) tok) (TokStream st tok) where + throwError err = do + st <- get + predicate (PFail (err{parseStateAtErr=Just st})) + catchError (TokStream ptrans) catcher = TokStream $ do + pval <- catchPredicate ptrans + case pval of + OK a -> return a + Backtrack -> mzero + PFail err -> parserToPredicateT (catcher err) +instance TokenType tok => + MonadPlusError (ParseError (TokStreamState st tok) tok) (TokStream st tok) where + catchPredicate (TokStream ptrans) = TokStream (catchPredicate ptrans) + predicate = TokStream . predicate +instance (TokenType tok, Monoid a) => + Monoid (TokStream st tok a) where { mempty = return mempty; mappend a b = liftM2 mappend a b; } + +-- Return the next token in the state along with it's line and column position. If the boolean +-- parameter is true, the current token will also be removed from the state. +nextToken :: TokenType tok => Bool -> TokStream st tok (TokenAt tok) +nextToken doRemove = do + st <- get + case tokenQueue st of + [] -> case getLines st of + [] -> mzero + line:lines -> do + modify (\st -> st{tokenQueue=lineToTokensAt line, getLines=lines}) + nextToken doRemove + tok:tokx | doRemove -> put (st{tokenQueue=tokx}) >> return tok + tok:_ -> return tok + +---------------------------------------------------------------------------------------------------- + +-- | The public API for the 'TokStream' monad wraps 'TokStream' in a newtype called 'Parser. +data Parser st tok a + = ParserNull + | Parser{ parserToTokStream :: TokStream st tok a } + -- 'Parser' has it's own 'ParserNull' constructor because of lookup tables. When a lookup table is + -- evaluated, it selects the next parser from the table based on the current token in the stream. + -- But before it evaluates the next parser, it must shift the current token from the stream. If + -- the next parser is 'mzero', then the token will need to be unshifed immediately. To prevent + -- this unnecessary shift-unshift, the looked-up parser is checked: if the next parser is + -- 'ParserNull' (which could happen often because it is the default value used when constructing + -- the table) then the current token is not shifted at all. +instance Show (Parser st tok a) where { show p = case p of { ParserNull -> "ParserNull"; Parser _ -> "Parser ..."; }} +instance TokenType tok => Functor (Parser st tok) where + fmap f p = case p of { ParserNull -> ParserNull; Parser p -> Parser (fmap f p); } +instance TokenType tok => + Monad (Parser st tok) where + return = Parser . return + parser >>= bind = case parser of + ParserNull -> ParserNull + Parser p -> Parser $ p >>= \a -> case bind a of { ParserNull -> mzero; Parser p -> p; } + --parserA >> parserB = case parserA of + -- ParserNull -> ParserNull + -- Parser parserA -> case parserB of + -- ParserNull -> Parser (parserA >> mzero) + -- Parser parserB -> Parser (parserA >> parserB) + fail = Parser . fail +instance TokenType tok => + MonadPlus (Parser st tok) where + mzero = ParserNull + mplus a b = case a of + ParserNull -> b + Parser a -> Parser $ case b of + ParserNull -> a + Parser b -> mplus a b +instance TokenType tok => Applicative (Parser st tok) where { pure = return; (<*>) = ap; } +instance TokenType tok => Alternative (Parser st tok) where { empty = mzero; (<|>) = mplus; } +instance TokenType tok => MonadState st (Parser st tok) where + get = Parser (gets userState) + put ust = Parser (modify (\st -> st{userState=ust})) +instance TokenType tok => + MonadError (ParseError (TokStreamState st tok) tok) (Parser st tok) where + throwError = Parser . throwError + catchError trial catcher = Parser $ + catchError (parserToTokStream trial) (\err -> parserToTokStream (catcher err)) +instance TokenType tok => + MonadPlusError (ParseError (TokStreamState st tok) tok) (Parser st tok) where + catchPredicate ptrans = Parser (catchPredicate (parserToTokStream ptrans)) + predicate = Parser . predicate +instance TokenType tok => Monoid (Parser st tok a) where {mempty=mzero; mappend=mplus; } + +---------------------------------------------------------------------------------------------------- + +-- | This class exists to provide the 'token'. Ordinarily you would want to use the 'tokenType' +-- function to construct a parser that succeeds when the 'TokenType' value you provide to it matches +-- the next 'Token' in the 'TokStream'. However you need to have this 'TokenType' value first to +-- construct the parser, which means retrieving it by name from the 'TokenDB'. But things are more +-- convenient if you have a 'MetaType' that you used to construct your 'Lexer' using the 'fullToken' +-- or 'emptyToken' functions, which is possible because these functions construct 'Lexer's from +-- 'UStrType's, and your 'MetaToken' type also instantiates 'UStrType'. If you have created a data +-- type to be used as a 'MetaType' and used it to construct tokens, the 'Dao.String.UStr' value of +-- the 'MetaToken' type is associated with the 'TT' value of your 'TokenType' in the 'TokenDB'. This +-- function conveniently sees your 'MetaToken' type, retrieves it from the 'TokenDB', and uses the +-- 'TT' value retrieved to construct a 'TokStream' using the 'tokenType' function. +-- > newtype MyToken = MyToken{ unwrapMyToken :: TT } +-- > instance 'TokenType' MyToken where { 'unwrapTT' = unwrapMyToken; 'wrapTT' = MyToken; } +-- > data MyMetaTT WHITESPACE | NUMBER | LABEL +-- > +-- > instance 'MetaToken' MyMetaTT MyToken where { 'tokenDBFromMetaValue' _ = getTokenDB } +-- > instance 'HasTokenDB' MyToken where +-- > getTokenDB = 'makeTokenDB' $ do +-- > mySpace <- emptyToken WHITESPACE $ 'rxRepeat1'('Prelude.map' 'ch' "\n\t ") +-- > let number = 'from' '0' 'to' '9' +-- > myNumber <- fullToken NUMBER $ 'rxRepeat1' number +-- > let alpha_ = [ch '_', 'from' '@A@' 'to' '@Z@', 'from' '@a@' 'to' '@z@'] +-- > myLabel <- fullToken LABLE $ 'rxRepeat1' alpha_ . rxRepeat(number : alpha_) +-- > -- now the 'TT' values have been associated with the 'Dao.String.UStr' values +-- > -- of your 'MetaToken' type. +-- > 'activate' [mySpace, myNumber, myLabel] +-- > +-- > data MyAST = NullAST | Assign{ label :: 'Prelude.String', intValue :: 'Prelude.Int' } +-- > mkAssign :: String -> String -> MyAST +-- > mkAssign lbl val = Assign{ label = lbl, intValue = 'Prelude.read' val } +-- > +-- > -- make a 'TokStream' that parses a label, followed by a space, followed by a number +-- > myTokStream :: TokStream () MyToken MyAST +-- > myTokStream = 'Control.Applicative.pure' mkAssign 'Control.Applicative.<*>' ('token' LABEL) 'Control.Applicative.<*>' ('token' NUMBER) +class (Enum meta, UStrType meta) => + MetaToken meta tok | meta -> tok where { tokenDBFromMetaValue :: meta -> TokenDB tok } + +-- | This class exists to to provide the 'tokenBy' function. +class TokenType tok => HasTokenDB tok where { tokenDB :: TokenDB tok } +getTokenDB :: HasTokenDB tok => Parser st tok (TokenDB tok) +getTokenDB = return tokenDB + +tokenDBFromToken :: HasTokenDB tok => tok -> TokenDB tok +tokenDBFromToken _ = tokenDB + +tokenDBFromParser :: HasTokenDB tok => Parser st tok a -> TokenDB tok +tokenDBFromParser _ = tokenDB + +-- | If the given 'Parser' backtracks then evaluate to @return ()@, otherwise ignore the result of +-- the 'Parser' and evaluate to @return ()@. +ignore :: TokenType tok => Parser st tok ig -> Parser st tok () +ignore parser = mplus (parser >> return ()) (return ()) + +-- | Return the default value provided in the case that the given 'Parser' fails, otherwise +-- return the value returned by the 'Parser'. +defaultTo :: TokenType tok => a -> Parser st tok a -> Parser st tok a +defaultTo defaultValue parser = mplus parser (return defaultValue) + +-- | Given two parameters: 1. an error message and 2. a 'Parser', will succeed normally if +-- evaluating the given 'Parser' succeeds. But if the given 'Parser' backtracks, this this function +-- will evaluate to a 'Parser' failure with the given error message. If the given 'Parser' fails, +-- it's error message is used instead of the error message given to this function. The string +-- "expecting " is automatically prepended to the given error message so it is a good idea for your +-- error message to simple state what you were expecting, like "a string" or "an integer". I +-- typically write 'expect' statements like so: +-- > fracWithExp = do +-- > fractionalPart <- parseFractional +-- > 'tokenStrType' 'Alphabetic' (\tok -> tok=="E" || tok=="e") +-- > 'expect' "an integer expression after the 'e'" $ do +-- > exponentPart <- parseSignedInteger +-- > return (makeFracWithExp fractionalPart exponentPart :: 'Prelude.Double') +expect + :: (TokenType tok, UStrType str, MonadError (ParseError (TokStreamState st tok) tok) (Parser st tok)) + => str -> Parser st tok a -> Parser st tok a +expect errMsg parser = do + loc <- mplus (look1 asLocation) (Parser (gets finalLocation)) + let expectMsg = "expecting " ++ uchars errMsg + mplus parser (throwError ((parserErr loc){parseErrMsg = Just (ustr expectMsg)})) + +-- | Given a constructor that takes an arbitray value and a 'Dao.NewTokStream.Location' value, and a +-- 'Dao.NewTokStream.Parser' that evaluates to the same type of arbitrary value, this function +-- automatically notes the location of the current token, then evaluates the parser, then notes the +-- location of the next token to create a 'Dao.NewTokStream.Location' value and apply it to the +-- constructor. +withLoc :: TokenType tok => Parser st tok (Location -> a) -> Parser st tok a +withLoc parser = do + before <- look1 asLocation + cons <- parser + after <- mplus (look1 asLocation) (Parser (gets finalLocation)) + return (cons (before<>after)) + +shift :: TokenType tok => (TokenAt tok -> a) -> Parser st tok a +shift as = Parser (fmap as (nextToken True)) + +look1 :: TokenType tok => (TokenAt tok -> a) -> Parser st tok a +look1 as = Parser (fmap as (nextToken False)) + +unshift :: TokenType tok => TokenAt tok -> Parser st tok () +unshift tok = Parser $ modify (\st -> st{tokenQueue = tok : tokenQueue st}) + +metaTypeToTokenType :: (TokenType tok, MetaToken meta tok) => meta -> tok +metaTypeToTokenType meta = + case M.lookup (toUStr meta) (tableUStrToTT (tokenDBFromMetaValue meta)) of + Nothing -> error $ "internal: parser defined to use meta token "++show (toUStr meta)++ + " without having activated any tokenizer that constructs a token of that meta type" + Just tt -> wrapTT tt + +-- | This function takes two parameters, the first is a polymorphic function we can call +-- @getter@ that takes some of the contents of the current token in the stream. The first value +-- is a 'MetaToken' value we can call @meta@. This function will check the whether current token +-- in the stream has an identifier value that matches the given @meta@ value. If so, the current +-- token is shifted off of the stream and passed to the @getter@ function to extract the +-- necessary information from the token. +-- +-- Valid @getter@ functions are 'asTokType', 'asString', 'asUStr', 'as0', 'asToken', +-- 'asTokenAt', 'asTriple', 'asLineColumn', 'asLocation', or any composition of functions with +-- any of the above as the right-most function. +token :: (TokenType tok, MetaToken meta tok) => meta -> (TokenAt tok -> a) -> Parser st tok a +token meta as = look1 asTokType >>= \tok -> + if tok == metaTypeToTokenType meta then shift as else mzero + +-- | Useful for keywords or operators, this function is used to check if the next 'Token' value +-- in the 'Parser' is of a 'TokenType' labeled by the given constant string. This function +-- has similar behavior to @('tokenString' 'shift')@, /HOWEVER/ unlike 'tokenString', /this +-- function is much more efficient/ because the 'Token' identifier is looked up in the 'TokenDB' +-- only once and then used to add this parser to a parse table instead of merely comparing the +-- string value of the token. +-- +-- Valid @getter@ functions are 'asTokType', 'asString', 'asUStr', 'as0', 'asToken', +-- 'asTokenAt', 'asTriple', 'asLineColumn', 'asLocation', or any composition of functions with +-- any of the above as the right-most function. +tokenBy :: (UStrType name, HasTokenDB tok) => name -> (TokenAt tok -> a) -> Parser st tok a +tokenBy name as = do + db <- getTokenDB + let uname = toUStr name + tok <- look1 id + case M.lookup uname (tableUStrToTT db) of + Nothing -> if asUStr tok == uname then shift as else mzero + Just tt -> if unwrapTT (asTokType tok) == tt then shift as else mzero + +-- | A 'marker' immediately stores the cursor onto the runtime call stack. It then evaluates the +-- given 'Parser'. If the given 'Parser' fails, the position of the failure (stored in a +-- 'Dao.Token.Location') is updated such that the starting point of the failure points to the cursor +-- stored on the stack by this 'marker'. When used correctly, this function makes error reporting a +-- bit more helpful. +marker :: TokenType tok => Parser st tok a -> Parser st tok a +marker parser = do + before <- mplus (look1 asLocation) (Parser (gets finalLocation)) + pval <- catchPredicate parser + case pval of + PFail err -> throwError $ err{parseErrLoc = before <> parseErrLoc err} + pval -> predicate pval + +-- | The 'Parser's analogue of 'Control.Monad.State.runState', runs the parser using an existing +-- 'TokStreamState'. +runParserState + :: TokenType tok + => Parser st tok a + -> TokStreamState st tok + -> (Predicate (ParseError (TokStreamState st tok) tok) a, TokStreamState st tok) +runParserState parser initTokSt = case parser of + ParserNull -> (Backtrack, initTokSt) + Parser (TokStream parser) -> runState (runPredicateT parser) initTokSt + +-- | This is the second phase of parsing, takes a stream of tokens created by the 'lexicalAnalysis' +-- phase (the @['Line' tok]@ parameter) and constructs a syntax tree data structure using the +-- 'Parser' monad provided. +syntacticAnalysis + :: TokenType tok + => Parser st tok synTree + -> TokStreamState st tok + -> (Predicate (ParseError (TokStreamState st tok) tok) synTree, TokStreamState st tok) +syntacticAnalysis = runParserState + +getNullToken :: TokenType tok => Parser st tok tok +getNullToken = return (wrapTT (MkTT 0)) + +isEOF :: TokenType tok => Parser st tok Bool +isEOF = Parser (get >>= \st -> return (null (getLines st) && null (tokenQueue st))) + +---------------------------------------------------------------------------------------------------- + +-- | Parse table, used to create arrays of tokens that can be used to efficiently select the next +-- parse action to take based on the value of the current token in the token stream. +data PTable tok a + = PTableNull + | PTable { pTableArray :: Array TT (Maybe (TokenAt tok -> a)) } +instance TokenType tok => Functor (PTable tok) where + fmap f ptab = case ptab of + PTableNull -> PTableNull + PTable arr -> PTable (fmap (fmap (fmap f)) arr) +instance (Monoid a, TokenType tok) => Monoid (PTable tok a) where + mempty = PTableNull + mappend a b = case a of + PTableNull -> b + PTable arr -> case b of + PTableNull -> PTable arr + PTable arr' -> PTable (mergeArrays mappend mempty arr arr' ) + +newtype TableItem tok a = TableItem{ tableItemToPair :: (tok, TokenAt tok -> a) } +instance TokenType tok => Functor (TableItem tok) where + fmap f (TableItem ti) = TableItem (fmap (fmap f) ti) + +tableItem :: (TokenType tok, MetaToken meta tok) => + meta -> (TokenAt tok -> a) -> TableItem tok a +tableItem meta parser = TableItem (metaTypeToTokenType meta, parser) + +tableItemBy :: (TokenType tok, HasTokenDB tok, UStrType name) => + name -> (TokenAt tok -> a) -> TableItem tok a +tableItemBy name parser = + case M.lookup (toUStr name) (tableUStrToTT (tokdb parser)) of + Nothing -> error ("tableItemBy "++show (toUStr name)++" not activated in TokenDB") + Just tok -> TableItem (wrapTT tok, parser) + where + tokdb :: HasTokenDB tok => (TokenAt tok -> a) -> TokenDB tok + tokdb parser = tokenDBFromToken (tokType parser) + tokType :: HasTokenDB tok => (TokenAt tok -> a) -> tok + tokType _ = undefined -- don't want the value, just the type to be inferred + +-- | Use this function if your 'TableItem' contains a parser which you also need to evalaute as a +-- stand-alon parser. +evalPTableItem :: TokenType tok => TableItem tok a -> Parser st tok a +evalPTableItem (TableItem (tokType, parser)) = + look1 asTokType >>= \t -> if tokType==t then shift id >>= return . parser else mzero + +-- | Usually, 'PTable's and 'TableItem's will contain monadic 'Parser' function elements, and evaluating a +-- 'PTable or 'TableItem' will result in that 'Parser' function element being returned to the monadic +-- function which evaluated it, in which case it must be 'Control.Monad.join'ed. This function +-- provides a handy shortcut to the expression @('Control.Monad.join' . 'evalPTableItem')@. See also +-- 'joinEvalPTable'. +joinEvalPTableItem :: TokenType tok => TableItem tok (Parser st tok a) -> Parser st tok a +joinEvalPTableItem = join . evalPTableItem + +table :: Monoid a => TokenType tok => [TableItem tok a] -> PTable tok a +table tokParserAssocs = case asocs of + [] -> PTableNull + (tok1, _):_ -> PTable (accumArray mappend mempty bnds ttParserAssocs) where + ttParserAssocs = fmap (\ (tok, parser) -> (unwrapTT tok, Just parser)) asocs + tt = unwrapTT tok1 + bnds = foldl (\ (lo, hi) (tt, _) -> (min lo tt, max hi tt)) (tt, tt) ttParserAssocs + where + asocs = fmap tableItemToPair tokParserAssocs + +-- | Like 'bindPTable' but operates on a single 'TableItem'. +bindPTableItem :: TokenType tok => + TableItem tok (Parser st tok a) -> (a -> Parser st tok b) -> TableItem tok (Parser st tok b) +bindPTableItem (TableItem item) bind = TableItem (fmap (fmap (>>=bind)) item) + +-- | Like 'bindPTable' but operates on a list of 'TableItem's. +bindPTableItemList :: TokenType tok => + [TableItem tok (Parser st tok a)] -> (a -> Parser st tok b) -> [TableItem tok (Parser st tok b)] +bindPTableItemList list bind = fmap (flip bindPTableItem bind) list + +-- | 'PTable's take functions from a 'TokenAt' type to an arbitrary value, but usually this value is +-- a monadic computation. This function takes a table containing monadic computations in the +-- 'Parser' monad and binds it to a monadic 'Parser' function you provide using the +-- 'Control.Monad.>>=' function, evaluating to a new 'PTable' containing the function you provided. +bindPTable :: TokenType tok => + PTable tok (Parser st tok a) -> (a -> Parser st tok b) -> PTable tok (Parser st tok b) +bindPTable table bind = case table of + PTableNull -> PTableNull + PTable arr -> PTable (fmap (fmap (fmap (>>=bind))) arr) + +evalPTable :: TokenType tok => PTable tok a -> Parser st tok a +evalPTable ptable = case ptable of + PTableNull -> mzero + PTable arr -> do + tok <- look1 id + let tt = unwrapTT (asTokType tok) + if inRange (bounds arr) tt + then case arr!tt of + Nothing -> mzero + Just fn -> shift id >>= return . fn + else mzero + +-- | 'PTable's take functions from a 'TokenAt' type to an arbitrary value, but usually this value is +-- a monadic computation, therefore evaluating the table results in a computation that you must join +-- to the monad in which it was evaluated using 'Control.Monad.join'. This is so common it is +-- worthwhile to provide the 'joinEvalPTable' function as a handy shortcut for the expression: +-- > 'Control.Monad.join' ('evalPTable' myTable) +joinEvalPTable :: TokenType tok => PTable tok (Parser st tok a) -> Parser st tok a +joinEvalPTable = join . evalPTable + +---------------------------------------------------------------------------------------------------- +-- $Infix_operator_table +-- An infix operator table is an efficient method to parse equations expressed with infix operators. +-- These functions and data types allow you to define a grammar that can handle operator precedence +-- and right or left associativity (for example the rules for PEMDAS/BOMDAS). +-- +-- The polymorphic types used throughout use @op@ as the operator token type, and @o@ as the +-- expression type. Your grammar must be some form of tree data structure similar to this example: +-- > data Equation = LEAF Int | BRANCH Equation Char Equation +-- You have at least two constructors, leaves store values and branches store operators and branch +-- to other trees. In the above example, the @Equation@ data type would be bound to the polymorphic +-- type @o@, and @Data.Char.Char@ would be bound to the polymorphic @op@ type. + +--------- +-- Personal note: I considered making the 'InfixConstr' and 'OpPrec' types of the form: +-- > type InfixConstr a op b = a -> op -> a -> b +-- > data OpPrec a op b = OpPrec Associativity [UStr] (InfixConster a op b) +-- But this required me to add another function to the 'OpTableParser' of the type @(a -> b)@ to +-- handle the case where the there was only a single value not followed by an operator. But I +-- figured this could be handled without complicating things: you can simply require the parsed type +-- to be @a@ and use 'fmap' to convert the result of the parse table to @b@ using @(a -> b)@. +-- +-- I also tried making InfixConstr like this: +-- > type InfixConstr a op b = a -> op -> b -> a +-- and also +-- > type InfixConstr a op b = a -> op -> b -> b +-- But doing this does not allow one to easily mix together right and left associative parsers into +-- a single table. Again, it is best to assume a consistent type for all tokens over which to fold, +-- and place the burden of matching inconsistent types on whoever is writting the infix parser. + +-- | An infix constructor is a function of this form. It takes a 'Location' as it's final parameter, +-- which will denote the location of the @op@ token. The 'Location' can just be ignored if you want. +type InfixConstr st tok op o = o -> op -> o -> Parser st tok o + +-- | Used to define right or left associativity for infix operators. +newtype Associativity = Associativity{ associatesLeft :: Bool } deriving (Eq, Ord) +instance Show Associativity where + show (Associativity left) = if left then "leftAssoc" else "rightAssoc" + +associatesRight :: Associativity -> Bool +associatesRight = not . associatesLeft + +rightAssoc :: Associativity +rightAssoc = Associativity False + +leftAssoc :: Associativity +leftAssoc = Associativity True + +runAssociativity + :: TokenType tok + => Associativity + -> InfixConstr st tok op o + -> o + -> [(o, op)] + -> Parser st tok o +runAssociativity assoc constr o stack = + if associatesLeft assoc + then foldl (\ lhs (rhs, op) -> lhs >>= \lhs -> constr lhs op rhs) (return o) stack + else (foldr (\ (rhs, op) next initObj -> next rhs >>= constr initObj op) return stack) o + +-- | This data type is used to relate an 'Associativity' and an 'InfixConstr' to some operators, +-- the operators being given as strings. +data OpPrec st tok op o + = OpPrec + { opPrecAssoc :: Associativity + , opPrecOps :: [UStr] + , opPrecConstr :: InfixConstr st tok op o + } + +opLeft :: UStrType str => [str] -> InfixConstr st tok op o -> OpPrec st tok op o +opLeft = OpPrec leftAssoc . map toUStr + +opRight :: UStrType str => [str] -> InfixConstr st tok op o -> OpPrec st tok op o +opRight = OpPrec rightAssoc . map toUStr + +-- Stored in the 'OpTableParser', used to make choices on when to stack a token and when backtrack. +type OpTablePrec st tok op o = Maybe (Associativity, Int, InfixConstr st tok op o) + +-- | Use this data type to setup an operator table parser which parses a sequence of @o@ type data +-- separated by @op@ type operator tokens, where the @op@ tokens have been assigned the properties +-- of fixity and right or left associativity. +data OpTableParser st tok op o + = OpTableParser + { opTableErrMsg :: UStr + , opTableAutoShift :: Bool + -- ^ instructs the 'evalOpTableParser' whether or not to automatically shift the operator + -- token from the token stream. Usually you should set this tor 'Prelude.True'. However if + -- your @op@ parser is more complicated than just converting a token, and actually needs to + -- parse tokens in between terms, set this to 'Prelude.False' and make the 'opTableOpAs' + -- function perform parsing and shifting of the operator. If you do set this to + -- 'Prelude.False', make sure your 'opTableOpAs' function evaluates 'shift' at least once. + -- The original reason for providing this option is to more easily build parsers that keep + -- comments in the abstract syntax tree. Parsers that keep comments will usually parse all + -- comments at the beginning of the file, then proceed with parsing, and every token parsed + -- will have comments immediately after it parsed and paired with it. But it would be + -- impossible to create such a parser without the ability to specify exactly when to shift the + -- operator token and parse the comments. + , opTableOpAs :: TokenAt tok -> Parser st tok op + -- ^ 'TokenAt' values are automatically retrieved from the token stream by the + -- 'evalOpTableParser' function, and this function is used to convert those 'TokenAt' values + -- to values of data type @op@. During evaluation of 'evalOpTableParser' this function is + -- evaluated before the operator token is shifted from the token stream. + , opTableObjParser :: Parser st tok o + -- ^ This function will parse the non-opreator values of the equation. + , opTableConstr :: InfixConstr st tok op o + -- ^ This function is used to construct an @o@ from a stack of @o@ and @op@ values, it is + -- passed to 'runAssociativity'. In an arithmetic parser, for example, this function might be + -- of the form: + -- > constr :: Int -> String -> Int -> Int + -- > constr a op b = if op=="+" then a+b else if op=="*" then a*b + , opTableArray :: Maybe (Array TT (OpTablePrec st tok op o)) + } + +-- | Evaluate an 'OpTableParser' to a 'Parser'. +evalOpTableParser :: (HasTokenDB tok, TokenType tok, Show o) => OpTableParser st tok op o -> Parser st tok o +evalOpTableParser optab = evalOpTableParserWithInit (opTableObjParser optab) optab + +-- | Same as 'evalOpTableParser', but lets you provide a different parser for parsing the first +-- object term in the expression. This is useful if the function for parsing the initial term of the +-- expression is a prefix expression (but necessarily returns the same data type) of the function +-- that parses object terms in the expression. After the initial parser function is evaluated, the +-- 'opTableObjParser' function is used for every other term after it. +evalOpTableParserWithInit + :: (HasTokenDB tok, TokenType tok) + => Parser st tok o + -> OpTableParser st tok op o + -> Parser st tok o +evalOpTableParserWithInit initParser optab = do + initObj <- initParser + maybe (return initObj) (begin initObj) (opTableArray optab) + where + begin o table = mplus (lookGetPrec table >>= bindLeft table o) (return o) + lookGetPrec table = do + tok <- look1 id + let tt = unwrapTT (asTokType tok) + if inRange (bounds table) tt + then case table!tt of + Nothing -> mzero + Just (a,b,c) -> return (tok, a, b, c) + else mzero + bindLeft table leftObj (tok, assoc, prec, constr) = flip mplus (return leftObj) $ do + op <- opTableOpAs optab tok + if opTableAutoShift optab then shift as0 else return () + (rightObj, opInfo) <- bindRight table tok assoc prec + o <- constr leftObj op rightObj + case opInfo of + Nothing -> return o + Just opInfo -> bindLeft table o opInfo + bindRight table tok assoc prec = do + expect (uchars (opTableErrMsg optab)++" after "++show tok++" token") $ do + leftObj <- opTableObjParser optab + flip mplus (return (leftObj, Nothing)) $ do + opInfo@(nextTok, nextAssoc, nextPrec, constr) <- lookGetPrec table + let mergeStack = return (leftObj, Just opInfo) + let msg assoc = "associates to the "++(if associatesLeft assoc then "left" else "right") + case () of + () | assoc/=nextAssoc && prec==nextPrec -> fail $ unwords $ + [ "ambiguous experession, infix operators" + , show tok, "and", show nextTok, "are of the same prescedence, but" + , show tok, msg assoc, "whereas", show nextTok, msg nextAssoc + ] + () | associatesLeft assoc && prec>=nextPrec -> mergeStack + () | associatesRight assoc && prec> nextPrec -> mergeStack + () -> do + op <- opTableOpAs optab nextTok + if opTableAutoShift optab then shift as0 else return () + (rightObj, opInfo) <- bindRight table nextTok nextAssoc nextPrec + constr leftObj op rightObj >>= \o -> return (o, opInfo) + +-- | Sets up the 'OpTableParser' data structure. +-- +-- The first parameter is a function used to parse the right and left hand sides of each infix +-- operator. This function may safely recurse to itself via the 'Parser' created by the evaluation +-- of 'evalOpTableParser' provided that there is at least one other parser that does not recurse +-- which is tried before it. For example: +-- > myOperatorTable :: OpPrecTable MyOperator MySymbol +-- > myOperatorFromToken :: 'TokenAt' MyTokType -> 'Parser' () MyTokType MyOperator +-- > nonRecursive :: 'Parser' () MyTokType MySymbol -- This parser never recurses to 'myExpression'. +-- > +-- > -- This parser does recurse to 'myExpression' +-- > recursive :: 'Parser' () MyTokType MySymbol +-- > recursive = 'evalOpTableParser' myExpression +-- > +-- > -- This expression parser is OK, it will not loop infinitely as long as nonRecursive takes at +-- > least one token from the token stream. +-- > myExpression :: 'OpTableParser' () MyTokType MyOperator MySymbol +-- > myExpression = 'newOpTableParser' (nonRecursive >> recursive) myOperatorFromToken myOperatorTable +-- > +-- > -- These expression parsers will loop infinitely doing nothing: +-- > badExpression1 = 'newOpTableParser' recursive myOperatorFromToken myOperatorTable +-- > badExpression2 = 'newOpTableParser' (nonRecursive<|>recursive) myOperatorFromToken myOperatorTable +-- > +-- +-- The second parameter is a function which produces an @op@ data type from a 'TokenAt' value. +-- Operators are taken from the token stream by the table evaluator, and this function will take the +-- 'TokenAt' value provided by the table evaluator and convert it to an operator data type. The @op@ +-- typed data evaluated from this function will be used to construct the final @o@ value. +-- +-- The final parameters is an 'OpPrecTable' which you construct with the 'opPrecTable' or 'opTable' +-- functions, where you will assign prescedence and associativity properties to every operator +-- token. +newOpTableParser + :: (HasTokenDB tok, TokenType tok, UStrType errMsg) + => errMsg + -> Bool + -> (TokenAt tok -> Parser st tok op) + -> Parser st tok o + -> InfixConstr st tok op o + -> [OpPrec st tok op o] + -> OpTableParser st tok op o +newOpTableParser errMsg autoShift asOp objParser constr optab = + OpTableParser + { opTableErrMsg = toUStr errMsg + , opTableAutoShift = autoShift + , opTableObjParser = objParser + , opTableOpAs = asOp + , opTableConstr = constr + , opTableArray = inferTypes objParser tokenDB optab + } + where + ttBounds (tt, _) = foldl (\ (lo, hi) (tt, _) -> (min lo tt, max hi tt)) (tt, tt) . tail + maxPrec = length optab + precList + :: (TokenType tok, HasTokenDB tok) + => Parser st tok o + -> TokenDB tok + -> [OpPrec st tok op o] + -> [(TT, OpTablePrec st tok op o)] + precList _ db optab = do + (n, p) <- zip [0..] optab + op <- opPrecOps p + case M.lookup op (tableUStrToTT db) of + Nothing -> error ("internal, token "++show op++" has not been activated in the TokenDB") + Just op -> return (op, Just (opPrecAssoc p, maxPrec-n, opPrecConstr p)) + inferTypes + :: (TokenType tok, HasTokenDB tok) + => Parser st tok o + -> TokenDB tok + -> [OpPrec st tok op o] + -> Maybe (Array TT (OpTablePrec st tok op o)) + inferTypes parser db optab = case precList parser db optab of + [] -> Nothing + ax -> Just (accumArray (flip const) Nothing (ttBounds (head ax) ax) ax) + +-- | Evaluate a parser with infix operators in between each term. Provide an initial parser to be +-- evaluated for the first term only, then the function for parsing terms of the expression, then +-- the infix operator parser. All infix operators will be of the same prescedence and the given +-- associativity. No tables are created by this function, so it is a good idea for your infix +-- operator parser and or the parser for evaluating terms to be functions of the 'table' function. +simpleInfixedWithInit + :: (TokenType tok, UStrType errMsg) + => errMsg + -> Associativity + -> InfixConstr st tok op o + -> Parser st tok o + -> Parser st tok o + -> Parser st tok op + -> Parser st tok o +simpleInfixedWithInit errMsg assoc constr initPar objPar opPar = initPar >>= loop [] where + loop stack initObj = flip mplus (runAssociativity assoc constr initObj stack) $ + opPar >>= \op -> expect (toUStr errMsg) (objPar >>= \o -> loop (stack++[(o, op)]) initObj) + +-- | Same as 'simpleInfixedWithInit' except the fourth parameter (the function for parsing the terms +-- of the expression) is used as both the initial term parser and the function for parsing terms of +-- the expression. +simpleInfixed + :: (TokenType tok, UStrType errMsg) + => errMsg + -> Associativity + -> InfixConstr st tok op o + -> Parser st tok o + -> Parser st tok op + -> Parser st tok o +simpleInfixed errMsg assoc constr objPar opPar = objPar >>= loop [] where + loop stack initObj = flip mplus (runAssociativity assoc constr initObj stack) $ + opPar >>= \op -> expect (toUStr errMsg) (objPar >>= \o -> loop (stack++[(o, op)]) initObj) + +---------------------------------------------------------------------------------------------------- +-- | A 'Language' is a data structure that allows you to easily define a +-- two-phase parser (a parser with a 'lexicalAnalysis' phase, and a 'syntacticAnalysis' phase). The +-- fields supplied to this data type define the grammar, and the 'parse' function can be used to +-- parse an input string using the context-free grammar defined in this data structure. *Note* that +-- the parser might have two phases, but because Haskell is a lazy language and 'parse' is a pure +-- function, both phases happen at the same time, so the resulting parser does not need to parse the +-- entire input in the first phase before beginning the second phase. +-- +-- This data type can be constructed from a 'Parser' in such a way that the resulting +-- 'Parser' is stored in this object permenantly. It might then be possible to reduce +-- initialization time by using an *INLINE* pragma, which will hopefully cause the compiler to +-- define as much of the 'Parser'@'@s sparse matrix as it possibly can at compile time. But this +-- is not a guarantee, of course, you never really know how much an optimization helps until you do +-- proper profiling. +data Language st tok synTree + = Language + { columnWidthOfTab :: TabWidth + -- ^ specify how many columns a @'\t'@ character takes up. This number is important to get + -- accurate line:column information in error messages. + , mainLexer :: Lexer tok () + -- ^ *the order of these tokenizers is important,* these are the tokenizers passed to the + -- 'lexicalAnalysis' phase to generate the stream of tokens for the 'syntacticAnalysis' phase. + , mainParser :: Parser st tok synTree + -- ^ this is the parser entry-point which is used to evaluate the 'syntacticAnalysis' phase. + } + +-- | Construct a 'Language' from a 'Parser'. This defines a complete parser that can be used +-- by the 'parse' function. In constructing this 'Language', the 'Parser' will be converted +-- to a 'Parser' which can be referenced directly from this object. This encourages the runtime +-- to cache the 'Parser' which can lead to better performance. Using an INLINE pragma on this +-- value could possibly improve performance even further. +newLanguage :: (HasTokenDB tok, TokenType tok) => + TabWidth -> Parser st tok synTree -> Language st tok synTree +newLanguage tabw parser = + Language + { columnWidthOfTab = tabw + , mainLexer = tokenDBLexer tokenDB + , mainParser = parser + } + +-- | This is /the function that parses/ an input string according to a given 'Language'. +parse :: TokenType tok => + Language st tok synTree -> st -> String -> Predicate (ParseError st tok) synTree +parse lang st input = case lexicalResult of + OK () -> case parserResult of + OK a -> OK a + Backtrack -> Backtrack + PFail err -> PFail $ err{parseStateAtErr = Just (userState parserState)} + Backtrack -> Backtrack + PFail err -> PFail $ (lexErrToParseErr err){parseStateAtErr = Nothing} + where + initState = (newLexerState input){lexTabWidth = columnWidthOfTab lang} + (lexicalResult, lexicalState) = lexicalAnalysis (mainLexer lang) initState + (parserResult , parserState ) = + syntacticAnalysis (mainParser lang) (newTokStreamFromLexer st lexicalState) + +---------------------------------------------------------------------------------------------------- + +mergeArrays :: Ix i => (e -> e -> e) -> e -> Array i e -> Array i e -> Array i e +mergeArrays plus zero a b = + accumArray plus zero (boun (bounds a) (bounds b)) (assocs a ++ assocs b) where + boun (loA, hiA) (loB, hiB) = (min loA loB, max hiA hiB) + +---------------------------------------------------------------------------------------------------- + +class Parseable a where + parser :: TokenType tok => Parser st tok a + +class HasParseTable a where + parseTable :: TokenType tok => PTable tok a + diff --git a/src/Dao/Predicate.hs b/src/Dao/Predicate.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Predicate.hs @@ -0,0 +1,253 @@ +-- "src/Dao/Predicate.hs" provides 'PredicateT' which combines the +-- Maybe and Either types into a single monad. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} + +-- | Provides a monad that essentially combines the monadic functionality of 'Prelude.Maybe' and +-- 'Prelude.Either' into a single monad 'Predicate. Both the 'Prelude.Maybe' and 'Prelude.Either' +-- data types are both monads but it is convenient to have a single data type combining the two. +-- 'PFail' is analogous to @'Prelude.Left'@, 'Backtrack' is analogous to +-- @'Prelude.Right' $ 'Prelude.Nothing'@, and 'OK' is analogous to +-- @'Prelude.Right' . 'Prelude.Just'@. All relevant monad transformers are instnatiated, including +-- 'Control.Applicative.Applicative', 'Control.Applicative.Alternative', 'Control.Monad.MonadPlus', +-- and 'Control.Monad.Error.MonadError'. +-- +-- A new monad transformer 'PredicateT' is also introduced which lifts the 'Predicate' monad into +-- another monad and wraps it into the 'PredicateT' data type which instantiates the +-- 'Control.Monad.Trans.MonadTrans' class. Further, a new class 'MonadPlusError' is defined which +-- allows you to directly manipulate the 'Predicate' value of a 'PredicateT' transformer. +-- +-- Here is a simple example of how to use this module. +-- > newtype MyErr = MyErr String +-- > newtype MyIO a = WrapMyIO { unwrapMyIO :: 'PredicateT' MyErr IO a } +-- > deriving (Functor, Applicative, Alternative) +-- > +-- > instance 'Control.Monad.Monad' MyIO where -- this instance can also be derived +-- > 'Control.Monad.return' = WrapMyIO . 'Control.Monad.return' +-- > f 'Control.Monad.>>= bindTo = WrapMyIO $ unwrapMyIO f 'Control.Monad.>>=' unwrapMyIO . bindTo +-- > 'Control.Monad.fail' message = WrapMyIO $ 'PFail' (MyErr message) +-- > +-- > instance 'Control.Monad.MonadPlus' MyIO where -- this instance can also be derived +-- > 'Control.Monad.mzero' = WrapMyIO 'mzero' +-- > 'Control.Monad.mplus' (WrapMyIO try1) (WrapMyIO try2) = WrapMyIO ('mplus' try1 try2) +-- > +-- > instance 'Control.Monad.Error.Class.MonadError' MyErr MyIO where +-- > 'Control.Monad.Error.Class.MonadError.throwError' = WrapMyIO . 'Control.Monad.Error.Class.MonadError.throwError' +-- > 'Control.Monad.Error.Class.MonadError.catchError' (WrapMyIO try) catch = WrapMyIO ('catchError' try (unwrapMyIO . catch)) +-- > +-- > instance 'Control.Monad.IO.Class.MonadIO' MyIO where +-- > 'Control.Monad.IO.Class.liftIO' = WrapMyIO . 'liftIO' +-- > +-- > doStep :: MyIO () +-- > doStep = ... +-- > +-- > doJump :: MyIO () +-- > doJump = ... +module Dao.Predicate where + +import Control.Applicative +import Control.Monad +import Control.Monad.Error + +import Data.Monoid + +-- | 'Predicate' is a data type that combines 'Prelude.Maybe' and 'Prelude.Either' into a single +-- type. The 'Predicate' monad allows you to construct predicate functions that evaluate to 'OK' +-- (true) 'Backtrack' (false), and also provides a 'PFail' constructor for indicating a "does not +-- make sense" condition. +-- +-- The truth condition 'OK' can 'Control.Monad.return' a value which makes it a 'Data.Functor', an +-- 'Control.Applicative.Applicative', and a 'Control.Monad.Monad'. The false condition 'Backtrack' +-- serves as the 'Control.Monad.mzero' for 'Control.Monad.MonadPlus' and 'Control.Applicative.empty' +-- value for 'Control.Applicative.Alternative'. The 'PFail' condition, like 'Prelude.Left', can be +-- used as an error condition in the 'Control.Monad.Error.ErrorClass' which can be caught by +-- 'Control.Monad.Error.catchError'. +-- +-- This data type was originally intended for use in the Dao parser, but it is now used in several +-- contexts throughout the program. +data Predicate err ok + = Backtrack -- ^ analogous to 'Prelude.Nothing' + | PFail err -- ^ analogous to 'Prelude.Left' + | OK ok -- ^ OK is "just right" i.e. it is analogous to 'Prelude.Just' and 'Prelude.Right'. + deriving (Eq, Ord, Show) + +instance Functor (Predicate err) where + fmap fn (OK a) = OK (fn a) + fmap _ (PFail u) = PFail u + fmap _ Backtrack = Backtrack + +instance Monad (Predicate err) where + return = OK + ma >>= mfn = case ma of + OK ok -> mfn ok + PFail err -> PFail err + Backtrack -> Backtrack + +instance MonadPlus (Predicate err) where + mzero = Backtrack + mplus Backtrack b = b + mplus a _ = a + +instance MonadError err (Predicate err) where + throwError = PFail + catchError try catch = case try of + PFail err -> catch err + try -> try + +instance Applicative (Predicate err) where { pure = return; (<*>) = ap; } + +instance Alternative (Predicate err) where { empty = mzero; (<|>) = mplus; } + +instance Monoid ok => Monoid (Predicate err ok) where + mempty = Backtrack + mappend (OK a) (OK b) = OK(a<>b) + mappend a _ = a + +---------------------------------------------------------------------------------------------------- + +-- | A monad transformer lifting 'Predicate' into an outer monad. Use 'runPreicateT' to remove the +-- 'PredicateT' outer monad and retrieve the inner 'Predictate' value. +newtype PredicateT err m ok = PredicateT { runPredicateT :: m (Predicate err ok) } + +instance Monad m => Monad (PredicateT err m) where + return a = PredicateT (return (OK a)) + PredicateT ma >>= fma = PredicateT $ do + a <- ma + case a of + Backtrack -> return Backtrack + PFail u -> return (PFail u) + OK o -> runPredicateT (fma o) + PredicateT ma >> PredicateT mb = PredicateT $ do + a <- ma + case a of + Backtrack -> return Backtrack + PFail u -> return (PFail u) + OK _ -> mb + fail msg = PredicateT{ runPredicateT = return (PFail (error msg)) } + +instance Functor m => Functor (PredicateT err m) where + fmap f (PredicateT ma) = PredicateT (fmap (fmap f) ma) + +instance Monad m => MonadPlus (PredicateT err m) where + mzero = PredicateT (return Backtrack) + mplus (PredicateT a) (PredicateT b) = PredicateT $ do + result <- a + case result of + Backtrack -> b + PFail u -> return (PFail u) + OK o -> return (OK o) + +instance Monad m => MonadError err (PredicateT err m) where + throwError msg = PredicateT{ runPredicateT = return (PFail msg) } + catchError ptrans catcher = PredicateT $ do + value <- runPredicateT ptrans + case value of + Backtrack -> return Backtrack + PFail u -> runPredicateT (catcher u) + OK a -> return (OK a) + +instance (Functor m, Monad m) => Applicative (PredicateT err m) where { pure = return; (<*>) = ap; } + +instance (Functor m, Monad m) => Alternative (PredicateT err m) where { empty = mzero; (<|>) = mplus; } + +instance MonadTrans (PredicateT err) where { lift m = PredicateT(m >>= return . OK) } + +instance MonadIO m => MonadIO (PredicateT err m) where { liftIO = PredicateT . liftIO . fmap OK } + +---------------------------------------------------------------------------------------------------- + +-- | Often it is necessary to evaluate a sub-predicate monad within the 'Predicate' or 'PredicateT' +-- monads within the current 'Predicate' monad. Simply evaluating the sub-predicate would cause the +-- current predicate monad to evaluates to 'PFail' or 'Backtrack' if the sub-predicate evaluates to +-- either of these values. But using 'catchPredicate', it is possible to safely evaluate the +-- sub-predicate and capture it's 'Predicate' result, where you can then make a decision on how to +-- behave. +-- > do p <- 'catchPredicate' couldFailOrBacktrack +-- > case p of +-- > 'OK' rval -> useReturnValue rval -- use the return value from couldFailOrBacktrack +-- > 'PFail' msg -> printMyError msg -- report the error from couldFailOrBacktrack +-- > 'Backtrack' -> return () -- ignore backtracking +-- The above procedure prints the error message created if the sub-predicate evaluated to 'PFail'. +-- If you would like to "re-throw" a 'Predicate' that you have received you can use the 'predicate' +-- function. For example, this line of code could be added to the above procedure: +-- > predicate p +-- and the function will evaluate to the same exact 'Predicate' value that @couldFailOrBacktrack@ +-- had produced after the necessary response to the failure has been made, e.g. after the error +-- message has been printed. +class MonadPlusError err m | m -> err where + -- | Unlifts the whole 'Predicate' value, unlike 'catchError' which only catches the value stored + -- in a 'PFail' constructor. + catchPredicate :: m a -> m (Predicate err a) + -- | This will force the 'Predicate' value of the current computation. The following should + -- generally be true for all instances of 'MonadPlusError'. + -- > 'Control.Monad.return' = 'predicate' . 'OK' + -- > 'Control.Monad.Error.State.throwError' = 'predicate' . 'PFail' + -- > 'Control.Monad.mzero' = 'predicate' 'Backtrack' + predicate :: Predicate err a -> m a + +instance MonadPlusError err (Predicate err) where { catchPredicate = OK; predicate = id; } + +instance Monad m => MonadPlusError err (PredicateT err m) where + catchPredicate (PredicateT fn) = PredicateT{ runPredicateT = fn >>= \o -> return (OK o) } + predicate pval = PredicateT (return pval) + +-- | Evaluates to an empty list if the given 'Predicate' is 'Backtrack' or 'PFail', otherwise returns a +-- list containing the value in the 'OK' value. +okToList :: Predicate err o -> [o] +okToList pval = case pval of + OK o -> [o] + Backtrack -> [] + PFail _ -> [] + +-- | Like 'okToList', but evaluates to 'Data.Maybe.Nothing' if the given 'Predicate' is 'Backtrack' or +-- 'PFail', or 'Data.Maybe.Just' containing the value in the 'OK' value. +okToJust :: Predicate err o -> Maybe o +okToJust pval = case pval of + OK o -> Just o + Backtrack -> Nothing + PFail _ -> Nothing + +-- | If given 'Data.Maybe.Nothing', evaluates to 'PFail' with the given error information. +-- Otherwise, evaluates to 'OK'. +maybeToPFail :: err -> Maybe o -> Predicate err o +maybeToPFail err o = case o of + Nothing -> PFail err + Just ok -> OK ok + +-- | Like 'Prelude.fmap' but operates on the error report data of the 'Predicate'. +fmapPFail :: (errA -> errB) -> Predicate errA o -> Predicate errB o +fmapPFail f pval = case pval of + OK o -> OK o + Backtrack -> Backtrack + PFail err -> PFail (f err) + +-- | Like 'Data.Either.partitionEithers', but operates on a list of 'Predicates'. +partitionPredicates :: [Predicate err o] -> ([err], [o]) +partitionPredicates = loop [] [] where + loop errs oks ox = case ox of + [] -> (errs, oks) + OK o : ox -> loop errs (oks++[o]) ox + PFail err : ox -> loop (errs++[err]) oks ox + Backtrack : ox -> loop errs oks ox + diff --git a/src/Dao/Random.hs b/src/Dao/Random.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Random.hs @@ -0,0 +1,483 @@ +-- "src/Dao/Random.hs" generates objects from integers that can be used +-- to test the parsers/pretty-printer, and the binary encoder/decoder. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +-- | Hints for making good random object generators: +-- Avoid using scramble more than once per constructor. If you have a data type constructed with: +-- > return DataType <*> 'scrambO' <*> 'scrambO' +-- then just do this instead +-- > 'scramble' $ return DataType <*> 'randO' <*> 'randO' +-- +-- Do not bother preceding generators for newtype data types with 'recurse' or 'countNode', it isn't +-- really necessary. +-- +-- Recursive data types containing lists with 'randList' should probably generate small lists for +-- 'randO' instances, and generate larger lists for 'defaultO' instances. +-- +-- When instantiating 'randO', use only 'randO' to fill-in all the objects contained in the object. +-- When instantiating 'defaultO', use only 'defaultO' to fill-in all the objects contained in the +-- object. +-- +-- When instantiating 'defaultO', it is OK to use 'defaultO' to fill-in other non-recursive data +-- types, but /BE VERY CAREFUL/ not to call 'defaultO' for another non-recursive type. +module Dao.Random where + +import Dao.String +import qualified Dao.Tree as T + +import Control.Exception +import Control.Applicative +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import Control.Monad.State + +import Data.Monoid +import Data.Char +import Data.Word +import Data.Ratio +import Data.Time +import Data.Array.IArray +import qualified Data.ByteString.Char8 as B + +import System.Random +import System.IO + +---------------------------------------------------------------------------------------------------- + +-- | A simple, stateful monad for generating arbitrary data types based on pseudo-random numbers +-- without lifting the @IO@ or @ST@ monads, i.e. it can be evaluated in a pure way. +newtype RandT m a = RandT { runRandT :: StateT RandOState m a } + deriving (Functor, Applicative, Monad, MonadPlus, Alternative) + +instance MonadTrans RandT where { lift = RandT . lift } +instance MonadIO m => MonadIO (RandT m) where { liftIO = RandT . liftIO } + +type RandO a = RandT IO a + +data RandOState + = RandOState + { integerState :: Integer -- ^ the predictable random generator + , stdGenState :: StdGen -- ^ the unpredictable random generator + , nodeCounter :: Int -- ^ counts how many nodes have been created for this particular run + , depthLimit :: Int -- ^ sets the limit of the recursion depth + , currentDepth :: Int -- ^ counts the current recursion depth for this particular run + , deepestSoFar :: Int -- ^ keeps track of how deep the deepest recursion has gone + , traceLevel :: Int + -- ^ when performing a trace, keeps track of how many trace recursions there have been + } + +-- | Initializes the 'RandOState' with two integer values: a maximium recursion depth value (limits +-- the number of times you can recursively call 'limSubRandO') and the seed value passed to +-- 'System.Random.mkStdGen'. +initRandOState :: Int -> Int -> RandOState +initRandOState subdepthlim seed = + RandOState + { integerState = fromIntegral seed + , stdGenState = mkStdGen seed + , nodeCounter = 0 + , depthLimit = subdepthlim + , currentDepth = 0 + , deepestSoFar = 0 + , traceLevel = 0 + } + +-- | Increment the internal node counter of the random generator state. This is good for measuring +-- the "weight" of randomly generated objects. /NOTE:/ do not use this if you also start your +-- 'randO' instance with 'recurse', because 'recurse' also calls this function. +countNode_ :: RandO Int +countNode_ = do + i' <- RandT $ gets nodeCounter + let i = i' + 1 + RandT $ modify (\st -> st{nodeCounter=i}) + return i + +-- | Algorithmically identical 'countNode_' but its function type is such that it can be written like so: +-- > 'countNode' $ do ... +-- whereas the 'countNode' function must be written like so: +-- > do { 'countNode_'; ... } +-- or +-- > countNode_ >> ... +-- /NOTE:/ do not use this if you also start your 'randO' instance with 'recurse', because 'recurse' +-- also calls this function. +countNode :: RandO a -> RandO a +countNode fn = countNode_ >> fn + +newtype RandChoice o = RandChoice{ getChoiceArray :: Maybe (Array Int (RandO o)) } +instance Functor RandChoice where + fmap f (RandChoice arr) = RandChoice $ fmap (fmap (fmap f)) arr +instance Monoid (RandChoice o) where + mempty = RandChoice Nothing + mappend (RandChoice a) (RandChoice b) = RandChoice $ msum + [ do (loA, hiA) <- fmap bounds a + (loB, hiB) <- fmap bounds b + listA <- fmap elems a + listB <- fmap elems b + return $ listArray (min loA loB, max hiA hiB) (listA++listB) + , a, b + ] + +-- | Similar to monadic bind, allows you to create a new 'RandChoice' by using the value produced by +-- another 'RandChoice'. +bindRandChoice :: RandChoice o -> (o -> RandChoice p) -> RandChoice p +bindRandChoice (RandChoice arr) f = RandChoice $ fmap (fmap (\o -> o >>= runRandChoiceOf . f)) arr + +-- | Instantiate your data types into this class if you can generate arbitrary objects from random +-- numbers using the 'RandO' monad. Minimal complete definition is one of either 'randO' or +-- 'randChoice', and one of either 'defaultO' or 'defaultChoice'. +class HasRandGen o where + -- | This is the function used to generate a random object of a data type that only has one + -- constructor. You must define either this or 'randChoice' or both. The 'randChoice' will be + -- defined as @('randChoiceList' ['randO'])@. + randO :: RandO o + randO = runRandChoice + -- | This is the function used to generate a random object of a data type that has multiple + -- constructors. Use 'randChoiceList' to build a list of 'RandO' data types, each item producing + -- an object with a different constructor. You must define either this or 'randO' or both. The + -- 'randO' will be defined using @('runChoiceList' 'randChoice')@ by default. + randChoice :: RandChoice o + randChoice = randChoiceList [randO] + -- | The 'randO' and/or 'randChoice' functions can be defined without any restrictions, they can + -- even be called recursively. But since we are working with randomness, recursion may produce + -- arbitrarily large objects which may consume all memory and crash the program. The 'recurse' + -- function can be used to count the depth of the recursive data type constructed and to limit the + -- depth, and when the limit is reached a non-recursive default value should be constructed + -- instead. This is the function that should produce the non-recursive data. + -- + -- Keep in mind that it is impossible to enforce whether or not the data generated by any function + -- will be recursive or not unless the data type itself is inherently not recursive. So it is the + -- programmers responsiblity to understand how to use this function. This function must terminate, + -- it is your responsibility to see that it does, it is your responsability to make sure you never + -- call a recursive function within this function. + -- + -- For data types that are inherenly not recursive, for example types instantiating + -- 'Prelude.Enum', this function may safely be defined by calling 'randO'. For recursive data + -- types, if the data type instantiates 'Data.Monoid.Monoid', consider returning + -- 'Data.Monoid.mempty'. + -- + -- Either this function or 'defaultChoice' must be defined. + defaultO :: RandO o + defaultO = runDefaultChoice + -- | This function is to 'defaultO' what 'randChoice' is to 'randO': it lets you construct a + -- random object from a list of choices, but like 'defaultO' every choice provided here must NOT + -- be a recursive function. + defaultChoice :: RandChoice o + defaultChoice = randChoiceList [defaultO] + +runRandChoiceOf :: RandChoice o -> RandO o +runRandChoiceOf (RandChoice{ getChoiceArray=arr }) = case arr of + Nothing -> fail "null RandChoice" + Just arr -> let (lo, hi) = bounds arr in join $ (arr!) . (lo+) <$> nextInt (hi-lo) + +runRandChoice :: HasRandGen o => RandO o +runRandChoice = runRandChoiceOf randChoice + +runDefaultChoice :: HasRandGen o => RandO o +runDefaultChoice = runRandChoiceOf defaultChoice + +randChoiceList :: forall o . [RandO o] -> RandChoice o +randChoiceList items = RandChoice{ getChoiceArray = guard (not $ null items) >> (Just arr) } where + len = length items + arr :: Array Int (RandO o) + arr = listArray (0, len-1) items + +instance HasRandGen () where { randO = return (); defaultO = randO; } +instance HasRandGen Int where { randO = randInt; defaultO = randO; } +instance HasRandGen Integer where { randO = fmap fromIntegral randInt; defaultO = randO; } +instance HasRandGen Char where { randO = fmap chr randInt; defaultO = randO } +instance HasRandGen Word64 where { randO = fromIntegral <$> (randO::RandO Int); defaultO = randO; } +instance HasRandGen Rational where + randO = return (%) <*> defaultO <*> ((+1) <$> defaultO) + defaultO = randO +instance HasRandGen Double where { randO = fromRational <$> randO; defaultO = randO; } +instance HasRandGen UTCTime where + randO = do + day <- fmap (ModifiedJulianDay . unsign . flip mod 73000) randInt + sec <- fmap (fromRational . toRational . flip mod 86400) randInt + return (UTCTime{utctDay=day, utctDayTime=sec}) + defaultO = randO +instance HasRandGen NominalDiffTime where + randO = randInteger (fromRational 0) $ \i -> do + div <- randInt + fmap (fromRational . (% fromIntegral div) . longFromInts) (replicateM (mod i 2 + 1) randInt) + defaultO = randO +instance HasRandGen Name where { randO = fmap (fromUStr . randUStr) randInt; defaultO = randO; } +instance HasRandGen UStr where + randO = fmap (ustr . unwords . fmap (uchars . toUStr)) (randList 0 9 :: RandO [Name]) + defaultO = randO +instance HasRandGen Bool where { randO = fmap (0/=) (nextInt 2); defaultO = randO; } +instance HasRandGen a => HasRandGen (Maybe a) where + randO = randO >>= \n -> if n then return Nothing else fmap Just randO + defaultO = return Nothing + +instance (Ord p, HasRandGen p, HasRandGen o) => HasRandGen (T.Tree p o) where + defaultO = return T.Void + randO = recurse $ do + branchCount <- nextInt 4 + cuts <- fmap (map (+1) . randToBase 6) randInt + fmap (T.fromList . concat) $ replicateM (branchCount+1) $ do + wx <- replicateM 6 randO + forM cuts $ \cut -> do + obj <- randO + return (take cut wx, obj) + +-- | Construct a value from an 'Prelude.Int'. Actually, you have a 50/50 chance of drawing a zero, +-- but this is because zeros are used often for you data type. +randInteger :: a -> (Int -> RandO a) -> RandO a +randInteger zero mkOther = do + i <- randInt + let (x, r) = divMod i 2 + if r==0 then return zero else mkOther x + +-- | Generate a random object given a maximum recursion limit, a seed value, and a 'RandO' generator +-- function. The weight (meaning the number of calls to 'countNode', 'countNode_', or 'recurse') of +-- the generated item is also returned. +genRandWeightedWith :: RandO a -> Int -> Int -> IO (a, Int) +genRandWeightedWith (RandT gen) subdepthlim seed = + fmap (fmap nodeCounter) $ runStateT gen (initRandOState subdepthlim seed) + +-- | This function you probably will care most about. does the work of evaluating the +-- 'Control.Monad.State.evalState' function with a 'RandOState' defined by the same two parameters +-- you would pass to 'initRandOState'. In other words, arbitrary random values for any data type @a@ +-- that instantates 'HasRandGen' can be generated using two integer values passed to this function. +genRandWeighted :: HasRandGen a => Int -> Int -> IO (a, Int) +genRandWeighted subdepthlim seed = genRandWeightedWith randO subdepthlim seed + +-- | Like 'genRandWeightedWith' but the weight value is ignored, only being evaluated to the random +-- object, +genRandWith :: RandO a -> Int -> Int -> IO a +genRandWith gen subdepthlim seed = fmap fst $ genRandWeightedWith gen subdepthlim seed + +-- | Like 'genRandWeightedWith' but the weight value is ignored, only being evaluated to the random +-- object. +genRand :: HasRandGen a => Int -> Int -> IO a +genRand subdepthlim seed = genRandWith randO subdepthlim seed + +randTrace :: MonadIO m => String -> RandT m a -> RandT m a +randTrace msg rand = do + trlev <- RandT $ gets traceLevel + nc <- RandT $ gets nodeCounter + sd <- RandT $ gets currentDepth + let prin msg = liftIO $ do + hPutStrLn stderr (replicate trlev ' ' ++ msg) + hFlush stderr >>= evaluate + () <- prin $ "begin "++msg++" c="++show nc++" d="++show sd + RandT $ modify $ \st -> st{traceLevel=trlev+1} + a <- rand >>= liftIO . evaluate + RandT $ modify $ \st -> st{traceLevel=trlev} + () <- prin $ "end "++msg + return a + +-- | Take another integer from the seed value. Provide a maximum value, the pseudo-random integer +-- returned will be the seed value modulo this maximum value (so passing 0 will result in a +-- divide-by-zero exception, passing 1 will always return 0). The seed value is then updated with +-- the result of this division. For example, if the seed value is 10023, and you pass 10 to this +-- function, the result returned will be 3, and the new seed value will be 1002. +-- Using numbers generated from this seed value is very useful for generating objects that are +-- somewhat predictable, but the contents of which are otherwise unpredictable. For example, if you +-- want to generate random functions but always with the names "a", "b", or "c", like so: +-- > a(...), b(...), c(...) +-- where the arguments to these functions can be arbitrary, then have your function generator +-- generate the names of these functions using 'nextInt' like so: +-- > 'Prelude.fmap' ('Prelude.flip' 'Prelude.lookup ('Prelude.zip' "abc" [0,1,2]))'nextInt' 3 +-- then the arguments to these functions can be generated using 'randInt'. The names of the +-- functions will be predictable for your seed values: any seed value divisible by 3 will generate a +-- function named "a", but the arguments will be arbitrary because they were generated by 'randInt'. +nextInt :: Int -> RandO Int +nextInt maxval = if abs maxval==1 || maxval==0 then return 0 else do + st <- RandT $ get + let (i, rem) = divMod (integerState st) (fromIntegral (abs maxval)) + RandT $ put $ st{integerState=i} + return (fromIntegral rem) + +-- | Generate a random integer from the pseudo-random number generator. +randInt :: RandO Int +randInt = RandT $ + state (\st -> let (i, gen) = next (stdGenState st) in (i, st{stdGenState=gen})) + +-- | Mark a recursion point, also increments the 'nodeCounter'. The recusion depth limit set when +-- evaluating a 'randO' computation will not be exceeded. When the number of 'recurse' functions +-- called without returning has reached this limit and this function is evaluated again, the given +-- 'RandO' generator will not be evaluated, the default value will be returned. +recurse :: HasRandGen a => RandO a -> RandO a +recurse fn = do + st <- RandT get + if currentDepth st > depthLimit st + then defaultO + else do + countNode_ + i <- (+1) <$> (RandT $ gets currentDepth) + RandT $ modify (\st -> st{currentDepth = i, deepestSoFar = max (deepestSoFar st) i}) + a <- fn + RandT $ modify (\st -> st{currentDepth = currentDepth st - 1}) + return a + +-- | The 'nextInt' function lets you derive objects from a non-random seed value internal to the +-- state of the 'RandT' monad. This is useful for random objects that have multiple constructors, +-- and you want to generate one of every constructor by simply initializing the random seed with +-- incrementing integers. +-- +-- However every instantiation of 'randChoice' makes use of this seed value. Consequently if your +-- data type is composed entirely of objects which all instantiate 'randChoice', every node of the +-- object will be generated by a non-random number. In some cases this is desirable, it allows you +-- to generate every possible object with a large enough sequence of random numbers. +-- +-- However when you wish to generate a very random, varied set of random objects, this +-- predictability is not desirable. To get around this, you can use the 'scramble' function. This +-- will use the current seed value to initialize a new child random generator with a child random +-- seed, and the provided 'RandT' function will be evaluated with in this child environment. After +-- evaluation is complete, the parent seed is restored. Since the child random seed is derived from the +-- parent seed, you are still guaranteed to always generate the same object from the same seed value, +-- but the child object generated will be much more varied and less predictable. +-- +-- So instead of generating a child node of your object with ordinary 'randO', use 'scrambO' (which +-- is equivalent to @('scramble' 'randO')@ and this will make your objects more varied, even for +-- predictable input. +scramble :: RandO a -> RandO a +scramble fn = do + newGen <- randInt + oldst <- RandT get + RandT (put $ oldst{ stdGenState=mkStdGen newGen }) + let wrap x = toInteger (fromIntegral x :: Word) + x <- wrap <$> randInt + y <- wrap <$> randInt + RandT (modify $ \st -> st{ integerState = x*(1 + (toInteger (maxBound::Word))) + y }) + a <- fn + RandT (modify $ \st -> st{ integerState=integerState oldst, stdGenState=stdGenState oldst }) + return a + +-- | This function is defined simply as @('scramble' 'randO')@, but I expect it to be used often +-- enough it warrants it's own function name. +scrambO :: HasRandGen a => RandO a +scrambO = scramble randO + +-- | The number of unique values a 'Prelude.Int' can be, which is @('Prelude.maxBound'+1)*2@. +intBase :: Integer +intBase = (fromIntegral (maxBound::Int) + 1) * 2 + +-- | Take an ordinary 'Prelude.Int' and make it unsigned by checking if it is a negative value, and +-- if it is, returning the maximum unsigned value plus the negative value, otherwise returning the +-- positive value unchanged. For example, -1 will return @2*('Prelude.maxBound'+1)-1@ and @+1@ will +-- return @1@. +unsign :: Int -> Integer +unsign i = if i<0 then intBase + fromIntegral i else fromIntegral i + +-- | Creates a string of digits from 0 to the given @base@ value by converting a random unsigned +-- integer to the list of digits that represents the random integer in that @base@. For example, if +-- you want a list of digits from 0 to 4 to be produced from a number 54, pass 4 as the base, then +-- the number 54. Each digit of the base-4 number representation of 54 will be returned as a +-- separate integer: @[2,1,3]@ (from lowest to highest place value, where 123 in base 10 would +-- return the list @[3,2,1]@). +randToBase :: Int -> Int -> [Int] +randToBase base i = loop (unsign i) where + loop i = if i==0 then [] else let (i' , sym) = divMod i b in fromIntegral sym : loop i' + b = fromIntegral base + +-- | When generating 'Prelude.Integers' from 'Int's, treat a list of 'Int's as a list of symbols in +-- a base M number, where M is the @('Prelude.maxBound'::'Prelude.Int')@ multiplied by two to allow +-- for every negative number to also be considered a unique symbol. +longFromInts :: [Int] -> Integer +longFromInts = foldl (\a b -> a*intBase + unsign b) 0 + +randEnum :: (Bounded x, Enum x) => x -> x -> RandO x +randEnum lo hi = fmap toEnum (nextInt (abs (fromEnum lo - fromEnum hi))) + +---------------------------------------------------------------------------------------------------- + +randUStr :: Int -> UStr +randUStr = ustr . B.unpack . getRandomWord + +randMultiName :: RandO [UStr] +randMultiName = do + i0 <- randInt + let (i1, len) = divMod i0 4 + fmap ((randUStr i1 :) . map randUStr) (replicateM len randInt) + +-- | When you want to use 'randList' or 'randListOf', you must provide a maximum bound for the +-- number of values generated for the list. Lets say you want a maximum bound of 20 items for your +-- data types. It sounds reasonable, but if your data type is recursive, and your recursion depth +-- limit 'depthLimit' is set to 4, your data type has a chance of creating 20^4 or 160000 nodes! You +-- may want to call 'randListOf' or 'randList' with a diminishing upper bound, a bound which gets +-- lower and lower as the recursion depth increases. +-- +-- That is the purpose of this function. You provide an initial integer value (like 24) and this +-- value will be logarithmically scaled based on the 'currentDepth' value. The scaling equation is: +-- > \x -> 'Prelude.floor' (x / 2^'depthLimit') +-- So if you provide a value of 24 to this function, the value returned will be: +-- > 'Prelude.floor' (24 / 2^'depthLimit') +-- And if the 'depthLimit' is 4 then @'Prelude.floor' (2 / 2^4) == 'Prelude.floor' (2/16) == 1@. So +-- for passing a value of 24 means the maximum number of nodes will be @24*12*6*3*1 == 5184@ nodes, +-- which is large, but considerably smaller than 160000 nodes. +depthLimitedInt :: Int -> RandO Int +depthLimitedInt x = getCurrentDepth >>= \d -> return (div x (2^d)) + +getCurrentDepth :: Monad m => RandT m Int +getCurrentDepth = RandT $ gets currentDepth + +randListOf :: Int -> Int -> RandO a -> RandO [a] +randListOf minlen maxlen rando = do + -- half of all lists will be null, unless the 'minlen' parameter is greater than 0 + minlen <- return (min minlen maxlen) + maxlen <- return (max minlen maxlen) + empt <- if minlen==0 then nextInt 2 else return 0 + if empt==1 + then return [] + else do + ln <- nextInt (maxlen-minlen) + replicateM (minlen+ln) rando + +randList :: HasRandGen a => Int -> Int -> RandO [a] +randList lo hi = randListOf lo hi randO + +defaultList :: HasRandGen a => Int -> Int -> RandO [a] +defaultList lo hi = randListOf lo hi defaultO + +randRational :: Int -> RandO Rational +randRational i0 = do + let (i1, len1) = divMod i0 4 + (_ , len2) = divMod i1 4 + a <- fmap longFromInts (replicateM (len1+1) randInt) + b <- fmap longFromInts (replicateM (len2+1) randInt) + return (a%b) + +getRandomWord :: Int -> B.ByteString +getRandomWord i = randomWords ! (mod i (rangeSize (bounds randomWords) - 1)) + +randomWords :: Array Int B.ByteString +randomWords = listArray (0, length list - 1) (map B.pack list) where + list = words $ unwords $ + [ "a academia accomplished added also an analysis and application applications apply are arent slim" + , "argument arguments as at avoids be because been behavior between book both by calculus plus were" + , "calling can change changes code commercial computability computation computer concepts earth was" + , "constructs contrast conversely declarative definition depending depends describing metal key fee" + , "designed developed development difference different domains domain easier effects fire water add" + , "elaborations elements eliminating emphasize entscheidungsproblem eschewing star best least being" + , "especially evaluation example executing expression facilitate financial formal greatest open etc" + , "functional has have hope how however imperative industrial input investigate is home close where" + , "it key lack lambda language languages largely like make many math mathematical may from flow she" + , "motivations much mutable notion numeric of on one ones only organizations output paradigm pit he" + , "specific pioneering practice predict produce program programming prominent purely rather trust I" + , "recursion referential result roots same science side so software some specifically state move me" + , "statistics style subject such supported symbolic system than that the they child this super mesh" + , "transparency treats twice understand use used value values variety viewed which wide will bill X" + , "dates times database structured listing setting dictionary returning throwing catching law factor" + , "option procedure alpha beta electron proton neutron shift hard soft bean beam fix drug undo minus" + , "field magic latice jump assemble area volume interesting slice sector region cylinder sphere plan" + , "inside without trying patterned rules" + ] + diff --git a/src/Dao/RefTable.hs b/src/Dao/RefTable.hs new file mode 100644 --- /dev/null +++ b/src/Dao/RefTable.hs @@ -0,0 +1,75 @@ +-- "src/Dao/RefTable.hs" a data type which maps opaque reference +-- handles to 'Dynamic' objects. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +-- | This module is used to implement a kind of un-typed global state for the Dao runtime which can +-- store object of arbitrary type in a place that can be accessed anywhere. It is used for data +-- types like file handles which have their own unique identifiers and you don't need Dao to assign +-- it a new unique ID to it them for you, you can just index it by a hash of the the unique ID. +-- +-- Every value stored in a table gets it's own MVar, so updating the value is thread safe, but it is +-- a bit memory intensive. So a 'RefTable' should only be used for things that really need to be +-- well protected, like UNIX file descriptors or sockets, ordinary file handles, credentials, +-- handles to access databases -- anything that needs to be allocated and released in order for it +-- to be used during runtime. +module Dao.RefTable + ( RefMonad, + RefNode, refNodeDestructor, refNodeValue, refTableNode, + RefTable, newRefTable, initializeWithKey, destroyWithKey + ) + where + +import qualified Dao.HashMap as H + +import Control.Applicative +import Control.Concurrent.MVar +import Control.Monad.Reader + +---------------------------------------------------------------------------------------------------- + +type RefMonad key val a = ReaderT (RefTable key val) IO a + +data RefNode a = RefNode{ refNodeDestructor :: IO (), refNodeValue :: MVar a } + +refTableNode :: (a -> IO ()) -> a -> IO (RefNode a) +refTableNode destructor a = newMVar a >>= \mvar -> + return $ RefNode{ refNodeDestructor=destructor a, refNodeValue=mvar } + +newtype RefTable key a = RefTable { refTableMVar :: MVar (H.HashMap key (RefNode a)) } + +newRefTable :: IO (RefTable key a) +newRefTable = RefTable <$> newMVar H.empty + +initializeWithKey :: Ord key => a -> IO () -> H.Index key -> RefMonad key a (MVar a) +initializeWithKey o destructor key = do + mvar <- H.hashLookup key <$> (asks refTableMVar >>= liftIO . readMVar) + case mvar of + Just node -> return (refNodeValue node) + Nothing -> do + mvar <- liftIO $ newMVar o + asks refTableMVar >>= + liftIO . flip modifyMVar (\hmap -> return (H.hashInsert key (RefNode destructor mvar) hmap, mvar)) + +destroyWithKey :: Ord key => H.Index key -> RefMonad key a () +destroyWithKey key = do + mvar <- H.hashLookup key <$> (asks refTableMVar >>= liftIO . readMVar) + case mvar of + Nothing -> return () + Just _ -> asks refTableMVar >>= liftIO . flip modifyMVar_ (return . H.hashDelete key) + diff --git a/src/Dao/Stack.hs b/src/Dao/Stack.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Stack.hs @@ -0,0 +1,88 @@ +-- "src/Dao/Stack.hs" provides the stack mechanism used for storing +-- local variables during evaluation. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +module Dao.Stack where + +import qualified Data.Map as M + +import Control.Monad +import Control.Monad.Identity + +newtype Stack key val = Stack { mapList :: [M.Map key val] } deriving Show + +emptyStack :: Stack key val +emptyStack = Stack [] + +stackLookup :: Ord key => key -> Stack key val -> Maybe val +stackLookup key stack = foldl (\f -> mplus f . (M.lookup key)) Nothing (mapList stack) + +-- | Always update in the top of the stack, regardless of whether the key being updated has been +-- defined at some lower level in the stack. If the stack is empty, the update function is evaluated +-- with 'Prelude.Nothing' and the result @a@ is returned, but the updated @val@ is disgarded. +stackUpdateTopM + :: (Monad m, Ord key) + => (Maybe val -> m (a, Maybe val)) -> key -> Stack key val -> m (a, Stack key val) +stackUpdateTopM updVal key (Stack stack) = case stack of + [] -> updVal Nothing >>= \ (a, _) -> return (a, Stack []) + s:stack -> updVal (M.lookup key s) >>= \ (a, o) -> return (a, Stack $ M.alter (const o) key s : stack) + +-- | If the key does not exist, the update will occur in the top level of the stack. If the key does +-- exist, regardless of whether the key exists in the top or in some lower level, the value at that +-- key will be updated in the level in which it is defined. If the stack is empty, the update +-- function is evaluated with 'Prelude.Nothing' and the result @a@ is returned, but the updated +-- @val@ is disgarded. +stackUpdateM + :: (Monad m, Ord key) + => (Maybe val -> m (a, Maybe val)) -> key -> Stack key val -> m (a, Stack key val) +stackUpdateM updVal key (Stack stack) = loop [] stack where + loop rx stack = case stack of + [] -> atTop (reverse rx) + s:stack -> case M.lookup key s of + Just o -> updVal (Just o) >>= \ (a, o) -> + return (a, Stack $ reverse rx ++ M.alter (const o) key s : stack) + Nothing -> loop (s:rx) stack + atTop stack = case stack of + [] -> updVal Nothing >>= \ (a, _) -> return (a, Stack []) + s:stack -> updVal Nothing >>= \ (a, o) -> return (a, Stack $ M.alter (const o) key s : stack) + +stackUpdate + :: Ord key + => (Maybe val -> (a, Maybe val)) + -> key -> Stack key val -> (a, Stack key val) +stackUpdate upd key = runIdentity . stackUpdateM (return . upd) key + +stackUpdateTop + :: Ord key + => (Maybe val -> (a, Maybe val)) + -> key -> Stack key val -> (a, Stack key val) +stackUpdateTop upd key = runIdentity . stackUpdateTopM (return . upd) key + +-- | Define or undefine a value at an address on the top tree in the stack. +stackDefine :: Ord key => key -> Maybe val -> Stack key val -> Stack key val +stackDefine key val = snd . stackUpdate (const ((), val)) key + +stackPush :: Ord key => M.Map key val -> Stack key val -> Stack key val +stackPush init stack = stack{ mapList = init : mapList stack } + +stackPop :: Ord key => Stack key val -> (Stack key val, M.Map key val) +stackPop stack = + let mx = mapList stack + in if null mx then (stack, M.empty) else (stack{mapList=tail mx}, head mx) + diff --git a/src/Dao/StepList.hs b/src/Dao/StepList.hs new file mode 100644 --- /dev/null +++ b/src/Dao/StepList.hs @@ -0,0 +1,414 @@ +-- "src/Dao/StepList.hs" provides a fundamental data type used in the +-- Dao System, the "StepList", which is a cursor that can step forward +-- or backward through a list. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | This is a line-editor object, but it works with arbitrary lists of objects, but this will work +-- for editing arbitrary lists. You could use it to create an ordinary line editor by representing a +-- file as be a list of strings representing a file. each string could further be converted to a +-- StepList containing characters to edit the line. +-- +-- This module provides a basic list cursor interface, that is, a list that you can step through +-- forward or backward, item by item. This is useful for building line editors. This module export +-- operators, so it is best not to import this module qualified. Therefore functions similar to +-- 'Data.Set.empty' or 'Data.Set.singleton' are named 'slEmpty' and 'slSingleton' to prevent name +-- conflicts without using qualified importing. +-- +module Dao.StepList where + +import Control.Applicative +import Control.Monad + +import Data.Array.IArray +import qualified Data.IntMap as I +import Data.List +import Data.Monoid +import Data.Typeable + +---------------------------------------------------------------------------------------------------- + +data StepList a + = StepList + { slCursor :: Int + , slLength :: Int + , slLeftOfCursor :: [a] + -- ^ items to the left of the cursor are stored in reverse order. If your 'StepList' is: + -- > list_A = [0, 1, 2, 3, 4] <> [5, 6, 7, 8] + -- evaluating @'leftOfCursor' list_A@ produces: + -- > [4, 3, 2, 1, 0] + , slRightOfCursor :: [a] + -- ^ items to the left of the cursor are stored in forward order. If your 'StepList' is: + -- > list_A = [0, 1, 2, 3, 4] <> [5, 6, 7, 8] + -- evaluating @'leftOfCursor' list_A@ produces: + -- > [5, 6, 7, 8] + } + deriving (Eq, Ord, Show, Read, Typeable) + +instance Monoid (StepList a) where { mempty = slEmpty; mappend = (+:+); } +instance Functor StepList where { fmap = slMap } +instance MonadPlus StepList where { mzero = mempty; mplus = (+:+); } +instance Applicative StepList where { pure = return; (<*>) = ap; } +instance Alternative StepList where { empty = mempty; (<|>) = (+:+); } +instance Monad StepList where + -- | Return is defined by 'slSingletonL'. This is because when lists are used as a monad, the + -- 'Control.Monad.return' operations that occur earlier in the computation place items in the list + -- earlier than 'Control.Monad.return' operations that occur later in the computation. Therefore a + -- monadic computation like @a >> b@ will have @a@ placed to the left of @b@. + return = slSingletonL + -- | Just like how the '(Prelude.>>=)' operator instantiated for Haskell lists is the + -- 'Prelude.concatMap' function, the '(Prelude.>>=)' operator for 'StepList's is the 'slConcatMap' + -- function. + (>>=) = flip slConcatMap + +-- | Test if the 'StepList' contains no elements. +slNull :: StepList a -> Bool +slNull sl = null (slLeftOfCursor sl) && null (slRightOfCursor sl) + +-- | Create an empty 'StepList'. +slEmpty :: StepList a +slEmpty = StepList 0 0 [] [] + +-- | Create a 'StepList' with a single item to the right of the cursor. +slSingletonR :: a -> StepList a +slSingletonR a = StepList 1 1 [a] [] + +-- | Create a 'StepList' with a single item to the left of the cursor. +slSingletonL :: a -> StepList a +slSingletonL a = StepList 1 1 [a] [] + +-- | Create a 'StepList' from a list of elements and an initial cursor position. The cursor position +-- can be out of range, it will be placed at the end by default. +slFromList :: Int -> [a] -> StepList a +slFromList i lst = + let len = length lst + cur = max 0 i + (left, right) = splitAt cur lst + in StepList + { slCursor = min cur len + , slLength = len + , slLeftOfCursor = left + , slRightOfCursor = right + } + +-- | Create a 'StepList' with two lists, the items to the left of the cursor, and the items to the +-- right of the cursor. The elements of the list to the left of the cursor are not reversed when +-- constructing the 'StepList' with this constructor. When the cursor is moved back to the +-- beginning of the list, the items will be reversed, i.e. +-- > slToList (slFromList [0,1,2,3] [4,5,6,7]) +-- will evaluate to the list: +-- > [3,2,1,0,4,5,6,7] +slFromLeftRight :: [a] -> [a] -> StepList a +slFromLeftRight left right = + StepList{ slCursor=cur, slLength=cur+rightlen, slLeftOfCursor=left, slRightOfCursor=right } where + cur = length left + rightlen = length right + +-- | Assign values to integer indicies in the 'Data.IntMap.IntMap' data type, and this function will +-- convert the 'Data.IntMap.IntMap' to a 'StepList'. Negative indicies will be placed to the left of +-- the cursor, with the lowest value being furthest left, positive indicies will be placed to the +-- right of the cursor with the highest value being furthest right. +slFromIntMap :: I.IntMap a -> StepList a +slFromIntMap im = slFromLeftRight (fmap snd $ sortfst left) (fmap snd $ sortfst right) where + sortfst = sortBy (\a b -> compare (fst a) (fst b)) + (left, right) = partition ((<0) . fst) $ I.assocs im + +slToArray :: StepList a -> Maybe (Array Int a) +slToArray (StepList cur len left right) = + if len==0 + then Nothing + else Just $ array (negate cur, len-cur-1) + (zip (iterate (subtract 1) (negate 1)) left ++ zip (iterate (+1) 0) right) + +-- | Creates an array storing the list where the indicies are 'Data.Array.IArray.bounds' such that +-- value at index zero is the value returned by 'slHeadR', items before the cursor have negative +-- indicies, and items after the cursor are zero or positive. If the cursor is at the right-most +-- position of the list, the resulting array, every item is assigned to a negative index. +slFromArray :: Maybe (Array Int a) -> StepList a +slFromArray arr = case arr of + Nothing -> mempty + Just arr -> + let bnds = bounds arr + (lo, hi) = maybe bnds id $ do + (lo, hi) <- return bnds + (lo, hi) <- return (min lo hi, max lo hi) + return $ if lo>0 then (0, hi-lo) else (lo, hi) + len = hi - lo + 1 + cur = negate lo + left = map (arr!) (takeWhile (>=lo) $ iterate (subtract 1) (negate 1)) + right = map (arr!) (takeWhile (<=hi) $ iterate (+1) 0) + in StepList cur len left right + +-- | Convert the 'StepList' to an ordinary Haskell list. +slToList :: StepList a -> [a] +slToList (StepList _ _ left right) = reverse left ++ right + +-- | When two 'StepList's are concatenated with @a +:+ b@ think of @b@ being inserted into the cursor +-- position at @a@, with all the items to the left of the cursor in @b@ being placed to the right of +-- the cursor of @a@ and all the items to the right of the cursor of @b@ being placed to the left +-- the cursor of @a@. Here is an ASCII illustration: +-- > list_A = [a0, a1, a2, a3, a4] <> [a5, a6, a7, a8] +-- > list_B = [b0, b1] <> [b2, b3, b4, b5, b6, b7, b8] +-- > ----- concatenate ----- +-- > list_A<>list_B = [a0, a1, a2, a3, a4, b0, b1] <> [b2, b3, b4, b5, b6, b7, b8, a5, a6, a7, a8] +(+:+) :: StepList a -> StepList a -> StepList a +(StepList c1 n1 b1 a1) +:+ (StepList c2 n2 b2 a2) = StepList (c1+c2) (n1+n2) (b1++b2) (a2++a1) +infixr 5 +:+ + +slMap :: (a -> b) -> StepList a -> StepList b +slMap f (StepList cur len left right) = StepList cur len (map f left) (map f right) + +slConcat :: [StepList a] -> StepList a +slConcat = foldl (+:+) slEmpty + +-- | The @(Control.Monad.>>=)@ operator applied to lists is the same as the 'Data.List.concatMap' +-- function. In the case of 'StepList', the @(Control.Monad.>>=)@ operator is defined with +-- 'Data.Monoid.mconcat' and 'Prelude.map'. +slConcatMap :: (a -> StepList b) -> StepList a -> StepList b +slConcatMap f = slConcat . map f . slToList + +-- | Place an item to the left of the cursor. This operator binds to the RIGHT with a precedence of +-- 5, it does not bind left. The reason is that this operator is more similar to the Haskell list +-- operator @(:)@. +-- > x <: ([0, 1, 2] <> [3, 4]) +-- > ([0, 1, 2, x] <> [3, 4]) +(<|) :: a -> (StepList a -> StepList a) +(<|) a (StepList cur len left right) = StepList (cur+1) (len+1) (a:left) right +infixr 5 <| + +-- | Place an item to the right of the cursor. This operator binds to the right with a precedence of +-- 5, just like the Haskell list operator @(:)@. +-- > x :> ([0, 1, 2] <> [3, 4]) +-- > ([0, 1, 2] <> [x, 3, 4]) +(|>) :: a -> StepList a -> StepList a +(|>) a (StepList cur len left right) = StepList cur (len+1) left (a:right) +infixr 5 |> + +-- | Place an item to the left of the cursor. This operator binds to the RIGHT with a precedence of +-- 5, it does not bind left. The reason is that this operator is more similar to the Haskell list +-- operator @(++)@. +-- > [a0, a1, a2] <++ ([b0, b1, b2] <> [b3, b4]) +-- > ([b0, ab, b2, a0, a1, a2] <> [b3, b4]) +(<++) :: [a] -> StepList a -> StepList a +(<++) ox sl = let len = length ox in + sl{ slLeftOfCursor = slLeftOfCursor sl ++ reverse ox + , slCursor = slCursor sl + len + , slLength = slLength sl + len + } +infixr 5 <++ + +-- | Place an item to the right of the cursor. This operator binds to the right with a precedence of +-- 5, just like the Haskell list operator @(++)@. +-- > [a0, a1, a2] ++> ([b0, b1, b2] <> [b3, b4]) +-- > ([b0, b1, b2] <> [a0, a1, a2, b3, b4]) +(++>) :: [a] -> StepList a -> StepList a +(++>) ox sl = let len = length ox in + sl{ slRightOfCursor = ox ++ slRightOfCursor sl + , slLength = slLength sl + len + } +infixr 5 ++> + +-- | Returns 'Prelude.True' if it is possible to move the cursor left or right by @n@ steps. +slShiftCheck :: Int -> StepList a -> Bool +slShiftCheck delta (StepList cur len _ _) = inRange (0, len) (cur+delta) + +-- | Returns 'Prelude.True' if it the index is within the bounds of the list. +slIndexCheck :: Int -> StepList a -> Bool +slIndexCheck i (StepList _ len _ _) = inRange (0, len) i + +-- | Shift the cursor @delta@ elements to the left if @delta@ is negative, or @delta@ elements to +-- the right if @delta@ is positive. +slCursorShift :: Int -> StepList a -> StepList a +slCursorShift delta0 a@(StepList cur len left right) + | delta0==0 = a + | delta0< 0 = + let delta = max delta0 (negate cur) + (middle, left') = splitAt (abs delta) left + in StepList (cur+delta) len left' (reverse middle ++ right) + | delta0> 0 = + let delta = min delta0 (len-cur) + (middle, right') = splitAt delta right + in StepList (cur+delta) len (reverse middle ++ left) right' + | otherwise = error "case statement of Dao.StepList.slCursorShift" + +-- | Place the cursor at an index position. +slCursorTo :: Int -> StepList a -> StepList a +slCursorTo i a@(StepList cur _ _ _) = slCursorShift (i-cur) a + +-- | Lookup a value at an absolute index (not relative to the cursor). +slIndex :: Int -> StepList a -> Maybe a +slIndex i sl = + let (StepList _ _ _ right) = slCursorShift i sl + in case right of { [] -> Nothing; o:_ -> return o; } + +-- | A bounds value expressed as a pair of indicies relative to the current cursor position can be +-- converted to an bounds value expressed as a pair of indicies relative to the 0th element in the +-- 'StepList'. This is the inverse operation of 'slAbsToRel'. +slRelToAbs :: StepList a -> (Int, Int) -> (Int, Int) +slRelToAbs (StepList cur _ _ _) (lo, hi) = (cur+lo, cur+hi) + +-- | A bounds value expressed as a pair of indicies relative to the 0th position in the 'StepList' +-- can be converted to a bounds value expressed as a pair of indicies relative to the current +-- cursor position. This is the inverse operation of 'slRelToAbs'. +slAbsToRel :: StepList a -> (Int, Int) -> (Int, Int) +slAbsToRel (StepList cur _ _ _) (lo, hi) = (lo-cur, hi-cur) + +-- | Selects items around the cursor, with the option of deleting the items selected from the +-- 'StepList'. The first boolean parameter indicates whether or not the list should be altered by +-- deleting the items that were selected. Items to the left of the cursor are selected if the +-- indicies are negative and items to the right of the cursor are selected if the indicies are +-- positive. Specify the range to select by passing a lower and upper bound relative to the cursor. +-- For example, to select a range of ten items, five before the cursor and five after the cursor, +-- use @slGetRelRange False (negate 5) 5@. To delete that same range from the 'StepList' and also +-- return it use @slGetRelRange True (negate 5) 5@. +-- +-- This function evaluates to a pair of 'StepList's. The 'Prelude.fst' is the selected items, the +-- 'Prelude.snd' is the modified 'StepList' which may be identical to the parameter 'StepList' if +-- the 'doDelete::Bool' parameter is 'Prelude.False'. +slCutRelRange :: Bool -> (Int, Int) -> StepList a -> (StepList a, StepList a) +slCutRelRange doDelete (lo, hi) o@(StepList cur len left right) = maybe (mempty, o) id $ do + let cutBiased minLen list = do + let lim = Just . min minLen . abs + lo <- lim $ min lo hi + hi <- lim $ max lo hi + let cutLen = hi-lo + guard (cutLen/=0) + (keep, list) <- Just $ splitAt lo list + (cut , list) <- Just $ splitAt cutLen list + return (cutLen, keep, cut, list) + case lo of + lo|lo<0 -> case hi of + hi|hi<=0 -> do + (cutLen, keep, cut, left) <- cutBiased cur left + cut <- Just $ StepList cutLen cutLen cut [] + Just $ + if doDelete + then (cut, StepList (max 0 (cur-cutLen)) (len-cutLen) (left++keep) right) + else (cut, o) + hi|hi>0 -> do + lo <- Just $ min cur (abs lo) + hi <- Just $ min (len-cur) hi + let cutLen = hi+lo + (midLeft, left ) <- Just $ splitAt lo left + (midRight, right) <- Just $ splitAt hi right + middle <- Just $ StepList lo cutLen midLeft midRight + Just $ + if doDelete + then (middle, StepList (max 0 (cur-cutLen)) (len-cutLen) left right) + else (middle, o) + _ -> undefined + lo|lo>=0 -> case hi of + hi|hi<=0 -> if lo==hi then Nothing else Just $ slCutRelRange doDelete (hi, lo) o + hi|hi>0 -> do + (cutLen, keep, cut, right) <- cutBiased (len-cur) right + cut <- Just $ StepList 0 cutLen [] cut + Just $ + if doDelete + then (cut, StepList cur (max cur (len-cutLen)) left (keep++right)) + else (cut, o) + _ -> undefined + _ -> undefined + +-- | Like 'slCutRelRange' but operates on an upper and lower bound indicated by absolute indicies, +-- rather than indicies relative to the cursor. +slCutAbsRange :: Bool -> (Int, Int) -> StepList a -> (StepList a, StepList a) +slCutAbsRange doDelete bnds list = slCutRelRange doDelete (slAbsToRel list bnds) list + +slDeleteRelRange :: (Int, Int) -> StepList a -> StepList a +slDeleteRelRange bnds = snd . slCutAbsRange True bnds + +slDeleteAbsRange :: (Int, Int) -> StepList a -> StepList a +slDeleteAbsRange bnds list = slDeleteRelRange (slAbsToRel list bnds) list + +slCopyRelRange :: (Int, Int) -> StepList a -> StepList a +slCopyRelRange bnds = fst . slCutRelRange False bnds + +slCopyAbsRange :: (Int, Int) -> StepList a -> StepList a +slCopyAbsRange bnds list = slCopyRelRange (slAbsToRel list bnds) list + +-- | Many functions may need to modify a 'StepList' but only on the elements to the left or right of +-- the cursor. These functions take a boolean type called 'Bias' +data Bias = ToLeft | ToRight deriving (Eq, Ord, Bounded, Enum, Ix, Show, Read) + +-- | Modify the items to the left or right of the cursor. The function will return a polymorphic +-- value paired with an updated list of items to the left of the cursor. +biasedApply :: Bias -> ([elems] -> (result, [elems])) -> StepList elems -> (result, StepList elems) +biasedApply bias f (StepList cur len left right) = case bias of + ToRight -> let (result, right') = f right in (result, StepList cur (length right') left right') + ToLeft -> + let (result, left') = f left + newlen = length left' + in (result, StepList newlen (len-cur+newlen) left' right) + +-- | Evaluates to true if the cursor is beyond the left or right-most position in the list. +slAtEnd :: Bias -> StepList a -> Bool +slAtEnd bias (StepList cur len _ _) = case bias of + ToRight -> cur==len + ToLeft -> cur==0 + +-- | Move the cursor to the right-most or left-most end of the 'StepList', depending on the 'Bias' +-- value given. The word Return has nothing to do with monad, we use this term because this function +-- is similar to the /carriage return/ of a typewriter. +slReturn :: Bias -> StepList a -> StepList a +slReturn bias (StepList cur len left right) = case bias of + ToLeft -> StepList 0 (cur+len) [] (reverse left ++ right) + ToRight -> StepList len len (left ++ reverse right) [] + +slHeadR :: StepList a -> a +slHeadR (StepList _ _ _ a) = head a + +slHeadL :: StepList a -> a +slHeadL (StepList _ _ a _) = head a + +slTail :: Bias -> StepList elems -> StepList elems +slTail bias = snd . biasedApply bias ((,) () . tail) + +slTake :: Bias -> Int -> StepList a -> StepList a +slTake bias n = snd . biasedApply bias ((,) () . take n) + +slTakeWhile :: Bias -> (a -> Bool) -> StepList a -> StepList a +slTakeWhile bias p = snd . biasedApply bias ((,) () . takeWhile p) + +slDrop :: Bias -> Int -> StepList a -> StepList a +slDrop bias n = snd . biasedApply bias ((,) () . drop n) + +slDropWhile :: Bias -> (a -> Bool) -> StepList a -> StepList a +slDropWhile bias p = snd . biasedApply bias ((,) () . dropWhile p) + +slSplitAt :: Bias -> Int -> StepList a -> ([a], StepList a) +slSplitAt bias n = biasedApply bias (splitAt n) + +slSpan :: Bias -> (a -> Bool) -> StepList a -> ([a], StepList a) +slSpan bias p = biasedApply bias (span p) + +slBreak :: Bias -> (a -> Bool) -> StepList a -> ([a], StepList a) +slBreak bias p = biasedApply bias (break p) + +-- | Apply a modifier to the whole list, try to keep the cursor in the same place. If the 'StepList' +-- shrinks below where the cursor was, the cursor is placed at the end of the 'StepList'. +slMapAll :: ([a] -> [b]) -> StepList a -> StepList b +slMapAll fn (StepList cur _ left right) = + let (left', right') = splitAt cur (fn $ reverse left ++ right) + newlen = length left' + length right' + in StepList (min cur newlen) newlen (reverse left') right' + diff --git a/src/Dao/String.hs b/src/Dao/String.hs new file mode 100644 --- /dev/null +++ b/src/Dao/String.hs @@ -0,0 +1,521 @@ +-- "src/Dao/String.hs" provides the fundamental string data type +-- called "UStr" which is used throughout the Dao System. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | This module has two purposes. Firstly, this module depends on no other module in the Dao +-- program, so it may be imported by any other module, and as such it provides the classes and +-- functions that must be available to every module. Most of these essential functions are related +-- to strings, which is why this module is named so. +-- +-- Therefore secondly, this module provides the /universal string/ data type 'UStr', and a type +-- class 'UStrType' that allows you to declare arbitrary data types to be convertible to and from +-- universal strings. Universal strings are built upon the "Data.ByteString.Lazy.UTF8" module in +-- the @utf8-string@ package of the Haskell platform. All strings used in the Dao runtime are stored +-- as this data type. +-- +-- /NOTE:/ though this module is absolutely essential to every other module in the Dao system, not +-- all data structures should need to instantiate 'UStrType'. By contrst, the +-- 'Dao.Interpreter.Structured' (not defined in this module) should be instantiated by nearly all +-- data structures, especially if it is necessary to manipulate these structures within the Dao +-- programming language. +-- +-- Dao is a high-level language, like a macro language or a scripting language. One thing +-- scripting/meta languages all have in common is the use of strings as a way to store and transmit +-- data in a human-readable but structured format; strings are often the universal intermediate code +-- of the runtime environment. Data structures can be converted to a string, stored in memory, +-- transmitted over a socket or pipe, saved to disk. Data from the disk, the socket, or in memory +-- can be parsed to reconstruct the data structures. +-- +-- However it is my opinion that use of strings as intermediate data structures is very poor design +-- in any programming language; it is an anti-pattern. I believe the universal data type should the +-- tree rather than the string. Therefore I have provided the "Dao.Tree" and "Dao.Struct" modules, +-- and the 'Dao.Interpreter.Structured' type class which expand on the ideas of 'Prelude.Show' and +-- 'Prelude.Read' by using a 'Dao.Tree.Tree' as the intermediate data structure, rather than a +-- 'Dao.String.UStr'. +module Dao.String where + +import Control.Monad +import Control.Monad.State +import Control.DeepSeq +import Control.Exception (assert) + +import Data.String +import Data.Monoid +import Data.Typeable +import qualified Data.Binary as B +import Data.Bits +import Data.Char +import Data.List (partition, stripPrefix) +import Data.Word +import Data.Array.Unboxed +import qualified Data.ByteString.Lazy.UTF8 as U +import qualified Data.ByteString.Lazy as B +import qualified Codec.Binary.UTF8.String as UTF8 + +import Numeric + +-- Necessary for the HasNullValue instances +import Data.Int +import Data.Ratio +import Data.Complex +import Data.Time.Clock +import qualified Data.IntMap as IM +import qualified Data.Map as M +import qualified Data.Set as S + +-- | Objects which can be used as a predicate testing whether or not the object is null, or of a +-- default value, should instantiate this class. +class HasNullValue a where { nullValue :: a; testNull :: a -> Bool; } +instance HasNullValue () where { nullValue = (); testNull () = True; } +instance HasNullValue UStr where { nullValue = mempty; testNull = (==mempty); } +instance HasNullValue [a] where { nullValue = []; testNull = null; } +instance HasNullValue Char where { nullValue = '\0'; testNull = (==nullValue); } +instance HasNullValue Int where { nullValue = 0; testNull = (==nullValue); } +instance HasNullValue Int64 where { nullValue = 0; testNull = (==nullValue); } +instance HasNullValue Word where { nullValue = 0; testNull = (==nullValue); } +instance HasNullValue Word64 where { nullValue = 0; testNull = (==nullValue); } +instance HasNullValue Double where { nullValue = 0; testNull = (==nullValue); } +instance HasNullValue Integer where { nullValue = 0; testNull = (==nullValue); } +instance HasNullValue (Ratio Integer) where { nullValue = 0%1; testNull = (==nullValue); } +instance HasNullValue (Complex Double) where { nullValue = 0:+0; testNull = (==nullValue); } +instance HasNullValue NominalDiffTime where { nullValue = fromRational 0; testNull = (==nullValue); } +instance HasNullValue (IM.IntMap a) where { nullValue = IM.empty; testNull = IM.null } +instance HasNullValue (M.Map k a) where { nullValue = M.empty; testNull = M.null } +instance HasNullValue (S.Set a) where { nullValue = S.empty; testNull = S.null } +instance HasNullValue U.ByteString where { nullValue = mempty; testNull = (==mempty); } + +-- | This is the /universal string/ type. It is a @newtype@ wrapper around +-- 'Data.ByteString.Lazy.UTF8.ByteString', but has an API that is used throughout the Dao system. +-- There is serious consideration to replace this module with "Data.Text", but even if that happens, +-- this module will be kept to provide a stable API to the string package upon which it is built. +newtype UStr = UStr { toUTF8ByteString :: U.ByteString } deriving (Eq, Ord, Typeable) +instance Monoid UStr where { mempty = toUStr ""; mappend a b = toUStr (uchars a ++ uchars b); } + +-- | To provide intermediate string representations of data structures is one of the purposes of +-- 'Prelude.Show' and 'Prelude.Read' in the Haskell language. In Haskell, 'Prelude.Read' and +-- 'Prelude.Show' must, by convention, output a string that can be converted back to an exactly +-- equivalent data structure to the structure that produced the output when the output string is +-- parsed by 'Prelude.Read'. In other words @read (show a) == a && show (read a) == a@ should +-- evaluate to 'Prelude.True' for any type of @a@. +-- +-- This is not merely a convention for the 'UStrType', it is a requirement. The minimal complete +-- definition is 'toUStr' and one or both of 'fromUStr' and 'maybeFromUStr'. The 'nil' function is +-- part of the minimal complete definition, except when your data type is also an instance of +-- 'Data.Monoid.Monoid'. If your data type is also a 'Data.Monoid.Monoid', then the default instance +-- of 'nil' is 'Data.monoid.mempty'. +-- +-- Another big difference between 'UStrType' and 'Prelude.Show'/'Prelude.Read' is that 'UStrType' is +-- not intented to be used to construct parsers, it is used as an abstract interface to a parser. +-- 'Prelude.Read' provides 'Prelude.lex' for taking a lexeme from the head of the input, +-- 'Prelude.readParen' for parsing items from within parentheses, and 'readsPrec' which +-- parameterizes the current precedence value and allows you to backtrack if a lexeme has a lower +-- prescedence. All of this functionality (and more) is provided in the "Dao.Parser" +-- module, it is not provided here in the 'UStrType'. +-- +-- When instantiating this class, you will may find the 'uchars' and 'ustr' to be useful if parsing +-- strings is necessary. If you want to use 'Prelude.Show' to instantiate 'toUStr', you can simply +-- use 'derive_toUStr' and 'derive_fromUStr'. The 'uchars' function is used to convert any +-- 'UStrType' to a 'Prelude.String' by first converting the 'UStrType' to a 'UStr', and 'ustr' is +-- does the inverse, however 'UStr' also instantiates 'UStrType' /so the way to convert a 'UStr' to +-- a 'Prelude.String' is to use 'uchars', the way to convert a 'Prelude.String' to a 'UStr' is to +-- use 'ustr'/. +class UStrType a where + -- | Like 'Prelude.Show.show', converts your data type to a universal string. + toUStr :: a -> UStr + -- | Like 'Prelude.read', constructs your data type from a universal string. + fromUStr :: UStr -> a + fromUStr str = maybe (error ("cannot construct data from UStr "++show str)) id (maybeFromUStr str) + -- | Like 'Prelude.reads' except the entire string must be consumed, and the return type is a + -- 'Prelude.Maybe' instead of a list. The return type here is not similar to + -- 'Prelude.ReadS' which is a synonym for @'Prelude.String' -> [(a, 'Prelude.String')]@ a pair + -- containing the read object and the remainder. + maybeFromUStr :: UStr -> Maybe a + maybeFromUStr = Just . fromUStr + nil :: a + nil = fromUStr mempty +instance UStrType UStr where { toUStr = id; fromUStr = id; } +instance UStrType String where + toUStr = UStr . U.fromString + fromUStr = U.toString . toUTF8ByteString +instance UStrType U.ByteString where + toUStr = UStr + fromUStr = toUTF8ByteString + maybeFromUStr = Just . fromUStr + +-- | This function lets you use the instantiation of 'Prelude.Show' to instantiate 'toUStr', +-- typically used when your data type uses Haskell's @deriving@ keyword to derive 'Prelude.Show'. +-- Note that this function also requires you to instantiate 'Prelude.Read' (also, perhaps, by the +-- @deriving@ keyword), because although this function does not use any of the 'Prelude.Read' +-- functions, this requirement emphasizes the importance of 'UStr' being a data structure that is +-- used to store an intermediate representation of structured data. +derive_ustr :: (Enum a, Read a, Show a) => a -> UStr +derive_ustr = toUStr . show + +-- | This function lets you use the instantiation of 'Prelude.Read' to instantiate 'toUStr', +-- typically used when your data type uses Haskell's @deriving@ keyword to derive 'Prelude.Read'. +-- Note that this function also requires you to instantiate 'Prelude.Show' (also, perhaps, by the +-- @deriving@ keyword), because although this function does not use any of the 'Prelude.Show' +-- functions, this requirement emphasizes the importance of 'UStr' being a data structure that is +-- used to store an intermediate representation of structured data. +derive_fromUStr :: (Enum a, Read a, Show a) => UStr -> a +derive_fromUStr = read . uchars + +-- | This function lets you use the instantiation of 'Prelude.Read' to instantiate 'toUStr', +-- typically used when your data type uses Haskell's @deriving@ keyword to derive 'Prelude.Read'. +-- Note that this function also requires you to instantiate 'Prelude.Show' (also, perhaps, by the +-- @deriving@ keyword), because although this function does not use any of the 'Prelude.Show' +-- functions, this requirement emphasizes the importance of 'UStr' being a data structure that is +-- used to store an intermediate representation of structured data. +derive_maybeFromUStr :: (Enum a, Read a, Show a) => UStr -> Maybe a +derive_maybeFromUStr u = case reads (uchars u) of + [(a, "")] -> Just a + _ -> Nothing + +-- | Convert a 'Prelude.String' to an object classed as a 'UStrType' by first converting it to a +-- 'UStr' using 'toUStr'. /NOTE:/ this is the function you use to convert a 'Prelude.String' to a +-- 'UStr', and for the 'UStr' type, this function never fails (never evaluates to the "bottom" +-- value). +ustr :: UStrType str => String -> str +ustr = fromUStr . toUStr + +-- | Convert a 'Prelude.String' to an object classed as a 'UStrType' by first converting it to a +-- 'UStr' using 'toUStr', but uses 'maybeFromUStr' to convert from the 'UStrType' object. /NOTE:/ +-- this is the function you use to convert a 'Prelude.String' to a 'UStr' (this is possible because +-- 'UStr' instantiates 'UStrType'), and for the 'UStr' type, this function never evaluates to +-- 'Prelude.Nothing'. +maybeUStr :: UStrType str => String -> Maybe str +maybeUStr = maybeFromUStr . toUStr + +-- | Convert an object classed as a 'UStrType' to a 'Prelude.String'. /NOTE:/ this is the function +-- you should use to convert a 'UStr' to a 'Prelude.String' (this is possible because 'UStr' +-- instantiates 'UStrType'). +uchars :: UStrType str => str -> String +uchars = U.toString . toUTF8ByteString . toUStr + +-- | Convert an object classed as a 'UStrType' to a @['Data.Word.Word8']@ list. Since 'UStr's store +-- data as UTF-8 encoded strings, this function simply returns the UTF-8 formatted octet stream from +-- that the 'Data.ByteString.Lazy.UTF8.ByteString' data structure. Of course, unless your 'UStrType' +-- is simply a @newtype@ of 'UStr' a conversion to a 'UStr' is done behind the scenes, which will +-- transparently encode a UTF8 string. +utf8bytes :: UStrType str => str -> [Word8] +utf8bytes = UTF8.encode . uchars . toUStr + +-- | The inverse of 'utf8bytes', tries to decode a stream of octets into a properly formatted UTF-8 +-- 'Data.ByteString.Lazy.UTF8.ByteString'. If encoding fails, this function evaluates to +-- 'Prelude.error' (evaluates to the "bottom" value). +upack :: [Word8] -> UStr +upack ax = toUStr (UTF8.decode ax) + +-- | Modify a 'UStr' with the APIs provided in the "Data.ByteString.UTF8.Lazy" module. +fmapUTF8String :: (U.ByteString -> U.ByteString) -> UStr -> UStr +fmapUTF8String f = UStr . f . toUTF8ByteString + +-- | Split a longer string up by the shorter string, for example: +-- > splitString (ustr "--") (one-one -- two-two -----> three-three -- four-four") +-- will be split to +-- > ["one-one ", " two-two ", "", "-> three-three ", " four-four"] +splitString :: UStr -> UStr -> [UStr] +splitString a b = case compare la lb of + EQ -> return $ if a==b then nil else a + LT -> delstr a b + GT -> delstr b a + where + la = ulength a + lb = ulength b + len = min la lb + loop ox str i ax bx = + if i>0 + then case stripPrefix ax bx of + Nothing -> loop ox (head bx : str) (i-1) ax (tail bx) + Just bx -> loop (ustr (reverse str) : ox) "" (i-len) ax bx + else reverse $ ustr (reverse str ++ bx) : ox + delstr a b = loop [] "" (abs $ lb-la) (uchars a) (uchars b) + +---------------------------------------------------------------------------------------------------- + +-- | A Variable-Length Integer (VLI) encoder. The bits of a variable-length integer will have a +-- format like so: +-- > bit column number: 7 6543210 +-- > --------- +-- > 1st highest order byte: 1 XXXXXXX +-- > 2nd highest order byte: 1 XXXXXXX +-- > 3rd highest order byte: 1 XXXXXXX +-- > ... +-- > lowest order byte : 0 XXXXXXX +-- If the highest-order bit is a one, it indicates there are more bytes to follow. If the highest +-- order bit is 0, then there are no more bytes. The 7 lower-order bits will be concatenated in +-- /big-endian order/ to form the length value for the string. By this method, most all strings +-- will have a length prefix of only one or two bytes. +vlIntegralToWord8s :: (Integral a, Bits a) => a -> [Word8] +vlIntegralToWord8s = reverse . (\ (a:ax) -> (a .&. 0x7F) : ax) . + fix (\loop w -> let v = 0x80 .|. fromIntegral (w .&. 0x7F) + in case shiftR w 7 of{ 0 -> [v]; w -> v : loop w; }) + +-- | Inverse operation of 'bitsToVLI' +vlWord8sToIntegral :: (Integral a, Bits a) => [Word8] -> (a, [Word8]) +vlWord8sToIntegral = loop 0 where + fn a w = shiftL a 7 .|. fromIntegral (w .&. 0x7F) + loop a wx = case wx of + [] -> (a, []) + w:wx -> if w .&. 0x80 == 0 then (fn a w, wx) else loop (fn a w) wx + +-- | Since a negative number expressed in a 'Prelude.Integer' type translates to an infinite +-- sequence of 0xFF bytes when converting it to a VLI, it needs to be encoded specially with a +-- negation bit in the very first position. +vlIntegerToWord8s :: Integer -> [Word8] +vlIntegerToWord8s w = reverse $ (\ (b:bx) -> (if w<0 then b .|. 0x40 else b):bx) $ loop (abs w) where + loop w = fromInteger (w .&. 0x3F) : + fix (\loop w -> case w of + 0 -> [] + w -> (0x80 .|. fromInteger (w .&. 0x7F)) : loop (shiftR w 7) + ) (shiftR w 6) + +vlWord8sToInteger :: [Word8] -> (Integer, [Word8]) +vlWord8sToInteger = loop 0 where + fn s m a w = shiftL a s .|. fromIntegral (w .&. m) + loop a wx = case wx of + [] -> (a, []) + w:wx -> + if w .&. 0x80 == 0 + then ((if w .&. 0x40 == 0 then id else negate) $ fn 6 0x3F a w, wx) + else loop (fn 7 0x7F a w) wx + +-- | When reading from a binary file, gather the bits of a Variable-Length Integer. +vlGatherWord8s :: B.Get [Word8] +vlGatherWord8s = loop [] where + loop wx = B.getWord8 >>= \w -> if w .&. 0x80 == 0 then return (wx++[w]) else loop (wx++[w]) + +-- | Encode only positive 'Prelude.Integer's. This differs from 'vlPutInteger' in that the sign of +-- the integer is not stored in the byte stream, saving a single bit of space. This can actually +-- simplify some equations that expect an VLInteger to be encoded as a multiple-of-7 length string +-- of bits as you don't need to make additional rules for the final byte which would only have +-- 6-bits if the sign is stored with it. +vlPutPosInteger :: Integer -> B.Put +vlPutPosInteger i = assert (i>=0) $ mapM_ B.putWord8 $ vlIntegralToWord8s $ i + +-- | Decode only positive 'Prelude.Integer's. This differs from 'vlPutInteger' in that the sign of +-- the integer is not stored in the byte stream, saving a single bit of space. This can actually +-- simplify some equations that expect an VLInteger to be encoded as a multiple-of-7 length string +-- of bits as you don't need to make additional rules for the final byte which only have 6-bits if +-- the sign is stored with it. +vlGetPosInteger :: B.Get Integer +vlGetPosInteger = fmap (fst . vlWord8sToIntegral) vlGatherWord8s + +-- | Encode a positive or negative 'Prelude.Integer' using 'vlWord8sToInteger'. The sign of the integer +-- is stored in the final byte in the list of encoded bytes, so the final encoded byte only has 6 +-- bits of information, rather than 7 in the case of positive integers. +vlPutInteger :: Integer -> B.Put +vlPutInteger = mapM_ B.putWord8 . vlIntegerToWord8s + +-- | Decode a positive or negative 'Prelude.Integer' using 'vlWord8sToInteger'. The sign of the integer +-- is stored in the final byte in the list of encoded bytes, so the final encoded byte only has 6 +-- bits of information, rather than 7 in the case of positive integers. +vlGetInteger :: B.Get Integer +vlGetInteger = fmap (fst . vlWord8sToInteger) vlGatherWord8s + +-- | Return the length of the 'UStr'. +ulength :: UStr -> Int +ulength = U.length . toUTF8ByteString + +-- | Length of a list, but unlike 'Data.List.length', allows a polymorphic length type. +iLength :: Num len => [a] -> len +iLength = foldl (+) 0 . map (const 1) + +-- | Used to encode a 'UStr' data type without any prefix at all. The instantiation of 'UStr' into +-- the 'Data.Binary.Binary' class places a prefix before every 'UStr' as it is serialized, allowing +-- it to be used more safely in more complex data types. +encodeUStr :: UStr -> B.Put +encodeUStr u = mapM_ B.putWord8 $ + vlIntegralToWord8s (U.length (toUTF8ByteString u)) ++ (UTF8.encode (uchars u)) + +-- | Used to decode a 'UStr' data type without any prefix. The instantiation of 'UStr' into the +-- 'Data.Binary.Binary' class places a prefix before every 'UStr' as it is serialized, allowing it +-- to be used more safely in more complex data types. +decodeUStr :: B.Get UStr +decodeUStr = do + (strlen, undecoded) <- fmap vlWord8sToIntegral vlGatherWord8s + if null undecoded + then fmap (toUStr . (UTF8.decode)) (replicateM strlen B.getWord8) + else fail "binary data decoder failed on UStr" + +---------------------------------------------------------------------------------------------------- + +bytesBitArith :: (Word8 -> Word8 -> Word8) -> B.ByteString -> B.ByteString -> B.ByteString +bytesBitArith f a b = B.pack $ map (uncurry f) $ B.zip a b + +bytesShift :: B.ByteString -> Int64 -> B.ByteString +bytesShift str i = let (len, r) = fmap fromIntegral (divMod (abs i) 8) in case compare i 0 of + EQ -> str -- identity + LT -> mappend (B.replicate len 0) $ if r==0 then str else -- shift right + snd $ B.mapAccumL (\prev b -> (b, shiftR b r .|. rotateR ((2^r-1) .&. prev) r)) 0 str + GT -> -- shift left + (if r==0 then id else snd . B.mapAccumR (\prev b -> (b, shiftL b r .|. ((2^r-1) .&. prev))) 0 + ) (B.drop len str) + +bytesRotate :: B.ByteString -> Int64 -> B.ByteString +bytesRotate str i = + let { len = B.length str; (cur8, r) = fmap fromIntegral (divMod i (len*8)); cur = div cur8 8; } + in if r==0 then str else let { (a, b) = B.splitAt cur str; str = b<>a; } in + snd $ B.mapAccumL (\prev b -> (b, shiftL b r .|. ((2^r-1) .&. prev))) (B.last str) str + +bytesBit :: Int64 -> B.ByteString +bytesBit i = let (len, r) = fmap fromIntegral (divMod i 8) in + if r==0 then B.snoc (B.replicate len 0) 1 else B.snoc (B.replicate (len-1) 0) (bit r) + +bytesTestBit :: B.ByteString -> Int64 -> Bool +bytesTestBit str i = let (len, r) = fmap fromIntegral (divMod i 8) in testBit (B.index str len) r + +bytesBitSize :: B.ByteString -> Int64 +bytesBitSize = (8*) . B.length + +bytesPopCount :: B.ByteString -> Int64 +bytesPopCount = B.foldl (\count b -> count + fromIntegral (popCount b)) 0 + +---------------------------------------------------------------------------------------------------- + +instance IsString UStr where { fromString = ustr } +instance Read UStr where { readsPrec n str = map (\ (s, rem) -> (toUStr (s::String), rem)) $ readsPrec n str } +instance Show UStr where { show u = show (uchars u) } +instance B.Binary UStr where + put u = encodeUStr u + get = decodeUStr +instance NFData UStr where { rnf (UStr a) = deepseq a () } + +-- | A type synonym for 'UStr' used where a string is used as some kind of identifier. +newtype Name = Name { nameToUStr :: UStr } deriving (Eq, Ord, Typeable) +instance Monoid Name where { mempty = nil; mappend (Name a) (Name b) = Name (a<>b); } +instance Show Name where { show = show . nameToUStr } +instance UStrType Name where + toUStr = nameToUStr + maybeFromUStr nm = + let str = uchars nm + ck f c = c=='_' || f c + in case str of + c:cx | ck isAlpha c || and (fmap (ck isAlphaNum) cx) -> Just (Name nm) + _ -> Nothing + fromUStr str = maybe (error msg) id $ maybeFromUStr str where + msg = "'Dao.String.Name' object must be constructed from alpha-numeric and underscore characters only:\n" + ++ take 256 (uchars str) +instance IsString Name where { fromString = ustr } +instance B.Binary Name where + put (Name u) = encodeUStr u + get = decodeUStr >>= \u -> case maybeFromUStr u of + Just nm -> return nm + Nothing -> fail "binary data contains invalid 'Dao.String.Name' object" +instance NFData Name where { rnf (Name a) = deepseq a () } + +-- | A type synonym for 'UStr' used where a string is storing a file path or URL. +type UPath = UStr + +---------------------------------------------------------------------------------------------------- + +-- | Breaks a long list into a list of lists no longer than the specified length. +breakInto :: Int -> [a] -> [[a]] +breakInto i bx = if null bx then [] else let (grp, bx') = splitAt i bx in grp : breakInto i bx' + +-- | An array mapping 6-bit values to base-64 character symbols +base64Symbols :: UArray Word Char +base64Symbols = listArray (0,63) (['A'..'Z']++['a'..'z']++['0'..'9']++"+/") + +-- | Encoding arbitrary bytes in a 'Data.ByteString.Lazy.ByteString' to base-64 character symbols +-- according to RFC 3548. +b64Encode :: B.ByteString -> [[Char]] +b64Encode = breakInto 76 . concatMap enc . breakInto 3 . B.unpack where + windows = [(0xFC0000, 18), (0x03F000, 12), (0x000FC0, 6), (0x00003F, 0)] + enc [] = [] + enc bx = + let len = length bx + buf = foldl (\buf b -> shiftL buf 8 .|. fromIntegral b) 0 (take 3 (bx++replicate (3-len) 0)) + in take 4 $ (++"==") $ take (len+1) $ flip map windows $ \ (mask, shft) -> + base64Symbols ! shiftR (mask.&.buf) shft + +-- | An array mapping base-64 character symbols to their 6-bit values. +base64Values :: UArray Char Int +base64Values = array ('+', 'z') $ concat $ + [ zip ['+', 'z'] (repeat 0xAAAAAAA) -- 0xAAAAAAA is the undefined value + , zip ['A'..'Z'] [0..25] + , zip ['a'..'z'] [26..51] + , zip ['0'..'9'] [52..61] + , [('+', 62), ('/', 63), ('=', 0xFFFFFFF)] -- 0xFFFFFFF is the end-of-input value + ] + +-- | Decoding base-64 character symbols according to RFC 3548 into a string of bytes stored in a +-- 'Data.ByteString.Lazy.ByteString'. If decoding fails, the invalid character and it's position in +-- the input string are returned as a pair in a 'Data.Either.Left' value, otherwise the +-- 'Data.ByteString.Lazy.ByteString' is returned as the 'Data.Either.Right' value. +b64Decode :: [Char] -> Either (Char, Word64) B.ByteString +b64Decode = loop 0 [] . breakInto 4 . filter (flip notElem " \t\r\n\v\f\0") where + loop i bx cxx = case cxx of + [] -> Right (B.pack bx) + cx:cxx -> case sum 0 0 i cx of + Left (c, i) -> Left (c, i) + Right (i, bx') -> loop i (bx++bx') cxx + sum tk b i cx = case cx of + [] -> Right (i, take (3-tk) (splitup b)) + c:cx -> if inRange (bounds base64Values) c + then case base64Values!c of + 0xAAAAAAA -> Left (c, i) + 0xFFFFFFF -> sum (tk+1) (shiftL b 6) (i+1) cx + c -> sum tk (shiftL b 6 .|. c) (i+1) cx + else Left (c, i) + splitup b = map fromIntegral [shiftR (b.&.0xFF0000) 16, shiftR (b.&.0xFF00) 8, b.&.0xFF] + +newtype Base64String = Base64String B.ByteString deriving Typeable +instance Show Base64String where { show (Base64String s) = unlines (b64Encode s) } +instance Read Base64String where + readsPrec _ str = + case partition (\c -> isSpace c || (inRange (bounds base64Values) c && base64Values!c /= 0xAAAAAAA)) str of + ("" , _ ) -> [] + (str, rem) -> case b64Decode $ filter (not . isSpace) str of + Left (ch, pos) -> error ("invalid charcter "++show ch++" at index "++show pos++" in base64-encoded string") + Right u -> [(Base64String u, rem)] +newtype Base16String = Base16String B.ByteString deriving Typeable +instance Show Base16String where + show (Base16String u) = unlines $ fmap (unwords . fmap hex) $ breakInto 32 (B.unpack u) where + hex b = [arr ! (shiftR (b.&.0xF0) 4), arr ! (b.&.0x0F)] + arr :: Array Word8 Char + arr = array (0,15) (zip [0..15] "0123456789ABCDEF") + +showHex :: (Show i, Integral i) => i -> String +showHex = ("0x"++) . map toUpper . flip Numeric.showHex "" + +showOrdinal :: (Show n, Integral n) => n -> String +showOrdinal n = show n ++ case mod n 100 of + n | 11<=n||n<=13 -> "th" + n -> case mod n 10 of { 1 -> "st"; 2 -> "nd"; 3 -> "rd"; _ -> "th"; } + +---------------------------------------------------------------------------------------------------- + +-- | This is a simlpe string tokenizer for breaking up strings into tokens that can be easily used +-- in rules in Doa scripts. +simpleTokenizer :: String -> [String] +simpleTokenizer = fix $ \loop cx -> case cx of + "" -> [] + c:cx -> maybe ([c] : loop cx) (\ (cx, rem) -> cx : loop rem) $ + foldl (\f split -> mplus f (split (c:cx))) Nothing $ concat $ + [ fmap (\predicate (c:cx) -> guard (predicate c) >> Just (span predicate (c:cx))) $ + [isSpace, isNumber, isAlpha] + , [\ (c:cx) -> guard (elem c "([{<>}])") >> Just ([c], cx)] + , [\ (c:cx) -> Just $ span (==c) (c:cx)] + ] + diff --git a/src/Dao/Token.hs b/src/Dao/Token.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Token.hs @@ -0,0 +1,400 @@ +-- "src/Dao/Token.hs" Defines the 'Token' and 'Location' types +-- used by "src/Dao/Interpreter.hs" and "src/Dao/Parser.hs". +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +{-# LANGUAGE DeriveDataTypeable #-} + +module Dao.Token where + +import Dao.String +import Dao.PPrint + +import Data.Monoid +import Data.Word +import Data.List (intercalate) +import Data.Typeable +import Data.Data + +import Control.Monad +import Control.DeepSeq + +---------------------------------------------------------------------------------------------------- + +type LineNum = Word +type ColumnNum = Word +type TabWidth = Word + +-- | If an object contains a location, it can instantiate this class to allow locations to be +-- updated or deleted (deleted by converting it to 'LocationUnknown'. Only three types in this +-- module instantiate this class, but any data type that makes up an Abstract Syntax Tree, for +-- example 'Dao.Interpreter.ObjectExpr' or 'Dao.Interpreter.AST.ObjectExrpr' also instantiate this class. +class HasLocation a where + getLocation :: a -> Location + setLocation :: a -> Location -> a + delLocation :: a -> a + +instance HasLocation () where + { getLocation _ = LocationUnknown; setLocation a _ = a; delLocation a = a; } + +instance HasLocation UStr where + { getLocation _ = LocationUnknown; setLocation a _ = a; delLocation a = a; } + +instance HasLocation Name where + { getLocation _ = LocationUnknown; setLocation a _ = a; delLocation a = a; } + +instance HasLocation a => HasLocation (Maybe a) where + getLocation = maybe LocationUnknown getLocation + setLocation o loc = fmap (flip setLocation loc) o + delLocation o = fmap delLocation o + +-- | Contains two points, a starting and and ending point, where each point consists of a row (line +-- number) and column (character count from the beginning of a line) for locating entities in a +-- parsable text. This type does not contain information regarding the source of the text, or +-- whether or not the input text is a file or stream. +data Location + = LocationUnknown + | Location + { startingLine :: LineNum + -- ^ the 'Location' but without the starting/ending character count + , startingColumn :: ColumnNum + , endingLine :: LineNum + , endingColumn :: ColumnNum + } + deriving (Eq, Typeable, Data) + +instance HasLocation Location where + getLocation = id + setLocation = flip const + delLocation = const LocationUnknown + +instance Show Location where + show t = case t of + LocationUnknown -> "" + Location a b _ _ -> show a ++ ':' : show b + +instance Monoid Location where + mempty = LocationUnknown +-- Location +-- { startingLine = 0 +-- , startingColumn = 0 +-- , endingLine = 0 +-- , endingColumn = 0 +-- } + mappend loc a = case loc of + LocationUnknown -> a + _ -> case a of + LocationUnknown -> loc + _ -> + loc + { startingLine = min (startingLine loc) (startingLine a) + , startingColumn = min (startingColumn loc) (startingColumn a) + , endingLine = max (endingLine loc) (endingLine a) + , endingColumn = max (endingColumn loc) (endingColumn a) + } +instance Ord Location where + compare a b = case (a,b) of + (LocationUnknown, LocationUnknown) -> EQ + (_ , LocationUnknown) -> LT + (LocationUnknown, _ ) -> GT + _ -> compare (abs(ela-sla), abs(eca-sca), sla, sca) (abs(elb-slb), abs(ecb-scb), slb, scb) + where + sla = startingLine a + ela = endingLine a + slb = startingLine b + elb = endingLine b + sca = startingColumn a + eca = endingColumn a + scb = startingColumn b + ecb = endingColumn b + -- ^ Greater-than is determined by a heuristic value of how large and uncertain the position of + -- the error is. If the exact location is known, it has the lowest uncertainty and is therefore + -- less than a location that might occur across two lines. The 'LocationUnknown' value is the most + -- uncertain and is greater than everything except itself. Using this comparison function, you can + -- sort lists of locations from least to greatest and hopefully get the most helpful, most + -- specific location at the top of the list. + +instance HasNullValue Location where + nullValue = LocationUnknown + testNull LocationUnknown = True + testNull _ = False + +instance PPrintable Location where + pPrint o = case o of + LocationUnknown -> pString "srcLoc()" + Location a b c d -> pList (pString "srcLoc") "(" ", " ")" [pShow a, pShow b, pShow c, pShow d] + +instance NFData Location where + rnf LocationUnknown = () + rnf (Location a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d () + +-- | Create a location where the starting and ending point is the same row and column. +atPoint :: LineNum -> ColumnNum -> Location +atPoint a b = + Location + { startingLine = a + , endingLine = a + , startingColumn = b + , endingColumn = b + } + +-- | The the coordinates from a 'Location': +-- @(('startingLine', 'startingColumn'), ('endingLine', 'endingColumn'))@ +locationCoords :: Location -> Maybe ((LineNum, ColumnNum), (LineNum, ColumnNum)) +locationCoords loc = case loc of + LocationUnknown -> Nothing + _ -> Just ((startingLine loc, startingColumn loc), (endingLine loc, endingColumn loc)) + +---------------------------------------------------------------------------------------------------- +-- $All_about_tokens +-- This module was designed to create parsers which operate in two phases: a lexical analysis phase +-- (see 'lexicalAnalysis') where input text is split up into tokens, and a syntactic analysis phase +-- where a stream of tokens is converted into data. 'Token' is the data type that makes this +-- possible. + +class HasLineNumber a where { lineNumber :: a -> LineNum } +class HasColumnNumber a where { columnNumber :: a -> ColumnNum } +class HasToken a where { getToken :: a tok -> Token tok } + +-- | Every token emitted by a lexical analyzer must have at least a type. 'Token' is polymorphic +-- over the type of token. +data Token tok + = EmptyToken { tokType :: tok } + -- ^ Often times, tokens may not need to contain any text. This is often true of opreator + -- symbols and keywords. This constructor constructs a token with just a type and no text. The + -- more descriptive your token types are, the less you need you will have for storing the text + -- along with the token type, and the more memory you will save. + | CharToken { tokType :: tok, tokChar :: !Char } + -- ^ Constructs tokens along with the text. If the text is only a single character, this + -- constructor is used, which can save a little memory as compared to storing a + -- 'Dao.String.UStr'. + | Token { tokType :: tok, tokUStr :: UStr } + -- ^ Constructs tokens that contain a copy of the text extracted by the lexical analyzer to + -- create the token. + deriving (Eq, Typeable) + +instance Show tok => Show (Token tok) where + show tok = + let cont = tokToStr tok + in show (tokType tok) ++ (if null cont then "" else ' ':show cont) + +instance Functor Token where + fmap f t = case t of + EmptyToken t -> EmptyToken (f t) + CharToken t c -> CharToken (f t) c + Token t u -> Token (f t) u + +-- | If the lexical analyzer emitted a token with a copy of the text used to create it, this +-- function can retrieve that text. Returns 'Dao.String.nil' if there is no text. +tokToUStr :: Token tok -> UStr +tokToUStr tok = case tok of + EmptyToken _ -> nil + CharToken _ c -> ustr [c] + Token _ u -> u + +-- | Like 'tokToUStr' but returns a 'Prelude.String' or @""@ instead. +tokToStr :: Token tok -> String +tokToStr tok = case tok of + EmptyToken _ -> "" + CharToken _ c -> [c] + Token _ u -> uchars u + +-- | This data type stores the starting point (the line number and column number) in the +-- source file of where the token was emitted along with the 'Token' itself. +data TokenAt tok + = TokenAt + { tokenAtLineNumber :: LineNum + , tokenAtColumnNumber :: ColumnNum + , getTokenValue :: Token tok + } + +instance Show tok => + Show (TokenAt tok) where + show tok = let (a,b,c) = asTriple tok in show a++':':show b++' ':show c + +instance HasLineNumber (TokenAt tok) where { lineNumber = tokenAtLineNumber } + +instance HasColumnNumber (TokenAt tok) where { columnNumber = tokenAtColumnNumber } + +instance HasToken TokenAt where { getToken = getTokenValue } + +instance Functor TokenAt where + fmap f t = + TokenAt + { tokenAtLineNumber = tokenAtLineNumber t + , tokenAtColumnNumber = tokenAtColumnNumber t + , getTokenValue = fmap f (getToken t) + } + +-- | Extract the type of the token. +asTokType :: TokenAt tok -> tok +asTokType = tokType . getToken + +-- | Extract the string value stored in this token. /WARNING:/ keyword and operator tokens contain +-- no strings to save memory, so evaluating this function on any token type defind by +-- 'Dao.Parser.operator', 'Dao.Parser.operatorTable', or 'Dao.Parser.keyword' will result in a null +-- sring. +asString :: TokenAt tok -> String +asString = tokToStr . getToken + +-- | Extract the string value stored in this token. /WARNING:/ keyword and operator tokens contain +-- no strings to save memory, so evaluating this function on any token type defind by +-- 'Dao.Parser.operator', 'Dao.Parser.operatorTable', or 'Dao.Parser.keyword' will result in a null +-- sring. +asUStr :: TokenAt tok -> UStr +asUStr = tokToUStr . getToken + +-- | Extract the string value stored in this token. /WARNING:/ keyword and operator tokens contain +-- no strings to save memory, so evaluating this function on any token type defind by +-- 'Dao.Parser.operator', 'Dao.Parser.operatorTable', or 'Dao.Parser.keyword' will result in a null +-- sring. +asName :: TokenAt tok -> Name +asName = fromUStr . asUStr + +-- | That is as-zero, because "0" looks kind of like "()". +-- This function is useful when it is necessary to pass a function argument to functions like +-- 'Dao.Parser.token' and 'Dao.Parser.tokenBy' but you want to ignore the token returned. +as0 :: TokenAt tok -> () +as0 = const () + +-- | Retrieve the token part of a 'TokenAt' object. +asToken :: TokenAt tok -> Token tok +asToken = getToken + +-- | Synonym for 'Prelude.id', used when it is necessary to pass a function argument to functions like +-- 'Dao.Parser.token' and 'Dao.Parser.tokenBy' but you just want the whole 'TokenAt' object. +asTokenAt :: TokenAt tok -> TokenAt tok +asTokenAt = id + +-- | Convert the contents of a 'TokenAt' object to a tripple containg it's component parts. +asTriple :: TokenAt tok -> (LineNum, ColumnNum, Token tok) +asTriple tok = (lineNumber tok, columnNumber tok, getToken tok) + +-- | Convert the contents of a 'TokenAt' object to a pair containg it's component parts, but not the +-- 'Token' itself. +asLineColumn :: TokenAt tok -> (LineNum, ColumnNum) +asLineColumn tok = (lineNumber tok, columnNumber tok) + +-- | Convert the contents of the 'TokenAt' object's 'lineNumber' and 'columnNumber' to a 'Location' +-- object. +asLocation :: TokenAt tok -> Location +asLocation = uncurry atPoint . asLineColumn + +-- | The lexical analysis phase emits a stream of 'TokenAt' objects, but it is not memory +-- efficient to store the line and column number with every single token. To save space, the token +-- stream is "compressed" into 'Lines', where 'TokenAt' that has the same 'lineNumber' is +-- placed into the same 'Line' object. The 'Line' stores the 'lineNumber', and the +-- 'lineNumber's are deleted from every 'TokenAt', leaving only the 'columnNumber' and 'Token' +-- in each line. +data Line tok + = Line + { lineLineNumber :: LineNum + , lineTokens :: [(ColumnNum, Token tok)] + -- ^ a list of tokens, each with an associated column number. + } + +instance HasLineNumber (Line tok) where { lineNumber = lineLineNumber } + +instance Show tok => Show (Line tok) where + show line = concat $ + [ "Line ", show (lineLineNumber line), ":\n" + , intercalate ", " $ + map (\ (col, tok) -> show col++" "++show tok) (lineTokens line) + ] + +instance Functor Line where + fmap f t = + Line + { lineLineNumber = lineLineNumber t + , lineTokens = fmap (fmap (fmap f)) (lineTokens t) + } + +lineToTokensAt :: Line tok -> [TokenAt tok] +lineToTokensAt line = map f (lineTokens line) where + lineNum = lineNumber line + f (colNum, tok) = + TokenAt + { tokenAtLineNumber = lineNum + , tokenAtColumnNumber = colNum + , getTokenValue = tok + } + +---------------------------------------------------------------------------------------------------- +-- $Error_handling +-- The lexical analyzer and syntactic analysis monads all instantiate +-- 'Control.Monad.ParseError.Class.MonadError' in the Monad Transformer Library ("mtl" package). This is +-- the type used for 'Control.Monad.ParseError.Class.throwError' and +-- 'Control.Monad.ParseError.Class.catchError'. + +-- | This data structure is used by both the lexical analysis and the syntactic analysis phase. +data ParseError st tok + = ParseError + { parseErrLoc :: Location + , parseErrMsg :: Maybe UStr + , parseErrTok :: Maybe (Token tok) + , parseStateAtErr :: Maybe st + } + deriving (Eq, Typeable) + +instance (PPrintable st, Show tok) => Show (ParseError st tok) where { show err = prettyShow err } + +instance Functor (ParseError st) where + fmap f e = + ParseError + { parseErrLoc = parseErrLoc e + , parseErrMsg = parseErrMsg e + , parseErrTok = fmap (fmap f) (parseErrTok e) + , parseStateAtErr = parseStateAtErr e + } + +instance (PPrintable st, Show tok) => PPrintable (ParseError st tok) where + pPrint err = do + pString (show (parseErrLoc err)++": ") + sp <- + maybe + (return False) + (\tok -> pString ("(on token: "++show tok++")") >> return True) + (parseErrTok err) + maybe + (return False) + (\msg -> when sp (pString " ") >> pUStr msg >> return True) + (parseErrMsg err) + maybe (return ()) (\st -> pEndLine >> pIndent (pPrint st)) (parseStateAtErr err) + +fmapParseErrorState :: (stA -> stB) -> ParseError stA tok -> ParseError stB tok +fmapParseErrorState f err@(ParseError{ parseStateAtErr=st }) = err{parseStateAtErr=fmap f st} + +-- | An initial blank parser error you can use to construct more detailed error messages. +parserErr :: Location -> ParseError st tok +parserErr loc = + ParseError + { parseErrLoc = loc + , parseErrMsg = Nothing + , parseErrTok = Nothing + , parseStateAtErr = Nothing + } + +newParseError :: ParseError st tok +newParseError = + ParseError + { parseErrLoc = LocationUnknown + , parseErrMsg = Nothing + , parseErrTok = Nothing + , parseStateAtErr = Nothing + } + diff --git a/src/Dao/Tree.hs b/src/Dao/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Dao/Tree.hs @@ -0,0 +1,437 @@ +-- "src/Dao/Tree.hs" provides a fundamental data type used in the Dao +-- System, the "Tree", which is similar to the "Data.Map" data type. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Dao.Tree where + +import Dao.String (HasNullValue, nullValue, testNull) -- TODO: move the HasNullValue class to it's own module. + +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import Control.Monad.Identity +import Control.Monad.Trans +import Control.Monad.State + +import Data.Typeable +import Data.Monoid +import Data.List (intercalate) +-- import Data.Binary +import qualified Data.Map as M +import Data.Word + +---------------------------------------------------------------------------------------------------- + +data Tree p n + = Void + | Leaf { branchData :: n } + | Branch { branchMap :: M.Map p (Tree p n) } + | LeafBranch + { branchData :: n + , branchMap :: M.Map p (Tree p n) + } + deriving Typeable +instance (Show p, Show n) => Show (Tree p n) where + show o = case o of + Void -> "voidTree" + Leaf o -> "(leaf "++show o++")" + Branch t -> "(branch ["++branch t++"])" + LeafBranch o t -> "(leaf "++show o++" branch ["++branch t++"])" + where { branch t = intercalate ", " (M.assocs t >>= \ (nm, o) -> [show nm++"="++show o]) } +instance (Eq p, Eq n) => Eq (Tree p n) where + (==) a b = case (a, b) of + (Void , Void ) -> True + (Leaf a , Leaf b ) -> a == b + (Branch a , Branch b ) -> a == b + (LeafBranch a aa, LeafBranch b bb) -> a == b && aa == bb + _ -> False +instance (Ord p, Ord n) => Ord (Tree p n) where + compare a b = case (a, b) of + (Void , Void ) -> EQ + (Leaf a , Leaf b ) -> compare a b + (Branch aa, Branch bb) -> compare aa bb + (LeafBranch a aa, LeafBranch b bb) -> case compare a b of + EQ -> compare aa bb + e -> e + (Void , _ ) -> LT + (_ , Void ) -> GT + (Leaf _ , _ ) -> LT + (_ , Leaf _ ) -> GT + (Branch _ , _ ) -> LT + (_ , Branch _ ) -> GT +instance Ord p => Functor (Tree p) where + fmap f tree = case tree of + Void -> Void + Leaf a -> Leaf (f a) + Branch m -> Branch (fmap (fmap f) m) + LeafBranch a m -> LeafBranch (f a) (fmap (fmap f) m) +instance (Ord p, Monoid n) => Monoid (Tree p n) where + mempty = Void + mappend = unionWith mappend +instance (NFData a, NFData b) => NFData (Tree a b) where + rnf Void = () + rnf (Leaf a ) = deepseq a () + rnf (Branch b) = deepseq b () + rnf (LeafBranch a b) = deepseq a $! deepseq b () +instance HasNullValue (Tree a b) where { nullValue = Void; testNull = Dao.Tree.null; } + +-- | A combinator to modify the data in the 'Leaf' and 'LeafBranch' nodes of a tree when passed to +-- one of the functions below. +type ModLeaf n = Maybe n -> Maybe n + +-- | A combinator to modify the data in the 'Branch' and 'LeafBranch' nodes of a tree when passed to +-- one of the functions below. +type ModBranch p n = Maybe (M.Map p (Tree p n)) -> Maybe (M.Map p (Tree p n)) + +-- | If a 'Tree' is 'Void' or a contains a branch that is equivalent to 'Data.Map.empty', +-- 'Data.Maybe.Nothing' is returned. +notVoid :: Tree p n -> Maybe (Tree p n) +notVoid t = case t of + Void -> Nothing + Branch b | M.null b -> Nothing + LeafBranch a b | M.null b -> Just (Leaf a) + _ -> Just t + +-- | If the given node is a 'Leaf' or 'LeafBranch', returns the Leaf portion of the node. +getLeaf :: Tree p n -> Maybe n +getLeaf t = case t of { Leaf n -> Just n; LeafBranch n _ -> Just n; _ -> Nothing } + +-- | If the given node is a 'Branch' or 'LeafBranch', returns the branch portion of the node. +getBranch :: Tree p a -> Maybe (M.Map p (Tree p a)) +getBranch t = case t of { Branch b -> Just b; LeafBranch _ b -> Just b; _ -> Nothing } + +-- | Use a 'ModLeaf' function to insert, update, or remove 'Leaf' and 'LeafBranch' nodes. +alterLeaf :: ModLeaf n -> Tree p n -> Tree p n +alterLeaf alt t = maybe Void id $ case t of + Void -> alt Nothing >>= \o -> Just (Leaf o) + Leaf o -> alt (Just o) >>= \o -> Just (Leaf o) + Branch b -> mplus (alt Nothing >>= \o -> Just (LeafBranch o b)) (Just (Branch b)) + LeafBranch o b -> mplus (alt (Just o) >>= \o -> Just (LeafBranch o b)) (Just (Branch b)) + +alterBranch :: (Eq p, Ord p) => ModBranch p n -> Tree p n -> Tree p n +alterBranch alt t = maybe Void id $ case t of + Void -> alt Nothing >>= \b -> Just (Branch b) + Leaf o -> mplus (alt Nothing >>= \b -> Just (LeafBranch o b)) (Just (Leaf o)) + Branch b -> alt (Just b) >>= \b -> Just (Branch b) + LeafBranch o b -> mplus (alt (Just b) >>= \b -> Just (LeafBranch o b)) (Just (Leaf o)) + +---------------------------------------------------------------------------------------------------- + +data ZipTree p n = ZipTree{ focus :: Tree p n, history :: [(p, Tree p n)] } + +newtype UpdateTreeT p n m a = UpdateTreeT{ getUpdateTreeStateT :: StateT (ZipTree p n) m a } +type UpdateTree p n a = UpdateTreeT p n Identity a + +instance Monad m => + Monad (UpdateTreeT p n m) where + return = UpdateTreeT . return + (UpdateTreeT a) >>= b = UpdateTreeT (a >>= getUpdateTreeStateT . b) +instance Functor m => + Functor (UpdateTreeT p n m) where { fmap f (UpdateTreeT m) = UpdateTreeT (fmap f m); } +instance (Monad m, Functor m) => + Applicative (UpdateTreeT p n m) where { pure = return; (<*>) = ap; } +instance Monad m => + MonadState (ZipTree p n) (UpdateTreeT p n m) where { state = UpdateTreeT . state; } +instance MonadTrans (UpdateTreeT p n) where { lift m = UpdateTreeT (lift m); } + +-- | Like 'Control.Monad.State.runState', evaluates an 'UpdateTree' monad transformer lifting the +-- 'Control.Monad.Identity.Identity' monad, removing the identity monad after evaluation to give you +-- a pure function. +runUpdateTree :: Ord p => UpdateTree p n a -> Tree p n -> (a, Tree p n) +runUpdateTree updfn = runIdentity . runUpdateTreeT updfn + +-- | Like 'Control.Monad.State.execState', disgards the value returned to the 'UpdateTree' monad and +-- only returns the 'Tree'. +execUpdateTree :: Ord p => UpdateTree p n a -> Tree p n -> Tree p n +execUpdateTree updfn = snd . runUpdateTree updfn + +-- | Update a 'Tree' using an 'UpdateTreeT' monad, much like how 'Control.Monad.State.runStateT' +-- works. Evaluates to a monadic computation of the lifted type @m@ that 'Control.Monad.return's a +-- pair containing the value last 'Control.Monad.return'ed to the lifted monad and the updated +-- 'Tree'. +runUpdateTreeT :: (Ord p, Functor m, Monad m) => UpdateTreeT p n m a -> Tree p n -> m (a, Tree p n) +runUpdateTreeT updfn tree = fmap (fmap focus) $ + runStateT (getUpdateTreeStateT (updfn >>= \a -> home >> return a)) (ZipTree{focus=tree, history=[]}) + +-- | Go to the node with the given path. If the path does not exist, it is created. +goto :: (Ord p, Monad m) => [p] -> UpdateTreeT p n m (Tree p n) +goto path = case path of + [] -> gets focus + (p:path) -> do + st <- get + let step tree = put $ st{focus=tree, history=(p, focus st):history st} + case getBranch (focus st) >>= M.lookup p of + Nothing -> step Void + Just tree -> step tree + goto path + +-- | Go up one level in the tree, storing the current sub-tree into the upper tree, unless the +-- current tree is 'Void', in which case it is deleted from the upper tree. +back :: (Ord p, Monad m) => UpdateTreeT p n m () +back = modify $ \st -> case history st of + [] -> st + (p, tree):hist -> + st{ history = hist + , focus = flip alterBranch tree $ \branch -> flip mplus (fmap (M.delete p) branch) $ do + subTree <- notVoid (focus st) + fmap (M.insert p subTree) (mplus branch (return mempty)) + } + +-- | Returns 'Prelude.True' if we are at the top level of the tree. +atTop :: (Functor m, Monad m) => UpdateTreeT p n m Bool +atTop = fmap Prelude.null (gets history) + +-- | Go back to the top level of the tree. +home :: (Ord p, Functor m, Monad m) => UpdateTreeT p n m () +home = atTop >>= flip unless (back >> home) + +-- | Return the current path. +getPath :: (Ord p, Functor m, Monad m) => UpdateTreeT p n m [p] +getPath = fmap (reverse . fmap fst) (gets history) + +-- | Modify the tree node at the current 'focus'. After the update, if there is a leaf attached at +-- the focus, the value of the leaf is returned. +modifyNode :: (Ord p, Functor m, Monad m) => (Tree p n -> Tree p n) -> UpdateTreeT p n m (Maybe n) +modifyNode mod = modify (\st -> st{focus=mod(focus st)}) >> fmap getLeaf (gets focus) + +-- | Modify the tree node using a 'ModBranch' function which allows you to alter the 'Data.Map.Map' +-- object containing the branches of the current node. +modifyBranch :: (Ord p, Functor m, Monad m) => ModBranch p n -> UpdateTreeT p n m () +modifyBranch mod = modifyNode (alterBranch mod) >> return () + +-- | Modify the tree node using a 'ModLeaf' function which allows you to alter the 'Data.Map.Map' +-- object containing the current of the current node. +modifyLeaf :: (Ord p, Functor m, Monad m) => ModLeaf n -> UpdateTreeT p n m (Maybe n) +modifyLeaf mod = modifyNode (alterLeaf mod) + +---------------------------------------------------------------------------------------------------- +-- $MapLikeFunctions +-- In this section I have made my best effor to create API functions as similar as possible to that +-- of the "Data.Map" module. +---------------------------------------------------------------------------------------------------- + +alter :: Ord p => (Tree p a -> Tree p a) -> [p] -> Tree p a -> Tree p a +alter mod path = execUpdateTree (goto path >> modifyNode mod) +--alterNode alt px t = runIdentity $ alterNodeM (return . alt) px t + +-- | Insert a 'Leaf' at a given address. +insert :: Ord p => [p] -> n -> Tree p n -> Tree p n +insert path n = execUpdateTree (goto path >> modifyLeaf (const (Just n))) +--insert px a = alter (const (Just a)) (flip mplus (Just Void)) px + +-- | Update a 'Leaf' at a given address. +update :: Ord p => [p] -> ModLeaf a -> Tree p a -> Tree p a +update path mod = execUpdateTree (goto path >> modifyLeaf mod) +--update path mod = alter mod (flip mplus (Just Void)) path + +-- | Delete a 'Leaf' or 'Branch' at a given address. +delete :: Ord p => [p] -> Tree p a -> Tree p a +delete path = execUpdateTree (goto path >> modifyLeaf (const Nothing)) +--delete px = alter (const Nothing) id px + +-- | Create a 'Tree' from a list of associationes, the 'Prelude.fst' element containing the branch, +-- the 'Prelude.snd' element containing the leaf value. This is the inverse operation of 'assocs'. +fromList :: Ord p => [([p], a)] -> Tree p a +fromList = foldl (\ tree (px, a) -> insert px a tree) Void + +-- | Lookup a 'Tree' value (the whole node, not just the data stored in the node) at given address. +-- NOTE: this may not be what you want. If you want return the data that is stored in a 'Leaf' or +-- 'LeafBranch', use 'lookup', or just do @'lookup' atBranch inTree >>= 'getLeaf'@. +lookupNode :: Ord p => [p] -> Tree p a -> Maybe (Tree p a) +lookupNode px t = case px of + [] -> Just t + p:px -> case t of + Branch t -> next p t + LeafBranch _ t -> next p t + _ -> Nothing + where { next p t = M.lookup p t >>= Dao.Tree.lookupNode px } + +-- | This function analogous to the 'Data.Map.lookup' function, which returns a value stored in a +-- leaf, or nothing if there is no leaf at the given path. +lookup :: Ord p => [p] -> Tree p a -> Maybe a +lookup px t = lookupNode px t >>= getLeaf + +-- | Using @[p]@ as a path, traverse the path through the given 'Tree' as far as possible, return +-- the last node that could be reached along with the remainder of the path that was not traversed. +-- This is used to lookup whether or not a leaf has been stored into the tree at the given path, or +-- at some sub-path of the given path. +partialLookup :: Ord p => [p] -> Tree p a -> Maybe ([p], Tree p a) +partialLookup px t = case px of + [] -> Just ([], t) + p:px -> mplus (getBranch t >>= M.lookup p >>= partialLookup px) $ + (getLeaf t >>= \ _ -> return (p:px, t)) + +-- | Using @[p]@ as a path, traverse a tree and retrieve every leaf found along the path until +-- traversal cannot continue. Evaluates to the list of leaves retrieved, the portion of the path +-- that could not be traversed, and the node at which traversal stopped. +leavesAlongPath :: Ord p => [p] -> Tree p a -> ([a], ([p], Tree p a)) +leavesAlongPath px t = maybe ([], (px, t)) id $ loop [] px t where + loop ax px t = return (ax ++ maybe [] (:[]) (getLeaf t)) >>= \ax -> case px of + [] -> return (ax, ([], t)) + p:px -> mplus (getBranch t >>= M.lookup p >>= loop ax px) (return (ax, (p:px, t))) + +-- | There are only two kinds values defined as a 'MergeType': 'union' and 'intersection. +type MergeType p a + = (Tree p a -> Tree p a -> Tree p a) + -> M.Map p (Tree p a) + -> M.Map p (Tree p a) + -> M.Map p (Tree p a) + +-- | Merge two trees together. +mergeWithKey :: Ord p + => ([p] -> Maybe a -> Maybe b -> Maybe c) + -> (Tree p a -> Tree p c) + -> (Tree p b -> Tree p c) + -> Tree p a -> Tree p b -> Tree p c +mergeWithKey overlap leftOnly rightOnly left right = loop [] left right where + -- loop :: Ord p => [p] -> Tree p a -> Tree p b -> Tree p c + loop px left right = case left of + Void -> case right of + Void -> Void + Leaf y -> rightOnly (Leaf y ) + Branch b -> rightOnly (Branch b) + LeafBranch y b -> rightOnly (LeafBranch y b) + Leaf x -> case right of + Void -> leftOnly (Leaf x ) + Leaf y -> maybe Void id (fmap Leaf (overlap px (Just x) (Just y))) + Branch b -> leafbranch (Just x) Nothing M.empty b + LeafBranch y b -> leafbranch (Just x) (Just y) M.empty b + Branch a -> case right of + Void -> leftOnly (Branch a) + Leaf y -> leafbranch Nothing (Just y) a M.empty + Branch b -> leafbranch Nothing Nothing a b + LeafBranch y b -> leafbranch Nothing (Just y) a b + LeafBranch x a -> case right of + Void -> leftOnly (LeafBranch x a) + Leaf y -> leafbranch (Just x) (Just y) a M.empty + Branch b -> leafbranch (Just x) Nothing a b + LeafBranch y b -> leafbranch (Just x) (Just y) a b + where + -- leafbranch :: Ord p => M.Map p (Tree p a) -> M.Map p (Tree p b) -> Maybe a -> Maybe b -> Tree p c + leafbranch x y left right = + let c = M.mergeWithKey both (bias leftOnly) (bias rightOnly) left right -- :: M.Map p (Tree p c) + in case overlap px x y of + Nothing -> notEmpty Branch c + Just z -> notEmpty (LeafBranch z) c + -- notEmpty :: Ord p => (M.Map p (Tree p a) -> Tree p a) -> M.Map p (Tree p a) -> Tree p a + notEmpty cons c = if M.null c then Void else cons c + -- both :: Ord p => p -> Tree p a -> Tree p b -> Maybe (Tree p c) + both p left right = notVoid (loop (px++[p]) left right) + -- bias :: Ord p => (Tree p a -> Tree p b) -> M.Map p (Tree p a) -> M.Map p (Tree p b) + bias fn = M.mapMaybe (notVoid . fn) + +mergeWith :: Ord p => (Maybe a -> Maybe b -> Maybe c) -> (Tree p a -> Tree p c) -> (Tree p b -> Tree p c) -> Tree p a -> Tree p b -> Tree p c +mergeWith overlap = mergeWithKey (\ _ -> overlap) + +unionWithKey :: Ord p => ([p] -> a -> a -> a) -> Tree p a -> Tree p a -> Tree p a +unionWithKey overlap = mergeWithKey (\k a b -> msum [liftM2 (overlap k) a b, a, b]) id id + +unionWith :: Ord p => (a -> a -> a) -> Tree p a -> Tree p a -> Tree p a +unionWith overlap = unionWithKey (\ _ -> overlap) + +union :: Ord p => Tree p a -> Tree p a -> Tree p a +union = unionWith const + +unionsWith :: Ord p => (a -> a -> a) -> [Tree p a] -> Tree p a +unionsWith overlap = foldl (unionWith overlap) Void + +unions :: Ord p => [Tree p a] -> Tree p a +unions = unionsWith (flip const) + +intersectionWithKey :: Ord p => ([p] -> a -> a -> a) -> Tree p a -> Tree p a -> Tree p a +intersectionWithKey overlap = mergeWithKey (\k -> liftM2 (overlap k)) (const Void) (const Void) + +intersectionWith :: Ord p => (a -> a -> a) -> Tree p a -> Tree p a -> Tree p a +intersectionWith overlap = intersectionWithKey (\ _ -> overlap) + +intersection :: Ord p => Tree p a -> Tree p a -> Tree p a +intersection = intersectionWith const + +intersectionsWith :: Ord p => (a -> a -> a) -> [Tree p a] -> Tree p a +intersectionsWith overlap = foldl (intersectionWith overlap) Void + +intersections :: Ord p => [Tree p a] -> Tree p a +intersections = intersectionsWith (flip const) + +differenceWithKey :: Ord p => ([p] -> a -> b -> Maybe a) -> Tree p a -> Tree p b -> Tree p a +differenceWithKey overlap = mergeWithKey (\k a b -> mplus (b >>= \b -> a >>= \a -> overlap k a b) a) id (const Void) + +differenceWith :: Ord p => (a -> b -> Maybe a) -> Tree p a -> Tree p b -> Tree p a +differenceWith overlap = differenceWithKey (\ _ -> overlap) + +difference :: Ord p => Tree p a -> Tree p b -> Tree p a +difference = differenceWith (\ _ _ -> Nothing) + +-- | Get all items and their associated path. +assocs :: Tree p a -> [([p], a)] +assocs t = loop [] t where + recurs px b = M.assocs b >>= \ (p, t) -> loop (px++[p]) t + loop px t = case t of + Void -> [] + Leaf a -> [(px, a)] + Branch b -> recurs px b + LeafBranch a b -> (px, a) : recurs px b + +-- | Apply @'Prelude.map' 'Prelude.snd'@ to the result of 'assocs', behaves just like how +-- 'Data.Map.elems' or 'Data.Array.IArray.elems' works. +elems :: Tree p a -> [a] +elems t = fmap snd (assocs t) + +-- | Counts the number of *nodes*, which includes the number of 'Branch'es and 'Leaf's. +size :: Tree p a -> Word64 +size t = case t of + Void -> 0 + Leaf _ -> 1 + Branch m -> 0 + f m + LeafBranch _ m -> 1 + f m + where { f m = foldl (\sz tre -> sz + size tre) (fromIntegral (M.size m)) (M.elems m) } + +branchCount :: Tree p a -> Int +branchCount = maybe 0 M.size . getBranch + +null :: Tree p a -> Bool +null Void = True +null _ = False + +---------------------------------------------------------------------------------------------------- + +data TreeDiff a b + = LeftOnly a -- something exists in the "left" branch but not in the "right" branch. + | RightOnly b -- something exists in the "right" branch but not in the "left" branch. + | TreeDiff a b -- something exists in the "left" and "right" branches but they are not equal + deriving (Eq, Typeable) + +-- | Produce a difference report of two trees with the given comparison predicate. If the predicate +-- returns 'Prelude.True', the node is ignored, otherwise the differences is reported. +treeDiffWith :: Ord p => (a -> b -> Bool) -> Tree p a -> Tree p b -> Tree p (TreeDiff a b) +treeDiffWith compare = mergeWithKey leaf (fmap LeftOnly) (fmap RightOnly) where + leaf _ a b = msum $ + [ a >>= \a -> b >>= \b -> if compare a b then Nothing else Just (TreeDiff a b) + , fmap LeftOnly a, fmap RightOnly b + ] + +-- | Call 'treeDiffWith' using 'Prelude.(==)' as the comparison predicate. +treeDiff :: (Eq a, Ord p) => Tree p a -> Tree p a -> Tree p (TreeDiff a a) +treeDiff = treeDiffWith (==) + diff --git a/src/dao-main.hs b/src/dao-main.hs new file mode 100644 --- /dev/null +++ b/src/dao-main.hs @@ -0,0 +1,122 @@ +-- "src/dao-main.hs" the Main module for the "dao" executable program. +-- Provides an interactive command line interface to the Dao System. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, +-- please see . + + +-- {-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Dao +import Dao.Predicate +import Dao.PPrint + +import Data.Char + +import Control.Monad +import Control.Monad.IO.Class + +import System.Environment +import System.IO +--import System.Console.Readline + +---------------------------------------------------------------------------------------------------- + +version :: String +version = "0.0 (experimental)" + +disclaimer :: String +disclaimer = unlines $ + [ "\"Dao\" version "++version + , "Copyright (C) 2008-2014 Ramin Honary." + , "This program comes with ABSOLUTELY NO WARRANTY." + , "This is free software, and you are welcome to redistribute it under" + , "the terms and conditions of the GNU Affero General Public License." + , "Enter the command \":license\" for details." + , "-----------------------------------------------" + ] + +inputLoop :: Exec (Maybe UStr) +inputLoop = do + liftIO $ putStr "dao> " >> hFlush stdout + closed <- liftIO $ hIsClosed stdin + eof <- liftIO isEOF + if closed || eof + then return Nothing + else do + -- hSetEcho stdin True + str <- liftIO getLine + --------------------------------------------------- + --readline "dao> " >>= \str -> case str of + -- Nothing -> return Nothing + -- Just str -> addHistory str >> return (Just str) + case words (uchars str) of + o | o==[":quit" ] || o==[":", "quit" ] -> return Nothing + o | o==[":license"] || o==[":", "license"] -> liftIO (putStrLn license_text) >> inputLoop + ((':':_) : _) -> do + evalScriptString (dropWhile (\c -> isSpace c || c==':') str) + inputLoop + (a:cmds) | head a==':' -> do + liftIO $ hPutStr stderr $ unwords $ + ["Error: unknown meta-command"] ++ if null cmds then [] else [show $ head cmds] + inputLoop + _ -> return $ Just $ toUStr str + +main :: IO () +main = do + hSetBuffering stderr LineBuffering + hSetBuffering stdout LineBuffering + argv <- getArgs + when (elem "--version" argv) (putStr disclaimer) + argv <- return $ fmap ustr $ filter (/="--version") argv + --initialize -- initialize the ReadLine library + result <- setupDao $ do + loadDaoStandardLibrary + daoInitialize $ do + loadEveryModule argv + daoInputLoop inputLoop + daoShutdown + case result of + OK () -> return () + PFail (ExecReturn o) -> maybe (return ()) (putStrLn . prettyShow) o + PFail (err@ExecError{}) -> hPutStrLn stderr (prettyShow err) + Backtrack -> hPutStrLn stderr "(does not compute)" + --restorePrompt -- shut-down the ReadLine library + hPutStrLn stderr "Dao has exited." + +license_text :: String +license_text = unlines $ + [ "Dao version: "++version + , "Copyright (C) 2008-2014 Ramin Honary" + , "" + , "This program is free software: you can redistribute it and/or modify" + , "it under the terms and conditions of the GNU General Public License as" + , "published by the Free Software Foundation, either version 3 of the" + , "license, or (at your option) any later version." + , "" + , "This program is distributed in the hope that it will be useful" + , "WITHOUT ANY WARRANTY; without even the implied warranty of" + , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , "GNU General Public License for more details." + , "" + , "You should have received a copy of the GNU General Public License" + , "along with this program (see the file called \"LICENSE\"). If not," + , "please see ." + ] + diff --git a/tests/main.hs b/tests/main.hs new file mode 100644 --- /dev/null +++ b/tests/main.hs @@ -0,0 +1,26 @@ +-- "tests/main.hs" calls the main function of the Dao.Test module. +-- +-- Copyright (C) 2008-2014 Ramin Honary. +-- This file is part of the Dao System. +-- +-- The Dao System is free software: you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- The Dao System is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program (see the file called "LICENSE"). If not, see +-- . + +module Main where +import qualified Dao.Test +import qualified Dao.CoreTests + +main :: IO () +main = Dao.Test.main Dao.CoreTests.unitTester +