Changeset 25

Show
Ignore:
Timestamp:
02/13/05 19:15:26 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
1041
Message:

* monadic continuations (unfinished)

Location:
src
Files:
11 modified

Legend:

Unmodified
Added
Removed

  • src/AST.hs

    r18 r25  
    1414module AST where 
    1515import Internals 
    16  
    1716import Context 
    1817 
    1918type Ident = String 
    20  
    21 instance Show (a -> b) where 
    22     show f = "sub { ... }" 
    2319 
    2420class Context n where 
    … …  
    5349instance Context VBool where 
    5450    castV = VBool 
    55     doCast (VJunc j l) = juncToBool j l 
     51    doCast (VJunc j)   = juncToBool j 
    5652    doCast (VBool b)   = b 
    5753    doCast VUndef      = False 
    … …  
    6460    doCast _           = True 
    6561 
    66 juncToBool :: JuncType -> Set Val -> Bool 
    67 juncToBool JAny     = (True `elementOf`) . mapSet vCast 
    68 juncToBool JAll     = not . (False `elementOf`) . mapSet vCast 
    69 juncToBool JNone    = not . (True `elementOf`) . mapSet vCast 
    70 juncToBool JOne     = (1 ==) . length . filter vCast . setToList 
     62juncToBool :: VJunc -> Bool 
     63juncToBool (Junc JAny  _  vs) = (True `elementOf`) $ mapSet vCast vs 
     64juncToBool (Junc JAll  _  vs) = not . (False `elementOf`) $ mapSet vCast vs 
     65juncToBool (Junc JNone _  vs) = not . (True `elementOf`) $ mapSet vCast vs 
     66juncToBool (Junc JOne  ds vs) 
     67    | (True `elementOf`) $ mapSet vCast ds 
     68    = False 
     69    | otherwise 
     70    = (1 ==) . length . filter vCast $ setToList vs 
    7171 
    7272instance Context VInt where 
    … …  
    125125    vCast x = MkArray (vCast x)  
    126126 
     127{- 
    127128instance Context VJunc where 
    128     castV = VJunc JAny 
    129     vCast x = mkSet (vCast x) 
     129    castV = JAny . castV 
     130    vCast x = JAny $ mkSet (vCast x) 
     131-} 
    130132 
    131133instance Context VList where 
    … …  
    134136    vCast (VPair k v)   = [k, v] 
    135137    vCast (VRef v)      = vCast v 
     138    vCast (VUndef)      = [] 
    136139    vCast v             = [v] 
    137140 
    … …  
    146149 
    147150type VScalar = Val 
    148 type VJunc = Set Val 
     151-- type VJunc = Set Val 
    149152 
    150153instance Context VScalar where 
    … …  
    204207    | VSub      VSub 
    205208    | VBlock    Exp 
    206     | VJunc     JuncType VJunc 
     209    | VJunc     VJunc 
    207210    | VError    VStr Exp 
     211    deriving (Show, Eq, Ord) 
     212 
     213data VJunc = Junc { juncType :: JuncType 
     214                  , juncDup  :: Set Val 
     215                  , juncSet  :: Set Val 
     216                  } deriving (Show, Eq, Ord) 
     217 
     218data JuncType = JAny | JAll | JNone | JOne 
    208219    deriving (Show, Eq, Ord) 
    209220 
    … …  
    226237data VSub = Sub 
    227238    { isMulti       :: Bool 
     239    , subName       :: String 
    228240    , subType       :: SubType 
     241    , subPad        :: Symbols 
    229242    , subAssoc      :: String 
    230243    , subParams     :: Params 
    … …  
    239252    | THash     Val 
    240253 
     254{- 
    241255data JuncType = JAll | JAny | JOne | JNone 
    242256    deriving (Show, Eq, Ord) 
    243  
    244 instance Eq (Env -> [Val] -> Val) 
    245 instance Ord (Env -> [Val] -> Val) where 
     257-} 
     258 
     259instance Ord ([Val] -> StateEnv Val) where 
    246260    compare _ _ = LT 
    247261instance (Ord a) => Ord (Set a) where 
    … …  
    257271    = App String [Exp] [Exp] 
    258272    | Syn String [Exp] 
    259     | Prim (Env -> [Val] -> Val) 
     273    | Sym Scope Var 
     274    | Prim ([Val] -> StateEnv Val) 
    260275    | Val Val 
    261276    | Var Var SourcePos 
    … …  
    311326defaultScalarParam  = buildParam "" "*" "$_" (Val VUndef) 
    312327 
    313 data Env = Env { cxt :: Cxt 
    314                , sym :: Symbols 
    315                , cls :: ClassTree 
    316                , evl :: Env -> Exp -> Val 
    317                } deriving (Show) 
    318 type Symbol  = (String, Val) 
     328-- The eval monad! 
     329type StateEnv a = State Env a 
     330 
     331data Env = Env { envContext :: Cxt 
     332               , envPad     :: Symbols 
     333               , envClasses :: ClassTree 
     334               , envEval    :: Exp -> Eval Val 
     335               , envCC      :: Val -> Eval Val 
     336               , envBody    :: Exp 
     337               , envDepth   :: Int 
     338               , envID      :: Unique 
     339               } deriving (Show, Eq) 
     340 
    319341type Symbols = [Symbol] 
    320  
     342data Symbol = Symbol { symScope :: Scope 
     343                     , symName  :: String 
     344                     , symValue :: Val 
     345                     } deriving (Show, Eq, Ord) 
     346 
     347data Scope = SGlobal | SMy | SOur | SLet | STemp | SState 
     348    deriving (Show, Eq, Ord, Read, Enum) 
     349 
     350type Eval x = ContT Val (ReaderT Env IO) x 

  • src/Bind.hs

    r12 r25  
    4444bindArray :: [Exp] -> [Param] -> MaybeError [(Param, Exp)] 
    4545bindArray vs ps = do 
    46     case foldM (doBindArray (Syn "&infix:," vs)) ([],0) prms of 
     46    case foldM (doBindArray (Syn "," vs)) ([],0) prms of 
    4747        Left errMsg     -> fail errMsg 
    4848        Right (bound,_) -> return $ reverse bound 
    … …  
    5151 
    5252doSlice :: Exp -> [VInt] -> Exp 
    53 doSlice v ns = Syn "&infix:[]" [v, Val $ VList $ map VInt ns] 
     53doSlice v ns = Syn "[]" [v, Val $ VList $ map VInt ns] 
    5454 
    5555-- XXX - somehow force failure 
    5656doIndex :: Exp -> VInt -> Exp 
    57 doIndex v n = Syn "&infix:[]" [v, Val $ VInt n] 
     57doIndex v n = Syn "[]" [v, Val $ VInt n] 
    5858 
    5959doBindArray :: Exp -> ([(Param, Exp)], VInt) -> (Param, Char) -> MaybeError ([(Param, Exp)], VInt) 
    … …  
    6969 
    7070isPair :: Exp -> Bool 
    71 isPair (Syn "&infix:=>" [(Val v), _])   = True 
     71isPair (Syn "=>" [(Val v), _])   = True 
    7272isPair (Val (VPair _ _))                = True 
    7373isPair _                                = False 
    7474 
    7575unPair :: Exp -> (String, Exp) 
    76 unPair (Syn "&infix:=>" [(Val k), exp]) = (vCast k, exp) 
     76unPair (Syn "=>" [(Val k), exp]) = (vCast k, exp) 
    7777unPair (Val (VPair k v))                = (vCast k, Val v) 
    7878unPair x                                = error ("Not a pair: " ++ show x) 

  • src/Eval.hs

    r21 r25  
    2020import Prim 
    2121import Context 
    22  
    23 emptyEnv = Env { cxt = "List" 
    24                , sym = initSyms 
    25                , cls = initTree 
    26                , evl = evaluate 
     22import Monad 
     23 
     24emptyEnv = Env { envContext = "List" 
     25               , envPad     = [initSyms] 
     26               , envClasses = initTree 
     27               , envEval    = evaluate 
    2728               } 
    2829 
    29 addSym :: Env -> [(String, Val)] -> Env 
    30 addSym env [] = env 
    31 addSym env ((var, val):vs) = env{ sym = (var, val):(sym $ addSym env vs) } 
    32  
    33 evaluate :: Env -> Exp -> Val 
    34 evaluate env@Env{ cxt = cxt, cls = cls } exp 
    35     | Val v <- val  = v 
    36     | otherwise     = VError "Invalid expression" exp 
    37     where 
    38     (env', val) = reduce env exp 
    39     isaContext = isaType cls cxt 
     30addSym :: Symbols -> StateEnv () 
     31addSym syms = modify doAddSyms 
     32    where 
     33    doAddSyms env@Env{ envPad = (pad:outer) } = env{ envPad = ((syms++pad):outer) } 
     34 
     35pushPad :: Symbols -> StateEnv () 
     36pushPad syms = modify (\env -> env{ envPad = tail $ envPad env }) 
     37 
     38popPad :: StateEnv () 
     39popPad = modify (\env -> env{ envPad = tail $ envPad env }) 
     40 
     41evaluate :: Exp -> StateEnv Val 
     42evaluate exp = do 
     43    val <- reduce exp 
     44    return $ case val of 
     45        Val v       -> v 
     46        otherwise   -> VError "Invalid expression" exp 
    4047 
    4148-- OK... Now let's implement the hideously clever autothreading algorithm. 
    … …  
    4350-- Second pass - thread thru any() and one() 
    4451 
    45 chainFun :: Params -> Exp -> Params -> Exp -> Env -> [Val] -> Val 
    46 chainFun p1 f1 p2 f2 env' (v1:v2:vs) 
    47     | VBool False <- applyFun env' (chainArgs p1 [v1, v2]) f1 
    48     = VBool False 
    49     | otherwise 
    50     = applyFun env' (chainArgs p2 (v2:vs)) f2 
     52chainFun :: Params -> Exp -> Params -> Exp -> [Val] -> StateEnv Val 
     53chainFun p1 f1 p2 f2 (v1:v2:vs) = do 
     54    val <- applyFun (chainArgs p1 [v1, v2]) f1 
     55    case val of 
     56        VBool False -> return val 
     57        _           -> applyFun (chainArgs p2 (v2:vs)) f2 
    5158    where 
    5259    chainArgs prms vals = map chainArg (prms `zip` vals) 
    5360    chainArg (p, v) = ApplyArg (paramName p) v False 
    5461 
    55 applyFun :: Env -> [ApplyArg] -> Exp -> Val 
    56 applyFun env bound (Prim f) 
    57     = f env [ argValue arg | arg <- bound, (argName arg !! 1) /= '_' ] 
    58 applyFun env bound body 
    59     | Val val   <- exp          = val 
    60     | otherwise                 = VError "Invalid expression" exp 
    61     where 
    62     (fenv, exp) = reduce (env `addSym` formal) body 
    63     formal = filter (not . null . fst) $ map argNameValue bound 
    64     argNameValue (ApplyArg name val _) = (name, val) 
    65  
    66 apply :: Env -> VSub -> [Exp] -> [Exp] -> ((Env -> Env), Exp) 
    67 apply env@Env{ cls = cls } Sub{ subParams = prms, subFun = fun } invs args = 
     62applyFun :: [ApplyArg] -> Exp -> StateEnv Val 
     63applyFun bound (Prim f) 
     64    = f [ argValue arg | arg <- bound, (argName arg !! 1) /= '_' ] 
     65applyFun bound body = do 
     66    pushPad formal 
     67    exp <- reduce body 
     68    return $ case exp of 
     69        Val val     -> val 
     70        otherwise   -> VError "Invalid expression" exp 
     71    where 
     72    formal = filter (not . null . symName) $ map argNameValue bound 
     73    argNameValue (ApplyArg name val _) = Symbol SMy name val 
     74 
     75apply :: VSub -> [Exp] -> [Exp] -> StateEnv Exp 
     76apply sub invs args = do 
     77    env <- get 
     78    doApply env sub invs args 
     79 
     80doApply :: Env -> VSub -> [Exp] -> [Exp] -> StateEnv Exp 
     81doApply env@Env{ envClasses = cls } Sub{ subParams = prms, subFun = fun } invs args = 
    6882    case bindParams prms invs args of 
    6983        Left errMsg     -> retVal $ VError errMsg (Val VUndef) 
    70         Right bindings  -> retVal $ juncApply eval (reverse . fst $ foldl doBind ([],env) bindings) 
    71     where 
    72     eval bound = applyFun env bound fun 
     84        Right bindings  -> retVal $ VUndef -- XXX -- juncApply eval (reverse . fst $ foldl doBind ([],env) bindings) 
     85    where 
     86    eval bound = applyFun bound fun 
     87    {- XXX 
    7388    doBind :: ([ApplyArg], Env) -> (Param, Exp) -> ([ApplyArg], Env) 
    74     doBind (bs, env) (prm@Param{ paramName = name }, exp) 
    75         = let (val, coll) = expToVal env prm exp in 
    76         (((ApplyArg name val coll): bs), env `addSym` [(name, val)]) 
    77     expToVal env Param{ isSlurpy = slurpy, paramContext = cxt } exp 
    78         = (evalEnv env{ cxt = cxt } exp, slurpy || isCollapsed cxt) 
     89    doBind (bs, env) (prm@Param{ paramName = name }, exp) = do 
     90        (val, coll) <- expToVal prm exp 
     91        (((ApplyArg name val coll): bs), env `addSym` [Symbol SMy name val]) 
     92    -} 
     93    expToVal Param{ isSlurpy = slurpy, paramContext = cxt } exp = do 
     94        val <- evalEnvWithContext cxt exp 
     95        return (val, (slurpy || isCollapsed cxt)) 
    7996    isCollapsed cxt 
    8097        | isaType cls "Bool" cxt        = True 
    … …  
    83100        | otherwise                     = False 
    84101 
    85 evalEnv env@Env{ evl = f } = f env 
     102evalEnv exp = do 
     103    evl <- gets envEval 
     104    evl exp 
     105 
     106evalEnvWithContext newCxt exp = do 
     107    Env{ envContext = cxt, envEval = evl } <- get 
     108    modify (\env -> env{ envContext = newCxt }) 
     109    val <- evl exp 
     110    modify (\env -> env{ envContext = cxt }) 
     111    return val 
    86112 
    87113toGlobal name 
    … …  
    91117    | otherwise = name 
    92118 
    93 retVal :: Val -> ((Env -> Env), Exp) 
    94 retVal val = (id, Val val) 
    95  
    96 isGlobalExp (Syn name _) = name `elem` map ("&infix:" ++) (words ":= ::=") 
     119retVal :: Val -> StateEnv Exp 
     120retVal val = return $ Val val 
     121 
     122isGlobalExp (Syn name _) = name `elem` (words ":= ::=") 
    97123isGlobalExp _ = False 
    98124 
    99 reduce :: Env -> Exp -> ((Env -> Env), Exp) 
    100 reduce Env{ cxt = cxt } exp@(NonTerm _) 
    101     | cxt == "Bool"     = retVal $ VBool False 
    102     | cxt == "List"     = retVal $ VList [] 
    103     | cxt == "Array"    = retVal $ VArray $ MkArray [] 
    104     | cxt == "Hash"     = retVal $ VHash $ MkHash emptyFM 
    105     | otherwise         = retVal $ VUndef 
    106  
    107 reduce env@Env{ sym = sym } exp@(Var var _) 
    108     | Just val <- lookup var sym 
     125findSym :: String -> [Symbols] -> Maybe Val 
     126findSym name pad 
     127    | Just s <- find ((== name) . symName) (concat pad) 
     128    = Just $ symValue s 
     129    | otherwise 
     130    = Nothing 
     131 
     132reduce :: Exp -> StateEnv Exp 
     133reduce exp = do 
     134    env <- get 
     135    doReduce env exp 
     136 
     137doReduce Env{ envPad = pad } exp@(Var var _) 
     138    | Just val <- findSym var pad 
    109139    = retVal val 
    110     | Just val <- lookup (toGlobal var) sym 
     140    | Just val <- findSym (toGlobal var) pad 
    111141    = retVal val 
    112142    | otherwise 
    113143    = retVal $ VError ("Undefined variable " ++ var) exp 
    114144 
    115 reduce env@Env{ cxt = cxt } exp@(Syn name exps) 
    116     | name `isInfix` ";" 
    117     , [left, right]     <- exps 
    118     , (lead, final)     <- buildStatements exps 
    119     , (env', exp)       <- foldl (runStatement "Any") (env, Val VUndef) lead 
    120     , (env', exp)       <- runStatement cxt (env', exp) final 
    121     = (const env', exp) 
    122     | name `isInfix` ":=" 
    123     , [Var var _, exp]  <- exps 
    124     , (fenv, Val val)   <- reduce env exp 
    125     = (combineEnv fenv var val, Val val) 
    126     | name `isInfix` "::=" 
    127     , [Var var _, Val val]  <- exps 
    128     = (combineEnv id var val, Val VUndef) 
    129     | name `isInfix` "=>" 
    130     , [keyExp, valExp]  <- exps 
    131     , key               <- evalEnv env keyExp 
    132     , val               <- evalEnv env valExp 
    133     = retVal $ VPair key val 
    134     | name `isInfix` "," 
    135     = retVal $ VList $ concatMap (vCast . evalEnv env{ cxt = "List" }) exps 
    136     | name `isInfix` "[]" 
    137     , (listExp:rangeExp:errs)   <- exps 
    138     , list      <- evalEnv env{ cxt = "List" } listExp 
    139     , range     <- evalEnv env{ cxt = "List" } rangeExp 
    140     , slice     <- unfoldr (doSlice errs $ vCast list) (map vCast $ vCast range) 
    141     = retVal $ VList slice 
     145doReduce env@Env{ envContext = cxt } exp@(Syn name exps) = case name of 
     146    ";" -> do 
     147        let (lead, final) = buildStatements exps 
     148        vals <- mapM (evalEnvWithContext "Any") lead 
     149        -- collect IO values from vals? 
     150        retVal =<< evalEnv final 
     151    ":=" -> do 
     152        let [Var var _, exp] = exps 
     153        val     <- evalEnv exp 
     154        addSym [Symbol SMy var val] -- XXX scope 
     155        retVal val 
     156    "::=" -> do -- XXX wrong 
     157        let [Var var _, exp] = exps 
     158        val     <- evalEnv exp 
     159        addSym [Symbol SMy var val] -- XXX scope 
     160        retVal VUndef 
     161    "=>" -> do 
     162        let [keyExp, valExp] = exps 
     163        key     <- evalEnv keyExp 
     164        val     <- evalEnv valExp 
     165        retVal $ VPair key val 
     166    "," -> do 
     167        vals    <- mapM (evalEnvWithContext "List") exps 
     168        retVal $ VList vals 
     169    "[]" -> do 
     170        let (listExp:rangeExp:errs) = exps 
     171        list    <- evalEnvWithContext "List" listExp 
     172        range   <- evalEnvWithContext "List" rangeExp 
     173        let slice = unfoldr (doSlice errs $ vCast list) (map vCast $ vCast range) 
     174        retVal $ VList slice 
     175    "gather" -> do 
     176        val     <- evalEnvWithContext "List" exp 
     177        -- ignore val 
     178        retVal val 
     179    _ -> do 
     180        retVal $ VError "Unknown syntactic construct" exp 
    142181    where 
    143182    doSlice :: [Exp] -> [Val] -> [VInt] -> Maybe (Val, [VInt]) 
    … …  
    152191    buildStatements exps 
    153192        | ((Syn name' exps'):rest)  <- exps 
    154         , name' `isInfix` ";" 
     193        , name' == ";" 
    155194        = buildStatements (exps' ++ rest) 
    156195        | (global, local)   <- partition isGlobalExp exps 
    157196        , stmts             <- global ++ local 
    158197        = (init stmts, last stmts) 
    159     runStatement :: Cxt -> (Env, Exp) -> Exp -> (Env, Exp) 
    160     runStatement cxt (env, (Val val)) exp 
    161         | VError _ _    <- val 
    162         = (env, Val val) 
    163         | NonTerm _     <- exp 
    164         = (env, Val val) 
    165         | (fenv, exp)   <- reduce env{ cxt = cxt } exp 
    166         = (fenv env, exp) 
    167         | otherwise 
    168         = (env, Val $ VError "Unterminated statement" exp) 
    169     combineEnv f var val env = (f env) `addSym` [(var, val)] 
    170     isInfix name s = name == "&infix:" ++ s 
    171  
    172 reduce env@Env{ cxt = cxt, cls = cls } exp@(App name invs args) 
    173     | Just sub <- findSub name 
    174     = applySub sub invs args 
    175     | otherwise 
    176     = retVal $ VError ("No compatible subroutine found: " ++ name) exp 
     198 
     199doReduce env@Env{ envClasses = cls, envContext = cxt, envPad = pad } exp@(App name invs args) = do 
     200    case findSub name of 
     201        Just sub    -> applySub sub invs args 
     202        otherwise   -> retVal $ VError ("No compatible subroutine found: " ++ name) exp 
    177203    where 
    178204    applySub sub invs args 
    … …  
    186212        | Sub{ subAssoc = "list", subParams = (p:_) }   <- sub 
    187213        , null invs 
    188         = apply env sub{ subParams = (length args) `replicate` p } [] args 
     214        = apply sub{ subParams = (length args) `replicate` p } [] args 
    189215        -- chain-associativity 
    190216        | Sub{ subAssoc = "chain", subFun = fun, subParams = prm }   <- sub 
    … …  
    197223        | Sub{ subAssoc = "chain", subParams = (p:_) }   <- sub 
    198224        , null invs 
    199         = apply env sub{ subParams = (length args) `replicate` p } [] args -- XXX Wrong 
     225        = apply sub{ subParams = (length args) `replicate` p } [] args -- XXX Wrong 
    200226        -- normal application 
    201227        | otherwise 
    202         = apply env sub invs args 
     228        = apply sub invs args 
    203229    findSub name 
    204230        | ((_, sub):_) <- sort (subs name)  = Just sub 
    … …  
    208234        , fromJust fun 
    209235        ) 
    210         | ((n, val), order) <- sym env `zip` [0..] 
     236        | ((Symbol _ n val), order) <- concat pad `zip` [0..] 
    211237        , let sub@(Sub{ subType = subT, subReturns = ret, subParams = prms }) = vCast val 
    212         , n == name || n == toGlobal name 
     238        , (n ==) `any` [name, toGlobal name] 
    213239        , let isGlobal = '*' `elem` n 
    214240        , let fun = arityMatch sub (invs ++ args) -- XXX Wrong 
    … …  
    224250    deltaFromScalar x       = deltaType cls x "Scalar" 
    225251 
    226 reduce env (Parens exp) = reduce env exp 
    227 reduce env other = (id, other) 
     252doReduce _ (Parens exp) = reduce exp 
     253doReduce _ other = return other 
    228254 
    229255arityMatch sub@Sub{ subAssoc = assoc, subParams = prms } args 

  • src/Internals.hs

    r19 r25  
    1515 
    1616module Internals ( 
     17    module Cont, 
     18    module Data.Dynamic, 
     19    module Data.Unique, 
    1720    module System.Environment, 
    1821    module System.Random, 
    1922    module System.IO, 
    2023    module System.IO.Unsafe, 
     24    module Control.Monad.RWS, 
    2125    module Control.Monad.Error, 
    2226    module Data.Bits, 
    … …  
    3842) where 
    3943 
     44import Cont 
     45import Data.Dynamic 
    4046import System.Environment 
    4147import System.Random 
    4248import System.IO hiding (try) 
    4349import System.IO.Unsafe 
    44 import Control.Monad.Error 
     50import Control.Monad.RWS 
     51import Control.Monad.Error (MonadError(..)) 
    4552import qualified System.IO (try) 
    46 import Data.Bits 
     53import Data.Bits hiding (shift) 
    4754import Data.Maybe 
    4855import Data.Either 
    4956import Data.List hiding (intersect, union) 
     57import Data.Unique 
    5058import Data.Ratio 
    5159import Data.Word 
    … …  
    5765import Data.Tree 
    5866import Debug.Trace 
    59 import Text.ParserCombinators.Parsec 
     67import Text.ParserCombinators.Parsec hiding (parse) 
    6068import Text.ParserCombinators.Parsec.Expr 
    6169import Text.ParserCombinators.Parsec.Error hiding (ParseError, errorPos) 
    6270import Text.ParserCombinators.Parsec.Language 
     71 
     72-- Instances. 
     73instance Show Unique where 
     74    show = show . hashUnique 
     75instance Show (a -> b) where 
     76    show f = "sub { ... }" 
     77instance Eq (a -> b) where 
     78    _ == _ = False 

  • src/Junc.hs

    r18 r25  
    1616opJuncAll = opJunc JAll 
    1717opJuncAny = opJunc JAny 
    18 opJuncOne vals 
    19     | length (nub vals) == length vals 
    20     = VJunc JOne $ mkSet vals 
    21     | otherwise 
    22     = VJunc JOne emptySet 
     18opJuncOne args = VJunc (Junc JOne dups vals) 
     19    where 
     20    vals = mkSet [ v | [v] <- groups ] 
     21    dups = mkSet [ v | (v:_:_) <- groups ] 
     22    groups = group $ sort args 
    2323 
    2424opJunc :: JuncType -> [Val] -> Val 
    25 opJunc j vals = VJunc j $ joined `union` mkSet vs 
     25opJunc t vals = VJunc $ Junc t emptySet (joined `union` mkSet vs) 
    2626    where 
    27     joined = unionManySets $ map juncValues js 
     27    joined = unionManySets $ map (\(VJunc s) -> juncSet s) js 
    2828    (js, vs) = partition sameType vals 
    29     sameType (VJunc j' _)   = (j == j') 
    30     sameType _              = False 
     29    sameType (VJunc (Junc t' _ _))  = t == t' 
     30    sameType _                      = False 
    3131 
    32 juncValues :: Val -> VJunc 
    33 juncValues (VJunc _ l)  = l 
    34 juncValues _            = emptySet 
    35  
    36 juncType :: Val -> Maybe (JuncType, VJunc) 
    37 juncType v 
    38     | VJunc j l <- v 
    39     = Just (j, l) 
     32juncTypeIs :: Val -> [JuncType] -> Maybe VJunc 
     33juncTypeIs v ts 
     34    | (VJunc j) <- v 
     35    , juncType j `elem` ts 
     36    = Just j 
    4037    | otherwise 
    4138    = Nothing 
    4239 
    43 juncTypeIs :: Val -> [JuncType] -> Maybe (JuncType, VJunc) 
    44 juncTypeIs v js 
    45     | Just (j, l) <- juncType v 
    46     , j `elem` js 
    47     = Just (j, l) 
    48     | otherwise 
    49     = Nothing 
    50  
     40mergeJunc j ds vs 
     41    | j == JAny = Junc j (mkSet ds) (mkSet vs) 
     42    | j == JOne = Junc j dups vals 
     43    where 
     44    vals = mkSet [ v | [v] <- group $ sort vs ] 
     45    dups = mkSet (ds ++ [ v | (v:_:_) <- group $ sort (vs ++ ds) ]) 
    5146 
    5247juncApply f args 
    53     | (before, (ApplyArg name (VJunc j vs) coll):after) <- break isTotalJunc args 
    54     = VJunc j $ mapSet (\v -> juncApply f (before ++ ((ApplyArg name v coll):after))) vs 
    55     | (before, (ApplyArg name (VJunc j vs) coll):after) <- break isPartialJunc args 
    56     = VJunc j $ mapSet (\v -> juncApply f (before ++ ((ApplyArg name v coll):after))) vs 
     48    | this@(_, (pivot:_)) <- break isTotalJunc args 
     49    , VJunc (Junc j dups vals) <- argValue pivot 
     50    = VJunc $ Junc j dups $ appSet this vals 
     51    | this@(_, (pivot:_)) <- break isPartialJunc args 
     52    , VJunc (Junc j dups vals) <- argValue pivot 
     53    = VJunc $ mergeJunc j (appList this dups) (appList this vals) 
    5754    | (val:_) <- [ val | (ApplyArg _ val@(VError _ _) _) <- args ] 
    5855    = val 
    5956    | otherwise 
    6057    = f args 
     58    where 
     59    appSet x y = mkSet $ appList x y 
     60    appList (before, (ApplyArg name _ coll):after) vs 
     61        = map (\v -> juncApply f (before ++ ((ApplyArg name v coll):after))) $ setToList vs 
    6162 
    62 isTotalJunc (ApplyArg _ (VJunc JAll _) b)   = not b 
    63 isTotalJunc (ApplyArg _ (VJunc JNone _) b)  = not b 
    64 isTotalJunc _                   = False 
     63isTotalJunc arg 
     64    | (ApplyArg _ (VJunc j) b) <- arg 
     65    , (juncType j ==) `any` [JAll, JNone] 
     66    = not b 
     67    | otherwise 
     68    = False 
    6569 
    66 isPartialJunc (ApplyArg _ (VJunc JOne _) b) = not b 
    67 isPartialJunc (ApplyArg _ (VJunc JAny _) b) = not b 
    68 isPartialJunc _                 = False 
    69  
     70isPartialJunc arg 
     71    | (ApplyArg _ (VJunc j) b) <- arg 
     72    , (juncType j ==) `any` [JOne, JAny] 
     73    = not b 
     74    | otherwise 
     75    = False 
    7076 
    7177data ApplyArg = ApplyArg 

  • src/Lexer.hs

    r9 r25  
    1212modu