diff --git a/Egison.hs b/Egison.hs --- a/Egison.hs +++ b/Egison.hs @@ -11,7 +11,7 @@ import Paths_egison welcomeMsg :: String -welcomeMsg = "Egison, version 1.0.4 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" +welcomeMsg = "Egison, version 1.0.5 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" byebyeMsg :: String byebyeMsg = "\nLeaving Egison.\nByebye. See you again! (^^)/\n" @@ -559,16 +559,16 @@ return (Test expr) <|> do try (string "execute") return Execute - <|> do try (string "load") + <|> do try (string "load-file") spaces filename <- stringLiteral spaces - return (Load filename) - <|> do try (string "load-file") + return (LoadFile filename) + <|> do try (string "load") spaces filename <- stringLiteral spaces - return (LoadFile filename) + return (Load filename) ) "top expression" parseExpression :: Parser Expression @@ -1186,7 +1186,7 @@ evalMatchExp :: Environment -> ObjectRef -> ObjectRef -> [MatchClause] -> IOThrowsError Value evalMatchExp env typObjRef tgtObjRef (MatchClause pat expr:rest) = do patObjRef <- liftIO (makeClosure env pat) - matchs <- patternMatch [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])] + matchs <- patternMatch1 [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])] case matchs of [] -> evalMatchExp env typObjRef tgtObjRef rest (frame:_) -> do objRef <- liftIO (makeClosure (frame:env) expr) @@ -1211,6 +1211,89 @@ -- -- Pattern Match -- +patternMatch1 :: [MState] -> IOThrowsError [Frame] +patternMatch1 [] = return [] +patternMatch1 ((MState frame []):_) = do + return [frame] +patternMatch1 ((MState frame ((MAtom (PClosure bf patObjRef) tgtObjRef typObjRef):atoms)):states) = do + patObj <- liftIO (readIORef patObjRef) + case patObj of + Value (World _) -> throwError (Default "patternMatch1: not a pattern") + Value (Character _) -> throwError (Default "patternMatch1: not a pattern") + Value (Integer _) -> throwError (Default "patternMatch1: not a pattern") + Value (Double _) -> throwError (Default "patternMatch1: not a pattern") + Value (Collection _) -> throwError (Default "patternMatch1: not a pattern") + Value (Function _ _ _) -> throwError (Default "patternMatch1: not a pattern") + Value (Type _) -> throwError (Default "patternMatch1: not a pattern") + Value (DestructorFunction _) -> throwError (Default "patternMatch1: not a pattern") + Value (BuiltinFunction _) -> throwError (Default "patternMatch1: not a pattern") + Value WildCard -> patternMatch1 ((MState frame atoms):states) + Value (PatVar var nums) -> + do typVal <- cEval1 typObjRef + case typVal of + Type tf -> let mObjRef = getValueFromFrame tf ("var-match",[]) in + case mObjRef of + Nothing -> throwError (Default "no method in type: var-match") + Just fnObjRef -> + do ret <- cApply fnObjRef [tgtObjRef] + objRefs <- collectionToObjRefList ret + patternMatch1 ((map (\objRef -> (MState (((var,nums),objRef):frame) + (map (\(MAtom (PClosure bf2 pat) tgt typ) -> (MAtom (PClosure (((var,nums),objRef):bf2) pat) tgt typ)) + atoms))) + objRefs) ++ states) + _ -> throwError (Default "patternMatch1: patVar not type") + Value (Tuple pats) -> + do tgts <- tupleToObjRefList tgtObjRef + typs <- tupleToObjRefList typObjRef + patternMatch1 ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states) + Value (InductiveData con pats) -> + do typVal <- cEval1 typObjRef + case typVal of + Type tf -> let mObjRef = getValueFromFrame tf ("inductive-match",[]) in + case mObjRef of + Nothing -> throwError (Default "no method in type: var-match") + Just fnObjRef -> + do fnObj <- cEval1 fnObjRef + case fnObj of + DestructorFunction deconInfo -> + do indRet <- inductiveMatch deconInfo con tgtObjRef + case indRet of + (nTypObjRef, nTgtsObjRef) -> + do inTypObjRefs <- tupleToObjRefList nTypObjRef + inTgtsRefs <- collectionObjToObjRefList nTgtsObjRef + inTgtObjRefss <- tupleObjRefListToListOfList inTgtsRefs + patternMatch1 ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) + pats inTgtObjRefs inTypObjRefs) ++ atoms))) + inTgtObjRefss) ++ states) + _ -> throwError (Default "patternMatch1: inductive-match is not destructor") + Value (PredPat predName pats) -> + do typVal <- cEval1 typObjRef + case typVal of + Type tf -> let mObjRef = getValueFromFrame tf (predName,[]) in + case mObjRef of + Nothing -> throwError (Default "no method in type: var-match") + Just fnObjRef -> + do ret <- cApply fnObjRef (pats ++ [tgtObjRef]) + case ret of + (InductiveData "true" []) -> patternMatch1 ((MState frame atoms):states) + (InductiveData "false" []) -> patternMatch1 states + _ -> throwError (Default "patternMatch1: return value of pred-pattern is not boolean") + Value (AndPat pats) -> + patternMatch1 ((MState frame ((map (\pat -> (MAtom (PClosure bf pat) tgtObjRef typObjRef)) pats) ++ atoms)):states) + Value (OrPat pats) -> + patternMatch1 ((map (\pat -> (MState frame ((MAtom (PClosure bf pat) tgtObjRef typObjRef):atoms))) + pats) ++ states) + Value (CutPat pat) -> + do retFrames <- patternMatch1 [(MState frame ((MAtom (PClosure bf pat) tgtObjRef typObjRef):atoms))] + case retFrames of + [] -> return [] + _ -> do restFrames <- patternMatch1 states + return (retFrames ++ restFrames) + Closure env expr -> + do patObj2 <- eval1 (bf:env) expr + patObjRef2 <- liftIO (newIORef (Value patObj2)) + patternMatch1 ((MState frame ((MAtom (PClosure [] patObjRef2) tgtObjRef typObjRef):atoms)):states) + patternMatch :: [MState] -> IOThrowsError [Frame] patternMatch [] = return [] patternMatch ((MState frame []):rest) = do diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 1.0.4 +Version: 1.0.5 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison