egison 1.0.4 → 1.0.5
raw patch · 2 files changed
+90/−7 lines, 2 files
Files
- Egison.hs +89/−6
- egison.cabal +1/−1
Egison.hs view
@@ -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
egison.cabal view
@@ -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