diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 2.1.16 +Version: 2.2.0 Synopsis: An Interpreter for the Programming Language Egison Description: An interpreter for the programming language Egison. A feature of Egison is the strong pattern match facility. diff --git a/hs-src/Language/Egison/Core.hs b/hs-src/Language/Egison/Core.hs --- a/hs-src/Language/Egison/Core.hs +++ b/hs-src/Language/Egison/Core.hs @@ -177,6 +177,9 @@ _ -> throwError $ Default "cEval1: cannot reach here!") numVals return $ Value $ PatVar name nums +cEval1 (Closure env (ValuePatExpr expr)) = do + objRef <- liftIO $ makeClosure env expr + return $ Value $ ValuePat objRef cEval1 (Closure env (PredPatExpr predName argExprs)) = do argObjRefs <- liftIO $ mapM (makeClosure env) argExprs return $ Value $ PredPat predName argObjRefs @@ -226,11 +229,11 @@ destructInfo <- liftIO $ makeDestructInfo destructInfoExpr return $ Value $ Destructor destructInfo where makeDestructInfo [] = return [] - makeDestructInfo ((cons, typExpr, pmcs):rest) = do + makeDestructInfo ((pppat, typExpr, pmcs):rest) = do typObjRef <- liftIO $ makeClosure env typExpr let epmcs = map (\(ppat, body) -> (env, ppat, body)) pmcs retRest <- makeDestructInfo rest - return ((cons, typObjRef, epmcs):retRest) + return ((pppat, typObjRef, epmcs):retRest) cEval1 (Closure env (MatchAllExpr tgtExpr typExpr (patExpr, body))) = do patObjRef <- liftIO $ makeClosure env patExpr tgtObjRef <- liftIO $ makeClosure env tgtExpr @@ -410,7 +413,7 @@ atoms))) objRefs) ++ states _ -> throwError $ Default "patternMatch: second argument of match expressions must be type" - Intermidiate (IInductiveData con patObjRefs) -> do + Value (ValuePat _) -> do typObj <- cRefEval1 typObjRef case typObj of Value (Type tf) -> @@ -421,18 +424,15 @@ do fnObj <- cRefEval1 fnObjRef case fnObj of Value (Destructor deconInfo) -> do - indRet <- inductiveMatch deconInfo con tgtObjRef + indRet <- inductiveMatch deconInfo patObjRef tgtObjRef case indRet of - (nTypObjRef, nTgtsObjRef) -> do - inTypObjRefs <- tupleToObjRefList nTypObjRef - inTgtsRefs <- collectionToObjRefList nTgtsObjRef - inTgtObjRefss <- mapM tupleToObjRefList inTgtsRefs + (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) - (zip3 patObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms))) + (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms))) inTgtObjRefss) ++ states) + _ -> throwError $ Default "patternMatch: inductive-match is not destructor" _ -> throwError $ Default "patternMatch: second argument of match expressions must be type" - Value (InductiveData con pats) -> do - patObjRefs <- liftIO $ mapM (newIORef . Value) pats + Value (InductiveData _ _) -> do -- same with ValuePat typObj <- cRefEval1 typObjRef case typObj of Value (Type tf) -> @@ -443,16 +443,33 @@ do fnObj <- cRefEval1 fnObjRef case fnObj of Value (Destructor deconInfo) -> do - indRet <- inductiveMatch deconInfo con tgtObjRef + indRet <- inductiveMatch deconInfo patObjRef tgtObjRef case indRet of - (nTypObjRef, nTgtsObjRef) -> do - inTypObjRefs <- tupleToObjRefList nTypObjRef - inTgtsRefs <- collectionToObjRefList nTgtsObjRef - inTgtObjRefss <- mapM tupleToObjRefList inTgtsRefs - patternMatch flag $ (map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> MAtom (PClosure bf pat) inTgtObjRef inTypObjRef) - (zip3 patObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms))) - inTgtObjRefss) ++ states + (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do + patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) + (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms))) + inTgtObjRefss) ++ states) + _ -> throwError $ Default "patternMatch: inductive-match is not destructor" _ -> throwError $ Default "patternMatch: second argument of match expressions must be type" + Intermidiate (IInductiveData _ _) -> do -- same with ValuePat + typObj <- cRefEval1 typObjRef + case typObj of + Value (Type tf) -> + let mObjRef = Data.Map.lookup ("inductive-match",[]) tf in + case mObjRef of + Nothing -> throwError (Default "no method in type: inductive-match") + Just fnObjRef -> + do fnObj <- cRefEval1 fnObjRef + case fnObj of + Value (Destructor deconInfo) -> do + indRet <- inductiveMatch deconInfo patObjRef tgtObjRef + case indRet of + (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do + patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) + (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms))) + inTgtObjRefss) ++ states) + _ -> throwError $ Default "patternMatch: inductive-match is not destructor" + _ -> throwError $ Default "patternMatch: second argument of match expressions must be type" Intermidiate (ITuple pats) -> do patObjRefs <- innerRefsToObjRefList pats tgtObjRefs <- tupleToObjRefList tgtObjRef @@ -498,25 +515,64 @@ MOne -> return retFrames _ -> throwError $ Default $ "invalid pattern: " ++ show patObj -inductiveMatch :: DestructInfo -> String -> ObjectRef -> IOThrowsError (ObjectRef,ObjectRef) -inductiveMatch [] _ _ = throwError (Default "inductiveMatch: not matched any clauses") -inductiveMatch ((con,_,[]):rest) pcon tgtObjRefRef = - if (con == pcon) - then throwError (Default "inductiveMatch: not matched any clauses") - else inductiveMatch rest pcon tgtObjRefRef -inductiveMatch ((con,typObjRef,((env,ppat,expr):cls)):rest) pcon tgtObjRefRef = do - if (con == pcon) - then do mPpmRet <- primitivePatternMatch ppat tgtObjRefRef - - case mPpmRet of - Nothing -> inductiveMatch ((con,typObjRef,cls):rest) pcon tgtObjRefRef - Just ppmRet -> do - newEnv <- liftIO $ extendEnv env ppmRet - ret <- liftIO $ makeClosure newEnv expr - return (typObjRef,ret) - else inductiveMatch rest pcon tgtObjRefRef +inductiveMatch :: DestructInfo -> ObjectRef -> ObjectRef -> IOThrowsError ([ObjectRef], [ObjectRef], [[ObjectRef]]) +inductiveMatch [] _ _ = throwError $ Default "inductiveMatch: not matched any primitive pattern clauses" +inductiveMatch ((pppat, typObjRef, pclss):rest) patObjRef tgtObjRef = do + mRet <- primitivePatPatternMatch pppat patObjRef + case mRet of + Nothing -> inductiveMatch rest patObjRef tgtObjRef + Just (patObjRefs, frame) -> do + mPpmRet <- helper pclss + case mPpmRet of + Nothing -> throwError $ Default "inductiveMatch: not matched any primitive clauses" + Just tgtObjRefs -> do + typObjRefs <- tupleToObjRefList typObjRef + return (typObjRefs, patObjRefs, tgtObjRefs) + where helper [] = return Nothing + helper ((env, ppat, expr):pclss2) = do + mPpmRet <- primitivePatternMatch ppat tgtObjRef + case mPpmRet of + Nothing -> helper pclss2 + Just ppmRet -> do + newEnv <- liftIO $ extendEnv env (ppmRet ++ frame) + retObjRef <- liftIO $ makeClosure newEnv expr + tgtObjRefs <- collectionToObjRefList retObjRef + tgtObjRefss <- mapM tupleToObjRefList tgtObjRefs + return $ Just tgtObjRefss +primitivePatPatternMatch :: PrimitivePatPattern -> ObjectRef -> IOThrowsError (Maybe ([ObjectRef], FrameList)) +primitivePatPatternMatch PPWildCard patObjRef = return $ Just ([patObjRef], []) +primitivePatPatternMatch (PPValuePat name) patObjRef = do + patObj <- cRefEval1 patObjRef + case patObj of + Value (ValuePat objRef) -> return $ Just ([], [((name, []), objRef)]) + _ -> return $ Nothing +primitivePatPatternMatch (PPInductivePat ppcons pppats) patObjRef = do + patObj <- cRefEval1 patObjRef + case patObj of + Intermidiate (IInductiveData pcon patObjRefs) -> + if ppcons == pcon + then primitivePatPatternMatchList pppats patObjRefs + else return Nothing + Value (InductiveData pcon patVals) -> do + patObjRefs <- liftIO $ mapM (newIORef . Value) patVals + if ppcons == pcon + then primitivePatPatternMatchList pppats patObjRefs + else return Nothing + _ -> return $ Nothing +primitivePatPatternMatchList :: [PrimitivePatPattern] -> [ObjectRef] -> IOThrowsError (Maybe ([ObjectRef], FrameList)) +primitivePatPatternMatchList [] [] = return $ Just ([], []) +primitivePatPatternMatchList (pppat:pppats) (patObjRef:patObjRefs) = do + mRet <- primitivePatPatternMatch pppat patObjRef + case mRet of + Nothing -> return Nothing + Just (retPatObjRefs, retFrame) -> do + mRetRest <- primitivePatPatternMatchList pppats patObjRefs + case mRetRest of + Nothing -> return Nothing + Just (retRestPatObjRefs, retRestFrame) -> return $ Just (retPatObjRefs ++ retRestPatObjRefs, retFrame ++ retRestFrame) + primitivePatternMatch :: PrimitivePattern -> ObjectRef -> IOThrowsError (Maybe FrameList) primitivePatternMatch (PPatBool bool) objRef = do val <- cRefEval objRef diff --git a/hs-src/Language/Egison/Parser.hs b/hs-src/Language/Egison/Parser.hs --- a/hs-src/Language/Egison/Parser.hs +++ b/hs-src/Language/Egison/Parser.hs @@ -291,7 +291,7 @@ parseValuePat :: Parser EgisonExpr parseValuePat = do char ',' expr <- parseExpr - return $ PredPatExpr "=" [expr] + return $ ValuePatExpr expr parseInnerExpr :: Parser InnerExpr parseInnerExpr = do expr <- parseExpr @@ -322,17 +322,29 @@ parseDestructInfoExpr :: Parser DestructInfoExpr parseDestructInfoExpr = braces (sepEndBy parseDestructClause whiteSpace) -parseDestructClause :: Parser (String, EgisonExpr, [(PrimitivePattern, EgisonExpr)]) -parseDestructClause = brackets (do patCons <- lexeme identifier +parseDestructClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitivePattern, EgisonExpr)]) +parseDestructClause = brackets (do pppat <- lexeme parsePrimitivePatPattern typExpr <- lexeme parseExpr dc2s <- lexeme (braces (sepEndBy parseDestructClause2 whiteSpace)) - return (patCons, typExpr, dc2s)) + return (pppat, typExpr, dc2s)) parseDestructClause2 :: Parser (PrimitivePattern, EgisonExpr) parseDestructClause2 = brackets (do datPat <- lexeme parsePrimitivePattern expr <- lexeme parseExpr return (datPat, expr)) +parsePrimitivePatPattern :: Parser PrimitivePatPattern +parsePrimitivePatPattern = + do char '_' + return PPWildCard + <|> do char ',' + char '$' + name <- lexeme identifier + return (PPValuePat name) + <|> angles (do c <- lexeme identifier + ps <- sepEndBy parsePrimitivePatPattern whiteSpace + return (PPInductivePat c ps)) + parsePrimitivePattern :: Parser PrimitivePattern parsePrimitivePattern = do char '_' diff --git a/hs-src/Language/Egison/Types.hs b/hs-src/Language/Egison/Types.hs --- a/hs-src/Language/Egison/Types.hs +++ b/hs-src/Language/Egison/Types.hs @@ -89,6 +89,7 @@ | VarOmitExpr EgisonExpr | PatVarExpr String [EgisonExpr] | WildCardExpr + | ValuePatExpr EgisonExpr | CutPatExpr EgisonExpr | NotPatExpr EgisonExpr | AndPatExpr [EgisonExpr] @@ -117,6 +118,11 @@ type MatchClause = (EgisonExpr, EgisonExpr) +data PrimitivePatPattern = PPWildCard + | PPValuePat String + | PPInductivePat String [PrimitivePatPattern] + deriving (Show) + data PrimitivePattern = PWildCard | PPatVar String | PInductivePat String [PrimitivePattern] @@ -137,7 +143,7 @@ type RecursiveBindings = [(String, EgisonExpr)] -type DestructInfoExpr = [(String, EgisonExpr, [(PrimitivePattern, EgisonExpr)])] +type DestructInfoExpr = [(PrimitivePatPattern, EgisonExpr, [(PrimitivePattern, EgisonExpr)])] -- -- Value @@ -157,6 +163,7 @@ | Float Double | WildCard | PatVar String [Integer] + | ValuePat ObjectRef | PredPat String [ObjectRef] | CutPat ObjectRef | NotPat ObjectRef @@ -216,7 +223,7 @@ data InnerValRef = IElement ObjectRef | ISubCollection ObjectRef -type DestructInfo = [(String, ObjectRef, [(Env, PrimitivePattern, EgisonExpr)])] +type DestructInfo = [(PrimitivePatPattern, ObjectRef, [(Env, PrimitivePattern, EgisonExpr)])] -- -- Internal Data @@ -311,6 +318,7 @@ showExpr (MacroVarExpr name nums) = "%" ++ name ++ unwordsNumExprs nums showExpr (PatVarExpr name nums) = "$" ++ name ++ unwordsNumExprs nums showExpr WildCardExpr = "_" +showExpr (ValuePatExpr expr) = "," ++ showExpr expr showExpr (PatVarOmitExpr pvar) = "$~" ++ showExpr pvar showExpr (VarOmitExpr pvar) = "~" ++ showExpr pvar showExpr (CutPatExpr _) = "#" @@ -399,6 +407,7 @@ showVal (Float contents) = show contents showVal WildCard = "_" showVal (PatVar name nums) = "$" ++ name ++ unwordsNums nums +showVal (ValuePat _) = "#" showVal (CutPat _) = "#" showVal (NotPat _) = "#" showVal (AndPat _) = "#" @@ -411,6 +420,7 @@ showVal (Type _) = "#" showVal (Destructor _) = "#" showVal (Func _ _ _) = "(lambda [" ++ "..." ++ "] ...)" +showVal (Macro _ _ ) = "(macro [" ++ "..." ++ "] ...)" showVal (PrimitiveFunc _) = "#" showVal (IOFunc _) = "#" showVal (Port _ _) = "#" diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -9,20 +9,14 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor - {[true [] + {[ [] {[ {[]}] [#t {[]}] [_ {}]}] - [false [] + [ [] {[ {[]}] [#f {[]}] - [_ {}]}]})] - [$= - (lambda [$val $tgt] - (match [val tgt] [Bool Bool] - {[[ ] #t] - [[ ] #t] - [[_ _] #f]}))]})) + [_ {}]}]})]})) (define $or (lambda [$b1 $b2] @@ -57,19 +51,12 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor - {[less [] + {[ [] {[ {[]}] [_ {}]}] - [equal [] + [ [] {[ {[]}] [_ {}]}] - [greater [] + [ [] {[ {[]}] - [_ {}]}]})] - [$= - (lambda [$val $tgt] - (match [val tgt] [Order Order] - {[[ ] #t] - [[ ] #t] - [[ ] #t] - [[_ _] #f]}))]})) + [_ {}]}]})]})) diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -8,16 +8,27 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor - {[nil [] + {[,$val [] + {[$tgt (if (= tgt val) + {[]} + {})]}] + [ [] {[{} {[]}] [_ {}]}] - [cons [a (List a)] + [ [a (List a)] {[{$x .$xs} {[x xs]}] [_ {}]}] - [snoc [a (List a)] + [ [a (List a)] {[{.$xs $x} {[x xs]}] [_ {}]}] - [join [(List a) (List a)] + [ [(List a)] + {[$tgt (letrec {[$helper (lambda [$pxs $tgt] + (match [pxs tgt] [(List a) (List a)] + {[[ _] {tgt}] + [[ ] (helper xs ys)] + [[_ _] {}]}))]} + (helper pxs tgt))]}] + [ [(List a) (List a)] {[$tgt (letrec {[$loop-fn (lambda [$ts] (match ts (List a) @@ -27,7 +38,7 @@ @(map (lambda [$as $bs] [{x @as} bs]) (loop-fn xs))}]}))]} (loop-fn tgt))]}] - [nioj [(List a) (List a)] + [ [(List a) (List a)] {[$tgt (letrec {[$loop-fn (lambda [$ts] (match ts (List a) @@ -193,13 +204,21 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor - {[nil [] + {[,$val [] + {[$tgt (if (= tgt val) + {[]} + {})]}] + [ [] {[{} {[]}] [_ {}]}] - [cons [a (Multiset a)] + [ [(Multiset a)] + {[$tgt {((remove a) tgt px)}]}] + [ [a (Multiset a)] {[$tgt (map (lambda [$t] [t ((remove a) tgt t)]) ((unique a) tgt))]}] - [join [(Multiset a) (Multiset a)] + [ [(Multiset a)] + {[$tgt {((remove-collection a) tgt pxs)}]}] + [ [(Multiset a) (Multiset a)] {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)]) (subcollections tgt))]}]})] [$= (lambda [$val $tgt] @@ -214,14 +233,18 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor - {[nil [] + {[,$val [] + {[$tgt (if (= tgt val) + {[]} + {})]}] + [ [] {[{} {[]}] [_ {}]}] - [cons [a (Set a)] + [ [a (Set a)] {[$tgt (let {[$tgt2 ((unique a) tgt)]} {@(match-all tgt2 (Multiset a) [ [x xs]]) @(match-all tgt2 (Multiset a) [ [x {@xs x}]])})]}] - [join [(Set a) (Set a)] + [ [(Set a) (Set a)] {[$tgt (let {[$tgt2 ((unique a) tgt)]} (concat (map (lambda [$xs $ys] (map (lambda [$sxs] [xs {@ys @sxs}]) (subcollections xs))) diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -1,6 +1,12 @@ (define $Integer (type {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (destructor + {[,$n [] + {[$tgt (if (= tgt n) + {[]} + {})]}]})] [$= (lambda [$val $tgt] (eq-n? val tgt))]})) (define $compare-integer @@ -14,6 +20,12 @@ (define $Double (type {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (destructor + {[,$d [] + {[$tgt (if (= tgt d) + {[]} + {})]}]})] [$= (lambda [$val $tgt] (eq-f? val tgt))]})) (define $compare-float @@ -29,10 +41,10 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor - {[o [] + {[ [] {[0 {[]}] [_ {}]}] - [s Nat + [ Nat {[$tgt (match (compare-integer tgt 0) Order {[ {(- tgt 1)}] [_ {}]})]}]})] diff --git a/lib/graph.egi b/lib/graph.egi --- a/lib/graph.egi +++ b/lib/graph.egi @@ -5,7 +5,11 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor - {[node [Node (Multiset Node) (Multiset Node)] + {[,$val [] + {[$tgt (if (= tgt val) + {[]} + {})]}] + [ [Node (Multiset Node) (Multiset Node)] {[ {[n in out]}]}]})] [$= (lambda [$val $tgt] (match [val tgt] [NodeInfo NodeInfo] diff --git a/lib/poker-hands.egi b/lib/poker-hands.egi --- a/lib/poker-hands.egi +++ b/lib/poker-hands.egi @@ -3,16 +3,20 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor - {[spade [] + {[,$suit [] + {[$tgt (if (= tgt suit) + {[]} + {})]}] + [ [] {[ {[]}] [_ {}]}] - [heart [] + [ [] {[ {[]}] [_ {}]}] - [club [] + [ [] {[ {[]}] [_ {}]}] - [diamond [] + [ [] {[ {[]}] [_ {}]}]})] [$= @@ -28,6 +32,12 @@ (lambda [$m] (type {[$var-match (lambda [$tgt] {(mod tgt m)})] + [$inductive-match + (destructor + {[,$n [] + {[$tgt (if (= tgt n) + {[]} + {})]}]})] [$= (lambda [$val $tgt] (eq? (mod val m) (mod tgt m)))]}))) (define $Card @@ -35,7 +45,11 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor - {[card [Suit (Mod 13)] + {[,$card [] + {[$tgt (if (= tgt card) + {[]} + {})]}] + [ [Suit (Mod 13)] {[ {[s n]}]}]})] [$= (lambda [$val $tgt] (match [val tgt] [Card Card]