├── Setup.hs ├── examples ├── Mult.hs ├── Sum.hs ├── Maybe.hs ├── Addn.hs ├── Sumif.hs ├── Partial.hs ├── Sumguards.hs ├── Factorial.hs ├── Map.hs └── Listcomp.hs ├── src ├── ScTypes.hs ├── TypeCheck.hs ├── NormalFormReducer.hs ├── PrepStage.hs ├── DefinitionGetter.hs ├── Main.hs ├── Tools.hs ├── FormalActualMap.hs └── EvalStage.hs ├── LICENSE ├── README.md ├── .gitignore ├── stupid-computer.cabal └── stack.yaml /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/Mult.hs: -------------------------------------------------------------------------------- 1 | mult x y = x * y 2 | 3 | --Example of custom ifix operators 4 | demo = 2 `mult` 3 -------------------------------------------------------------------------------- /examples/Sum.hs: -------------------------------------------------------------------------------- 1 | module Sum where 2 | 3 | import Prelude hiding (sum) 4 | 5 | sum :: Num a => [a] -> a 6 | sum (x:xs) = x + sum xs 7 | sum [] = 0 8 | 9 | -------------------------------------------------------------------------------- /examples/Maybe.hs: -------------------------------------------------------------------------------- 1 | mayInt :: (Maybe Integer) -> Integer 2 | mayInt (Just i) = i 3 | mayInt Nothing = 0 4 | 5 | --Example using constructor 6 | demo = mayInt (Just 10) -------------------------------------------------------------------------------- /examples/Addn.hs: -------------------------------------------------------------------------------- 1 | Module Addn where 2 | 3 | addn :: Integer -> (Integer -> Integer) 4 | addn n = (+) n 5 | 6 | --Example of partial function application 7 | demo = addn 4 5 -------------------------------------------------------------------------------- /examples/Sumif.hs: -------------------------------------------------------------------------------- 1 | module Sumif where 2 | 3 | sum' :: Num a => [a] -> a 4 | sum' xs = if (not (null xs)) then (head xs) + sum' (tail xs) else 0 5 | 6 | demo = sum' [1,2,3] -------------------------------------------------------------------------------- /examples/Partial.hs: -------------------------------------------------------------------------------- 1 | map' :: (a -> b) -> [a] -> [b] 2 | map' f (x:xs) = (f x) : (map' f xs) 3 | map' _ [] = [] 4 | 5 | --An example of using a partial function 6 | add x = (+) x 7 | 8 | demo = map (add 42) [1,2,3] 9 | -------------------------------------------------------------------------------- /examples/Sumguards.hs: -------------------------------------------------------------------------------- 1 | module Sumguards where 2 | 3 | import Prelude hiding (sum) 4 | 5 | sum :: Num a => [a] -> a 6 | sum xs | not (null xs) = head xs + sum (tail xs) 7 | | otherwise = 0 8 | 9 | demo = sum [1,2,3] -------------------------------------------------------------------------------- /examples/Factorial.hs: -------------------------------------------------------------------------------- 1 | module Factorial where 2 | 3 | fac :: Integer -> Integer 4 | fac 0 = 1 5 | fac 1 = 1 6 | fac n = n * fac(n-1) 7 | 8 | fac' :: Integer -> Integer 9 | fac' n = if (n <= 1) then 1 else n * fac' (n-1) 10 | 11 | fac'' n | n <= 1 = 1 12 | | otherwise = n * fac'' (n-1) -------------------------------------------------------------------------------- /examples/Map.hs: -------------------------------------------------------------------------------- 1 | module Map where 2 | 3 | import Prelude hiding (sum,map,product) 4 | 5 | 6 | map :: (a -> b) -> [a] -> [b] 7 | map f (x:xs) = (f x) : (map f xs) 8 | map _ [] = [] 9 | 10 | square :: Num a => a -> a 11 | square x = x*x 12 | 13 | sum :: Num a => [a] -> a 14 | sum (x:xs) = x + sum xs 15 | sum [] = 0 16 | 17 | product :: Num a => [a] -> a 18 | product (x:xs) = x * product xs 19 | product [] = 1 -------------------------------------------------------------------------------- /examples/Listcomp.hs: -------------------------------------------------------------------------------- 1 | module Listcomp where 2 | 3 | import Prelude hiding (map, take) 4 | 5 | 6 | map :: (a -> b) -> [a] -> [b] 7 | map f (x:xs) = (f x) : (map f xs) 8 | map _ [] = [] 9 | 10 | square :: Integer -> Integer 11 | square x = x*x 12 | 13 | doublelarge :: [Integer] -> [Integer] 14 | doublelarge xs = [x * 2 | x <- xs, x > 3] 15 | 16 | take :: Integer -> [a] -> [a] 17 | take 0 _ = [] 18 | take n (x:xs) = x : (take (n-1) xs) 19 | take _ [] = [] -------------------------------------------------------------------------------- /src/ScTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | 3 | module ScTypes where 4 | 5 | import "ghc-lib-parser" GHC.Hs 6 | 7 | import "ghc-lib-parser" GHC.Hs 8 | import "ghc-lib-parser" SrcLoc 9 | import "ghc-lib-parser" RdrName 10 | import "ghc-lib-parser" OccName 11 | import "ghc-lib-parser" Outputable 12 | 13 | import qualified Data.Map as Map 14 | 15 | type ModuleInfo = (Map.Map FunctionName FunctionInfo) 16 | data FunctionInfo = FunctionInfo {name::FunctionName, definition::(LHsDecl GhcPs), typesig::(Maybe TypeSig), numargs::NoArgs} 17 | type FunctionName = String 18 | type NoArgs = Integer 19 | type TypeSig = (LHsDecl GhcPs) 20 | 21 | type EvalState = (Map.Map String Int, String) -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Alexander Wasey 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # stupid-computer 2 | ## Break down Haskell programs and execute them step by step! 3 | 4 | A Haskell tracer, designed with readability in mind. 5 | 6 | For instance given the definition of the sum function: 7 | ``` 8 | sum :: [Int] -> Int 9 | sum (x:xs) = x + (sum xs) 10 | sum [] = 0 11 | ``` 12 | And an expression to evaluate: 13 | ``` 14 | sum [1,2,3,4] 15 | ``` 16 | A trace of the execution can be shown by the Stupid Computer as follows: 17 | ``` 18 | sum [1, 2, 3, 4] 19 | = 1 + sum [2,3,4] 20 | = 1 + 2 + sum [3,4] 21 | = 1 + 2 + 3 + sum [4] 22 | = 1 + 2 + 3 + 4 + sum [] 23 | = 1 + 2 + 3 + 4 + 0 24 | = 1 + 2 + 3 + 4 25 | = 1 + 2 + 7 26 | = 1 + 9 27 | = 10 28 | ``` 29 | 30 | To download and install run the following commands in your terminal. 31 | 32 | `git clone https://github.com/alexanderwasey/stupid-computer.git` 33 | 34 | `cd stupid-computer` 35 | 36 | `stack install` 37 | 38 | And then run the sum examples with 39 | 40 | `stupid-computer examples/sum.hs` , followed by `sum [1, 2, 3, 4]` 41 | 42 | For help run `stupid-computer --help` 43 | 44 | Source can be found at https://github.com/alexanderwasey/stupid-computer 45 | -------------------------------------------------------------------------------- /src/TypeCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, LambdaCase, ScopedTypeVariables, TypeApplications #-} 2 | {-# OPTIONS_GHC -Wno-missing-fields #-} 3 | 4 | module TypeCheck where 5 | 6 | import "ghc-lib-parser" GHC.Hs 7 | 8 | import "ghc-lib-parser" Config 9 | import "ghc-lib-parser" DynFlags 10 | import "ghc-lib-parser" StringBuffer 11 | import "ghc-lib-parser" Fingerprint 12 | import "ghc-lib-parser" Lexer 13 | import "ghc-lib-parser" RdrName 14 | import "ghc-lib-parser" ErrUtils 15 | import qualified "ghc-lib-parser" Parser 16 | import "ghc-lib-parser" FastString 17 | import "ghc-lib-parser" Outputable 18 | import "ghc-lib-parser" SrcLoc 19 | import "ghc-lib-parser" Panic 20 | import "ghc-lib-parser" HscTypes 21 | import "ghc-lib-parser" HeaderInfo 22 | import "ghc-lib-parser" ToolSettings 23 | import "ghc-lib-parser" GHC.Platform 24 | import "ghc-lib-parser" Bag 25 | 26 | import ScTypes 27 | import Tools 28 | import qualified Data.Map as Map 29 | import Data.List 30 | 31 | --Simply checks the types 32 | checkType :: (LHsDecl GhcPs) -> ScTypes.ModuleInfo -> String -> IO(Bool,String) 33 | checkType decl moduinfo filename = do 34 | result <- Tools.evalAsString toExecute filename (Map.keys moduinfo) 35 | 36 | case result of 37 | (Right s) -> return (True,s) 38 | (Left e) -> return (False,"") 39 | 40 | where toExecute = "let main = " ++ (showSDocUnsafe $ ppr decl) ++ " in main" -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | # Created by https://www.toptal.com/developers/gitignore/api/haskell,macos,visualstudiocode 3 | # Edit at https://www.toptal.com/developers/gitignore?templates=haskell,macos,visualstudiocode 4 | 5 | ### Haskell ### 6 | dist 7 | dist-* 8 | cabal-dev 9 | *.o 10 | *.hi 11 | *.hie 12 | *.chi 13 | *.chs.h 14 | *.dyn_o 15 | *.dyn_hi 16 | .hpc 17 | .hsenv 18 | .cabal-sandbox/ 19 | cabal.sandbox.config 20 | *.prof 21 | *.aux 22 | *.hp 23 | *.eventlog 24 | .stack-work/ 25 | cabal.project.local 26 | cabal.project.local~ 27 | .HTF/ 28 | .ghc.environment.* 29 | 30 | ### macOS ### 31 | # General 32 | .DS_Store 33 | .AppleDouble 34 | .LSOverride 35 | 36 | # Icon must end with two \r 37 | Icon 38 | 39 | # Thumbnails 40 | ._* 41 | 42 | # Files that might appear in the root of a volume 43 | .DocumentRevisions-V100 44 | .fseventsd 45 | .Spotlight-V100 46 | .TemporaryItems 47 | .Trashes 48 | .VolumeIcon.icns 49 | .com.apple.timemachine.donotpresent 50 | 51 | # Directories potentially created on remote AFP share 52 | .AppleDB 53 | .AppleDesktop 54 | Network Trash Folder 55 | Temporary Items 56 | .apdisk 57 | 58 | ### VisualStudioCode ### 59 | .vscode/* 60 | !.vscode/settings.json 61 | !.vscode/tasks.json 62 | !.vscode/launch.json 63 | !.vscode/extensions.json 64 | *.code-workspace 65 | 66 | ### VisualStudioCode Patch ### 67 | # Ignore all local history of files 68 | .history 69 | 70 | /tests 71 | 72 | #Ignore executable 73 | stupid-computer 74 | 75 | #Stack 76 | stack.yaml.lock 77 | 78 | # End of https://www.toptal.com/developers/gitignore/api/haskell,macos,visualstudiocode 79 | -------------------------------------------------------------------------------- /src/NormalFormReducer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, TypeApplications #-} 2 | {-# OPTIONS_GHC -Wno-missing-fields #-} 3 | 4 | module NormalFormReducer where 5 | 6 | import "ghc-lib-parser" GHC.Hs 7 | 8 | import "ghc-lib-parser" Config 9 | import "ghc-lib-parser" DynFlags 10 | import "ghc-lib-parser" StringBuffer 11 | import "ghc-lib-parser" Fingerprint 12 | import "ghc-lib-parser" Lexer 13 | import "ghc-lib-parser" RdrName 14 | import "ghc-lib-parser" ErrUtils 15 | import qualified "ghc-lib-parser" Parser 16 | import "ghc-lib-parser" FastString 17 | import "ghc-lib-parser" Outputable 18 | import "ghc-lib-parser" SrcLoc 19 | import "ghc-lib-parser" Panic 20 | import "ghc-lib-parser" HscTypes 21 | import "ghc-lib-parser" HeaderInfo 22 | import "ghc-lib-parser" ToolSettings 23 | import "ghc-lib-parser" GHC.Platform 24 | import "ghc-lib-parser" Bag 25 | 26 | 27 | import qualified Data.Map.Strict as Map 28 | import Data.List 29 | import Data.Either 30 | 31 | import Tools 32 | 33 | reduceNormalForm :: (LHsExpr GhcPs) -> DynFlags -> String -> [String] -> IO(Maybe (LHsExpr GhcPs)) 34 | reduceNormalForm (L l expr) flags filename hide = do 35 | collapsedexpr <- Tools.evalAsString (showSDocUnsafe $ ppr expr) filename hide 36 | case collapsedexpr of 37 | (Left _) -> return Nothing 38 | (Right out) -> do 39 | case Tools.parseModule "" flags out of 40 | PFailed _ -> return $ Just (L l (Tools.stringtoId out)) 41 | POk _ (L _ (HsModule _ _ _ [(L l(SpliceD _ (SpliceDecl _ (L _ (HsUntypedSplice _ _ _ expr)) _ )))] _ _)) -> do 42 | return $ Just expr 43 | _ -> error "FATAL REDUCTION ERROR" -------------------------------------------------------------------------------- /stupid-computer.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | -- Initial package description 'stupid-computer.cabal' generated by 'cabal 3 | -- init'. For further documentation, see 4 | -- http://haskell.org/cabal/users-guide/ 5 | 6 | name: stupid-computer 7 | version: 0.1.0.0 8 | synopsis: An educational tracer for Haskell. 9 | description: Execute Haskell programs step by step! 10 | bug-reports: stupid-computer@wasey.net 11 | license: MIT 12 | license-file: LICENSE 13 | author: Alexander Wasey 14 | maintainer: Alexander Wasey 15 | copyright: Alexander Wasey 2020 16 | category: Development 17 | build-type: Simple 18 | 19 | source-repository head 20 | type: git 21 | location: https://github.com/alexanderwasey/stupid-computer.git 22 | 23 | executable stupid-computer 24 | ghc-options: -static 25 | main-is: Main.hs 26 | other-modules: PrepStage 27 | , Tools 28 | , EvalStage 29 | , FormalActualMap 30 | , ScTypes 31 | , DefinitionGetter 32 | , TypeCheck 33 | , NormalFormReducer 34 | -- other-extensions: 35 | build-depends: base 36 | , extra 37 | , hint 38 | , transformers 39 | , ghc-lib-parser 40 | , containers 41 | , mtl 42 | -- hs-source-dirs: 43 | default-language: Haskell2010 44 | hs-source-dirs: src 45 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: 21 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/4.yaml 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # subdirs: 30 | # - auto-update 31 | # - wai 32 | packages: 33 | - . 34 | # Dependency packages to be pulled from upstream that are not in the resolver. 35 | # These entries can reference officially published versions as well as 36 | # forks / in-progress versions pinned to a git hash. For example: 37 | # 38 | # extra-deps: 39 | # - acme-missiles-0.3 40 | # - git: https://github.com/commercialhaskell/stack.git 41 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 42 | # 43 | # extra-deps: [] 44 | 45 | # Override default flag values for local packages and extra-deps 46 | # flags: {} 47 | 48 | # Extra package databases containing global packages 49 | # extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=2.5" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor 68 | -------------------------------------------------------------------------------- /src/PrepStage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | {-# OPTIONS_GHC -Wno-missing-fields #-} 3 | 4 | module PrepStage where 5 | 6 | import "ghc-lib-parser" GHC.Hs 7 | 8 | import "ghc-lib-parser" GHC.Hs 9 | import "ghc-lib-parser" SrcLoc 10 | import "ghc-lib-parser" RdrName 11 | import "ghc-lib-parser" OccName 12 | import "ghc-lib-parser" Outputable 13 | import "ghc-lib-parser" DynFlags 14 | import "ghc-lib-parser" BasicTypes 15 | 16 | 17 | import qualified Data.Map as Map 18 | 19 | import ScTypes 20 | import Tools 21 | 22 | prepModule :: (HsModule GhcPs) -> (ScTypes.ModuleInfo) 23 | prepModule (HsModule _ _ _ decls _ _) = Map.fromList $ map (prepFunction typedecls) functionbodies 24 | where 25 | functionbodies = filter Tools.isFunction decls 26 | typedecls = getTypeNames $ filter Tools.isType decls 27 | 28 | getTypeNames :: [LHsDecl GhcPs] -> Map.Map String (LHsDecl GhcPs) 29 | getTypeNames types = Map.fromList $ map (\x -> (getTypeName x, x)) types 30 | 31 | getTypeName :: (LHsDecl GhcPs) -> String 32 | getTypeName (L _ (SigD _ (TypeSig _ parts _))) = showSDocUnsafe $ ppr $ head parts 33 | getTypeName _ = error $ Tools.errorMessage ++ "Err getting name of type" 34 | 35 | prepFunction :: Map.Map String (LHsDecl GhcPs) -> (LHsDecl GhcPs) -> (ScTypes.FunctionName, ScTypes.FunctionInfo) 36 | prepFunction typemap decl = (name, (FunctionInfo name decl' decltype numargs)) 37 | where 38 | decl' = ensureInfix decl 39 | name = getName decl' 40 | numargs = numArgs decl' 41 | decltype = typemap Map.!? name 42 | 43 | ensureInfix :: (LHsDecl GhcPs) -> (LHsDecl GhcPs) 44 | ensureInfix (L a (ValD b (FunBind c d (MG e (L f matches) g) h i))) = (L a (ValD b (FunBind c d (MG e (L f matches') g) h i))) 45 | where matches' = map toPrefix matches 46 | toPrefix (L l (Match a (FunRhs name _ src) c d)) = (L l (Match a (FunRhs name Prefix src) c d)) 47 | 48 | 49 | --Gets the name from a function declaration 50 | getName :: (LHsDecl GhcPs) -> ScTypes.FunctionName 51 | getName (L _ (ValD _ (FunBind _ (L _ name) _ _ _))) = occNameString $ rdrNameOcc name 52 | getName expr = error $ showSDocUnsafe $ ppr expr 53 | 54 | --Gets the number of arguments from a function declaration 55 | numArgs :: (LHsDecl GhcPs) -> ScTypes.NoArgs 56 | numArgs (L _ (ValD _ (FunBind _ _ (MG _ (L _ cases) _) _ _))) = numArgsMatch $ head cases 57 | where numArgsMatch (L _ (Match _ _ pattern rhs) ) = toInteger $ length pattern 58 | numArgs _ = error $ Tools.errorMessage ++ "Getting number of arguments" 59 | 60 | prepBind :: (LHsBindLR GhcPs GhcPs) -> ScTypes.ModuleInfo 61 | prepBind (L l def@(FunBind _ _ function _ _)) = Map.fromList $ [PrepStage.prepFunction Map.empty (L l (ValD NoExtField def))] -------------------------------------------------------------------------------- /src/DefinitionGetter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, LambdaCase, ScopedTypeVariables, TypeApplications #-} 2 | {-# OPTIONS_GHC -Wno-missing-fields #-} 3 | 4 | module DefinitionGetter where 5 | 6 | import "ghc-lib-parser" GHC.Hs 7 | import "ghc-lib-parser" SrcLoc 8 | import "ghc-lib-parser" RdrName 9 | import "ghc-lib-parser" OccName 10 | import "ghc-lib-parser" Outputable 11 | 12 | import Data.Typeable (Typeable) 13 | import Data.Either 14 | 15 | import Data.List 16 | 17 | import Tools 18 | import ScTypes 19 | 20 | import qualified Data.Map.Strict as Map 21 | 22 | 23 | qualifier :: String 24 | qualifier = "definitiongetterqual" 25 | 26 | --Given an Expression and the enviroment return the correct rhs to substitute 27 | getDef :: (HsExpr GhcPs) -> [HsExpr GhcPs] -> ScTypes.ModuleInfo -> String -> IO(Maybe(HsExpr GhcPs, [LPat GhcPs], Map.Map Integer [LPat GhcPs])) 28 | getDef func args modu filename = do 29 | 30 | let funcname = showSDocUnsafe $ ppr $ func -- Get the function name 31 | let funcname' = if ((head funcname ) == '(') then init $ tail funcname else funcname 32 | 33 | (funcdef, t) <- case (modu Map.!? funcname') of --Get the function definition 34 | Just functioninfo -> do 35 | let (L _ info) = definition functioninfo 36 | return (info, typesig functioninfo) 37 | _ -> error $ Tools.errorMessage ++ "funcdef not found : " ++ funcname-- Should never happen 38 | 39 | --Create the type for the new function 40 | newtypestr <- case t of --Creating the type for this 41 | (Just t1) -> do 42 | let t2 = qualifier ++ funcname ++ " :: " ++ (Tools.setResultint t1) ++ ";" 43 | return t2 44 | _ -> return "" 45 | 46 | let (defmap, newfuncdef) = createNewFunction funcdef 47 | 48 | let funcstringwithtype = (Tools.nonCalledFunctionString modu) ++ " let { " ++ newtypestr ++ (createFunction newfuncdef) ++ "} in " 49 | let funcstring = (Tools.nonCalledFunctionString modu) ++ " let { " ++ (createFunction newfuncdef) ++ "} in "-- Create the function (and the map) 50 | 51 | let stringArgs = map (\x -> "( " ++(showSDocUnsafe $ ppr x) ++ ") ") args 52 | 53 | 54 | --Only use the type created if it is needed 55 | resultNoType <- getMatchingDefinition funcstring (qualifier ++ funcname) stringArgs defmap filename (Map.keys modu) 56 | case resultNoType of 57 | Nothing -> getMatchingDefinition funcstringwithtype (qualifier ++ funcname) stringArgs defmap filename (Map.keys modu) 58 | result -> return result 59 | 60 | --Creates a new function, and it's map 61 | createNewFunction :: (HsDecl GhcPs) -> ((Map.Map Integer ((HsExpr GhcPs), [LPat GhcPs])), (HsDecl GhcPs)) 62 | createNewFunction (ValD v (FunBind a b (MG c (L d defs) e ) f g)) = (map, decl) 63 | where 64 | (map, defs') = foldr createNewFunctionCase (Map.empty, []) defs 65 | decl = (ValD v (FunBind a b (MG c (L d defs') e ) f g)) 66 | 67 | --This is being used for the fold 68 | --Being folded as need to look at the old map in order to keep track of the ordering 69 | createNewFunctionCase :: (LMatch GhcPs (LHsExpr GhcPs)) -> ((Map.Map Integer ((HsExpr GhcPs), [LPat GhcPs])), [LMatch GhcPs (LHsExpr GhcPs)]) -> ((Map.Map Integer ((HsExpr GhcPs), [LPat GhcPs])), [LMatch GhcPs (LHsExpr GhcPs)]) 70 | createNewFunctionCase (L l (Match m_ext m_ctxt m_pats (GRHSs d bodies e) ) ) (m, matches) = (m'', match : matches) 71 | where 72 | firstIndex = toInteger $ Map.size m 73 | m' = Map.fromList $ zip [firstIndex..] $ map (\x -> (x,m_pats)) (map Tools.getFunctionDefFromBody bodies) 74 | m'' = Map.union m' m 75 | indexedBodies = zip [firstIndex..] bodies 76 | bodies' = map subIntegerValue indexedBodies 77 | match = (L l (Match m_ext m_ctxt m_pats (GRHSs d bodies' e))) 78 | 79 | subIntegerValue :: (Integer,(LGRHS GhcPs (LHsExpr GhcPs))) -> (LGRHS GhcPs (LHsExpr GhcPs)) 80 | subIntegerValue (val, (L l (GRHS a b (L l' _)) )) = (L l (GRHS a b (L l' def))) 81 | where def = Tools.stringtoId (show val) 82 | 83 | getMatchingDefinition :: String -> String -> [String] -> (Map.Map Integer ((HsExpr GhcPs), [LPat GhcPs])) -> String -> [String] -> IO (Maybe(HsExpr GhcPs, [LPat GhcPs], Map.Map Integer [LPat GhcPs])) 84 | getMatchingDefinition function funcname args defmap filename hide = do 85 | let pats = Map.map snd defmap 86 | 87 | --Don't bother with any of this if only one definition 88 | if (length defmap == 1) then do 89 | let (expr, pat) = head $ Map.elems defmap 90 | return $ Just (expr, pat, pats) 91 | else do 92 | defNo <- Tools.evalWithArgs @Integer function funcname args filename hide 93 | 94 | case defNo of 95 | (Right i) -> do 96 | let (expr, pat) = (defmap Map.! i) 97 | return $ Just (expr, pat, pats) 98 | (Left errs) -> return Nothing 99 | 100 | --Creates the function to be executed 101 | createFunction :: (HsDecl GhcPs) -> String 102 | createFunction (ValD _ (FunBind _ _ (MG _ (L _ defs) _ ) _ _)) = intercalate ";" finalCases 103 | where cases = map (showSDocUnsafe.ppr) defs 104 | casesNoNewlines = map (\x -> (map (\t -> if (t == '\n') then ' ' else t) x)) cases 105 | finalCases = map (qualifier ++) casesNoNewlines 106 | 107 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | {-# OPTIONS_GHC -Wno-missing-fields #-} 3 | 4 | module Main (main) where 5 | 6 | import "ghc-lib-parser" GHC.Hs 7 | 8 | import "ghc-lib-parser" Config 9 | import "ghc-lib-parser" DynFlags 10 | import "ghc-lib-parser" StringBuffer 11 | import "ghc-lib-parser" Fingerprint 12 | import "ghc-lib-parser" Lexer 13 | import "ghc-lib-parser" RdrName 14 | import "ghc-lib-parser" ErrUtils 15 | import qualified "ghc-lib-parser" Parser 16 | import "ghc-lib-parser" FastString 17 | import "ghc-lib-parser" Outputable 18 | import "ghc-lib-parser" SrcLoc 19 | import "ghc-lib-parser" Panic 20 | import "ghc-lib-parser" HscTypes 21 | import "ghc-lib-parser" HeaderInfo 22 | import "ghc-lib-parser" ToolSettings 23 | import "ghc-lib-parser" GHC.Platform 24 | import "ghc-lib-parser" Bag 25 | 26 | import System.IO.Extra 27 | import System.Environment 28 | 29 | import Control.Monad.State 30 | 31 | import qualified Language.Haskell.Interpreter as Hint 32 | 33 | import qualified Data.Map.Strict as Map 34 | import Data.Maybe 35 | import Data.List 36 | import Data.Char 37 | 38 | import qualified Tools as Tools 39 | import PrepStage 40 | import TypeCheck 41 | import EvalStage 42 | import ScTypes 43 | 44 | fakeSettings :: Settings 45 | fakeSettings = Settings 46 | { sGhcNameVersion=ghcNameVersion 47 | , sFileSettings=fileSettings 48 | , sTargetPlatform=platform 49 | , sPlatformMisc=platformMisc 50 | , sPlatformConstants=platformConstants 51 | , sToolSettings=toolSettings 52 | } 53 | where 54 | toolSettings = ToolSettings { 55 | toolSettings_opt_P_fingerprint=fingerprint0 56 | } 57 | fileSettings = FileSettings {} 58 | platformMisc = PlatformMisc {} 59 | ghcNameVersion = 60 | GhcNameVersion{ghcNameVersion_programName="ghc" 61 | ,ghcNameVersion_projectVersion=cProjectVersion 62 | } 63 | platform = 64 | Platform{ 65 | platformWordSize=PW8 66 | , platformMini=PlatformMini {platformMini_arch=ArchUnknown, platformMini_os=OSUnknown} 67 | , platformUnregisterised=True 68 | } 69 | platformConstants = 70 | PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8} 71 | 72 | fakeLlvmConfig :: LlvmConfig 73 | fakeLlvmConfig = LlvmConfig [] [] 74 | 75 | 76 | parsePragmasIntoDynFlags :: DynFlags -> FilePath -> String -> IO (Maybe DynFlags) 77 | parsePragmasIntoDynFlags flags filepath str = 78 | catchErrors $ do 79 | let opts = getOptions flags (stringToStringBuffer str) filepath 80 | (flags, _, _) <- parseDynamicFilePragma flags opts 81 | return $ Just flags 82 | where 83 | catchErrors :: IO (Maybe DynFlags) -> IO (Maybe DynFlags) 84 | catchErrors act = handleGhcException reportErr 85 | (handleSourceError reportErr act) 86 | reportErr e = do putStrLn $ "error : " ++ show e; return Nothing 87 | 88 | main :: IO () 89 | main = do 90 | 91 | args <- getArgs 92 | env <- getEnv "PWD" 93 | 94 | case args of 95 | ("--help":_) -> do --They have asked for help 96 | putStrLn "To launch load a .hs file, i.e `stupid-computer examples/sumpattern.hs`" 97 | putStrLn "Then expressions can be evaluated via user input, i.e `sum [1..5]`" 98 | putStrLn "Example files are available in examples/ in the source repo at: " 99 | putStrLn "https://github.com/alexanderwasey/stupid-computer" 100 | putStrLn "Such an input file may look like:" 101 | putStrLn "" 102 | putStrLn "sum :: Num a => [a] -> a" 103 | putStrLn "sum (x:xs) = x + sum xs" 104 | putStrLn "sum [] = 0" 105 | (x:_) -> do 106 | let filename = if (head x == '/') then x else env ++ "/" ++ x 107 | run filename x 108 | [] -> do 109 | putStrLn "Error : No File Given" 110 | 111 | run :: String -> String -> IO() 112 | run file filename = do 113 | s <- readFile' file 114 | (Just flags) <- 115 | parsePragmasIntoDynFlags 116 | (defaultDynFlags fakeSettings fakeLlvmConfig) file s 117 | case Tools.parseModule file (flags `gopt_set` Opt_KeepRawTokenStream) s of 118 | PFailed s -> do 119 | let errors = map showSDocUnsafe (pprErrMsgBagWithLoc $ snd (getMessages s flags)) 120 | mapM_ putStrLn errors 121 | 122 | POk s (L _ modu) -> do 123 | let preppedModule = PrepStage.prepModule modu 124 | runloop preppedModule flags filename file 125 | 126 | runloop :: ScTypes.ModuleInfo -> DynFlags -> String -> String -> IO() 127 | runloop preppedModule flags filename filepath = do 128 | putStrLn $ "Environment = " ++ filename 129 | 130 | input <- getLine 131 | 132 | if (take 2 ((map toLower) input) == ":q") 133 | then return () 134 | else do 135 | 136 | case Tools.parseModule "userinput" (flags `gopt_set` Opt_KeepRawTokenStream) input of 137 | --Users input cannot parse 138 | PFailed s -> do 139 | let errors = map showSDocUnsafe (pprErrMsgBagWithLoc $ snd (getMessages s flags)) 140 | mapM_ putStrLn errors 141 | 142 | --Parses correctly 143 | POk s (L _ modu) -> do 144 | let toExectute = Tools.getToExecute modu 145 | wellTyped <- checkType toExectute preppedModule filepath 146 | case wellTyped of 147 | (True,result) -> do 148 | let initline = (showSDocUnsafe $ ppr toExectute) 149 | putStrLn $ " " ++ initline 150 | runStateT (EvalStage.execute toExectute preppedModule initline flags) (Map.empty, filepath) 151 | putStrLn "" 152 | _ -> do 153 | putStrLn $ "Your code will not run, try checking it in GHCi!" 154 | 155 | runloop preppedModule flags filename filepath -------------------------------------------------------------------------------- /src/Tools.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, LambdaCase, ScopedTypeVariables, TypeApplications #-} 2 | {-# OPTIONS_GHC -Wno-missing-fields #-} 3 | 4 | module Tools where 5 | 6 | import "ghc-lib-parser" GHC.Hs 7 | import "ghc-lib-parser" RdrName 8 | import "ghc-lib-parser" OccName 9 | import "ghc-lib-parser" Outputable 10 | import "ghc-lib-parser" BasicTypes 11 | import "ghc-lib-parser" Config 12 | import "ghc-lib-parser" DynFlags 13 | import "ghc-lib-parser" StringBuffer 14 | import "ghc-lib-parser" Fingerprint 15 | import "ghc-lib-parser" Lexer 16 | import "ghc-lib-parser" RdrName 17 | import "ghc-lib-parser" ErrUtils 18 | import qualified "ghc-lib-parser" Parser 19 | import "ghc-lib-parser" FastString 20 | import "ghc-lib-parser" SrcLoc 21 | import "ghc-lib-parser" Panic 22 | import "ghc-lib-parser" HscTypes 23 | import "ghc-lib-parser" HeaderInfo 24 | import "ghc-lib-parser" ToolSettings 25 | import "ghc-lib-parser" GHC.Platform 26 | import "ghc-lib-parser" Bag 27 | 28 | 29 | import Control.Exception (throwIO) 30 | import Control.Monad.Trans.Class (lift) 31 | import Control.Monad.Trans.Writer (execWriterT, tell) 32 | import Data.Foldable (for_) 33 | import Data.Typeable (Typeable) 34 | import Data.Either 35 | import Data.List 36 | import qualified Data.Map as Map 37 | 38 | import ScTypes 39 | 40 | import qualified Language.Haskell.Interpreter as Hint 41 | 42 | toolsqualifier = "toolsqual" 43 | 44 | isFunction :: (LHsDecl GhcPs) -> Bool 45 | isFunction (L _ (ValD _ (FunBind _ _ _ _ _))) = True 46 | isFunction _ = False 47 | 48 | isType :: (LHsDecl GhcPs) -> Bool 49 | isType (L _ (SigD _ _)) = True 50 | isType _ = False 51 | 52 | getToExecute :: (HsModule GhcPs) -> (LHsDecl GhcPs) 53 | getToExecute (HsModule _ _ _ decls _ _) = if ((length executables) /= 0) then head executables else error "No statements found to execute." 54 | where 55 | executables = filter isToExecute decls 56 | 57 | isToExecute :: (LHsDecl GhcPs) -> Bool 58 | isToExecute (L _ (SpliceD _ (SpliceDecl _ (L _ (HsUntypedSplice _ _ _ _)) _ ) )) = True 59 | isToExecute _ = False 60 | 61 | --Get the function expr and the argument expressions (In the right order) 62 | getFuncArgs :: (LHsExpr GhcPs) -> (HsExpr GhcPs, [HsExpr GhcPs]) 63 | getFuncArgs (L _ (HsApp _ lhs (L _ rhs))) = (func, lhsargs ++ [rhs]) 64 | where 65 | (func, lhsargs) = getFuncArgs lhs 66 | 67 | getFuncArgs (L _ (OpApp _ (L _ lhs) (L _ op) (L _ rhs))) = (removePars op , [lhs, rhs]) 68 | 69 | getFuncArgs (L l (HsPar _ expr)) = getFuncArgs expr 70 | getFuncArgs (L _ expr) = (expr, []) 71 | 72 | --Creates functions to set up the rest of the envrioment with the other defined values 73 | nonCalledFunctionString :: (ScTypes.ModuleInfo) -> String 74 | nonCalledFunctionString modu = concat declsstrings 75 | where members = Map.elems modu 76 | declsstrings = map (\x -> "let { " ++ (printfunc x) ++ " } in ") members 77 | asone = (concat $ intersperse "; " declsstrings) ++ "; " 78 | 79 | printfunc :: FunctionInfo -> String 80 | printfunc (FunctionInfo _ (L l decl) (Just t) _) = (showSDocUnsafe $ ppr t ) ++ " ; " ++ (printdecl decl) 81 | printfunc (FunctionInfo _ (L l decl) Nothing _) = (printdecl decl) 82 | 83 | printdecl :: (HsDecl GhcPs) -> String 84 | printdecl def@(ValD _ (FunBind _ _ (MG _ (L _ defs) _ ) _ _)) = intercalate ";" $ map (showSDocUnsafe.ppr) defs 85 | 86 | --Executes a function when we need to 87 | --Do all the generation here so we can update this with a better soloution at some point 88 | evalWithArgs :: forall t. Typeable t 89 | => String -> String -> [String] -> String -> [String] -> IO (Either Hint.InterpreterError t) 90 | evalWithArgs function funcname args modulepath hide = Hint.runInterpreter $ do 91 | Hint.loadModules [modulepath] 92 | let hide' = filter (\x -> not(x `elem` operators)) hide 93 | Hint.setImportsF [Hint.ModuleImport "Prelude" Hint.NotQualified (Hint.HidingList hide'), Hint.ModuleImport (getModuleName modulepath) Hint.NotQualified Hint.NoImportList] 94 | Hint.interpret toEx (Hint.as :: t) 95 | where toEx = function ++ funcname ++ argString 96 | argString = concat $ " " : intersperse " " args 97 | 98 | --Gives output as a string 99 | evalAsString :: String -> String -> [String] -> IO(Either Hint.InterpreterError String) 100 | evalAsString s modulepath hide = Hint.runInterpreter $ do 101 | let hide' = filter (\x -> not(x `elem` operators)) hide 102 | Hint.loadModules [modulepath] 103 | Hint.setImportsF [Hint.ModuleImport "Prelude" Hint.NotQualified (Hint.HidingList hide'), Hint.ModuleImport (getModuleName modulepath) Hint.NotQualified Hint.NoImportList] 104 | Hint.eval s 105 | 106 | --Takes a string and turns it into the ID of a var 107 | stringtoId :: String -> (HsExpr GhcPs) 108 | stringtoId str = (HsVar NoExtField (noLoc (mkRdrUnqual $ mkVarOcc str))) 109 | 110 | errorMessage :: String 111 | errorMessage = "Oops, this shouldn't happen, please send a copy of your input file, and this output to stupid-computer@wasey.net : " 112 | 113 | removeLPars :: (LHsExpr GhcPs) -> (LHsExpr GhcPs) 114 | removeLPars (L l expr) = (L l (removePars expr)) 115 | 116 | --Removes the pars if they exist 117 | removePars :: (HsExpr GhcPs) -> (HsExpr GhcPs) 118 | removePars (HsPar _ (L l (HsVar xvar id))) = (HsVar xvar id) 119 | removePars (HsPar _ (L l (HsLit xlit id))) = (HsLit xlit id) 120 | removePars (HsPar _ (L l (HsPar xpar expr))) = removePars (HsPar xpar expr) 121 | removePars (HsPar _ (L l (HsOverLit xlit lit))) = (HsOverLit xlit lit) 122 | removePars expr = expr 123 | 124 | parseModule :: String -> DynFlags -> String -> ParseResult (Located (HsModule GhcPs)) 125 | parseModule filename flags str = 126 | unP Parser.parseModule parseState 127 | where 128 | location = mkRealSrcLoc (mkFastString filename) 1 1 129 | buffer = stringToStringBuffer str 130 | parseState = mkPState flags buffer location 131 | 132 | 133 | matchesPattern :: (HsExpr GhcPs) -> String -> (ScTypes.ModuleInfo) -> String -> IO(Bool) 134 | matchesPattern expr pat modu filepath = do 135 | let funcname = "matchpat" ++ toolsqualifier 136 | let funcstring = "let { " ++ ("matchpat"++toolsqualifier++" "++pat ++" = 1; matchpat"++toolsqualifier++" _ = 0;") ++ " } in " 137 | let arg = "( " ++ (showSDocUnsafe $ ppr expr) ++ ")" 138 | 139 | defNo <- Tools.evalWithArgs @Integer funcstring funcname [arg] filepath (Map.keys modu) 140 | case defNo of 141 | (Right 0) -> return False 142 | (Right 1) -> return True 143 | _ -> error $ Tools.errorMessage ++ funcname 144 | 145 | getDefFromBind :: (LHsBindLR GhcPs GhcPs) -> (HsExpr GhcPs) 146 | getDefFromBind (L _ (FunBind _ _ (MG _ (L _ defs) _ ) _ _)) = getFirstDefMatch $ head defs 147 | 148 | getFirstDef :: (LHsDecl GhcPs) -> (HsExpr GhcPs) 149 | getFirstDef (L _ (ValD _ (FunBind _ _ (MG _ (L _ defs) _ ) _ _))) = getFirstDefMatch $ head defs 150 | 151 | getFirstDefMatch :: (LMatch GhcPs (LHsExpr GhcPs)) -> (HsExpr GhcPs) 152 | getFirstDefMatch (L _ (Match _ _ _ (GRHSs _ bodies _))) = getFunctionDefFromBody $ head bodies 153 | 154 | --Gets the function definition from the body 155 | getFunctionDefFromBody :: (LGRHS GhcPs (LHsExpr GhcPs)) -> (HsExpr GhcPs) 156 | getFunctionDefFromBody (L _ (GRHS _ _ (L _ def)) ) = def 157 | getFunctionDefFromBody _ = error $ Tools.errorMessage ++ "Issue getting rhs of function" --Should never happen 158 | 159 | applyArgs :: (HsExpr GhcPs) -> [HsExpr GhcPs] -> (LHsExpr GhcPs) 160 | applyArgs expr [] = (noLoc expr) 161 | applyArgs expr args = foldr (\arg -> (\expr -> noLoc (HsApp NoExtField expr (noLoc arg)))) (noLoc expr) (reverse args) 162 | 163 | getModuleName filepath = reverse $ takeWhile (/='/') $ drop 3 $ reverse filepath 164 | 165 | operators = ["+", "-", "*", "/", "^", "^^", "**", "&&", "||", "<", "<=", "==", ">", ">=", "/=", "++", ":"] 166 | 167 | setResultint :: TypeSig -> String 168 | setResultint (L l (SigD d (TypeSig a b sigcontents))) = concat $ intersperse " -> " aslist 169 | where types = map (showSDocUnsafe.ppr) (init $ getTypesList sigcontents) 170 | aslist = types ++ ["Integer"] 171 | 172 | --Get a list of the types in the function 173 | --Without the typeclasses 174 | getTypesList :: (LHsSigWcType GhcPs) -> [HsType GhcPs] 175 | getTypesList (HsWC _ (HsIB _ (L _ t))) = getTypes t 176 | 177 | getTypes :: (HsType GhcPs) -> [HsType GhcPs] 178 | getTypes (HsQualTy _ _ (L _ t)) = getTypes t 179 | getTypes (HsAppTy _ (L _ l) (L _ r)) = getTypes l ++ getTypes r 180 | getTypes (HsFunTy _ (L _ l) (L _ r)) = getTypes l ++ getTypes r 181 | getTypes t = [t] 182 | -------------------------------------------------------------------------------- /src/FormalActualMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, LambdaCase, ScopedTypeVariables, TypeApplications #-} 2 | {-# OPTIONS_GHC -Wno-missing-fields #-} 3 | 4 | module FormalActualMap where 5 | 6 | import "ghc-lib-parser" GHC.Hs 7 | import "ghc-lib-parser" SrcLoc 8 | import "ghc-lib-parser" RdrName 9 | import "ghc-lib-parser" OccName 10 | import "ghc-lib-parser" Outputable 11 | import "ghc-lib-parser" BasicTypes 12 | import "ghc-lib-parser" FastString 13 | 14 | 15 | import Data.Typeable (Typeable) 16 | import Data.Either 17 | import Data.List 18 | import Data.String 19 | import Data.Char 20 | 21 | import Tools 22 | import ScTypes 23 | 24 | import qualified Data.Map.Strict as Map 25 | import Data.Maybe 26 | 27 | matchPatterns :: [HsExpr GhcPs] -> [LPat GhcPs] -> (ScTypes.ModuleInfo) -> IO(Maybe (Map.Map String (HsExpr GhcPs))) 28 | matchPatterns exprs patterns modu = do 29 | maps <- mapM (\(expr,pattern) -> matchPattern expr pattern modu) (zip exprs patterns) 30 | 31 | return $ (Just Map.fromList) <*> (conMaybes maps) 32 | 33 | --Now deal with each of the cases for the patterns 34 | 35 | --Simple case with just a variable pattern 36 | matchPattern :: (HsExpr GhcPs) -> (LPat GhcPs) -> (ScTypes.ModuleInfo) -> IO(Maybe ([(String, (HsExpr GhcPs))])) 37 | matchPattern expr (L _ (VarPat _ id)) _ = return $ Just [(showSDocUnsafe $ ppr id, expr)] 38 | 39 | matchPattern (HsPar _ (L _ expr)) (L _ (ParPat _ pat)) modu = matchPattern expr pat modu 40 | 41 | matchPattern (HsPar _ (L _ expr)) pat modu = matchPattern expr pat modu 42 | 43 | matchPattern expr (L _ (ParPat _ pat)) modu = matchPattern expr pat modu 44 | 45 | --Currently only concatenation 46 | matchPattern (ExplicitList xep syn (expr:exprs)) (L _(ConPatIn op (InfixCon l r))) modu = do 47 | case (showSDocUnsafe $ ppr op) of 48 | ":" -> do 49 | headmap <- matchPatternL expr l modu 50 | 51 | let taillist = (ExplicitList xep syn exprs) 52 | 53 | tailmap <- matchPattern taillist r modu 54 | 55 | return $ (++) <$> headmap <*> tailmap 56 | 57 | _ -> do 58 | error "Unsupported ConPatIn found" 59 | 60 | matchPattern (OpApp xop lhs oper rhs) pat@(L _(ConPatIn op (InfixCon l r))) modu = do 61 | case (showSDocUnsafe $ ppr op) of 62 | ":" -> do 63 | case (showSDocUnsafe $ ppr $ Tools.removeLPars oper) of 64 | "(:)" -> do 65 | headmap <- matchPatternL lhs l modu 66 | tailmap <- matchPatternL rhs r modu 67 | return $ (++) <$> headmap <*> tailmap 68 | "(++)" -> do -- lhs might be empty, and still have a match. 69 | --The lhs *should* be an explicit list with one element. 70 | case lhs of 71 | (L _ (HsPar _ lhs')) -> matchPattern (OpApp xop lhs' oper rhs) pat modu 72 | (L _ (ExplicitList _ _ [lhselem])) -> do 73 | headmap <- matchPatternL lhselem l modu 74 | tailmap <- matchPatternL rhs r modu 75 | return $ (++) <$> headmap <*> tailmap 76 | (L _ (ExplicitList _ _ [])) -> matchPatternL rhs pat modu --Check in the rhs for non-empty lists 77 | _ -> return Nothing 78 | _ -> return Nothing 79 | 80 | _ -> do 81 | let opname = "(" ++ (showSDocUnsafe $ ppr op) ++ ")" 82 | if (opname == (showSDocUnsafe $ ppr $ Tools.removeLPars oper)) 83 | then do 84 | headmap <- matchPatternL lhs l modu 85 | tailmap <- matchPatternL rhs r modu 86 | return $ (++) <$> headmap <*> tailmap 87 | else return Nothing 88 | 89 | --When a constructor has just one component 90 | matchPattern (HsApp xep lhs rhs ) (L l (ConPatIn op (PrefixCon ([arg])))) modu = do 91 | let lhsstring = showSDocUnsafe $ ppr lhs 92 | let opstring = showSDocUnsafe $ ppr op 93 | 94 | if (lhsstring == opstring) 95 | then matchPatternL rhs arg modu 96 | else return Nothing 97 | 98 | --When it has more than one 99 | matchPattern (HsApp xep lhs rhs ) (L l (ConPatIn op (PrefixCon args))) modu = do 100 | if (null args) then return Nothing 101 | else do 102 | innermatch <- matchPatternL lhs (L l (ConPatIn op (PrefixCon (init args)))) modu 103 | outermatch <- matchPatternL rhs (last args) modu 104 | return $ (++) <$> innermatch <*> outermatch 105 | 106 | matchPattern (ArithSeq xarith synexp seqInfo) (L _(ConPatIn op (InfixCon l r))) modu = do 107 | case (showSDocUnsafe $ ppr op) of 108 | ":" -> do 109 | case seqInfo of 110 | (From expr) -> do 111 | headmap <- matchPatternL expr l modu 112 | tailmap <- case expr of 113 | (L l (HsOverLit ext (OverLit extlit (HsIntegral (IL text neg val)) witness))) -> do 114 | let newseq = (ArithSeq xarith synexp (From (L l (HsOverLit ext (OverLit extlit (HsIntegral (IL (SourceText (show $ val+1)) neg (val+1))) witness))))) 115 | matchPattern newseq r modu 116 | _ -> return Nothing 117 | return $ (++) <$> headmap <*> tailmap 118 | 119 | (FromTo from to) -> do 120 | headmap <- matchPatternL from l modu 121 | 122 | tailmap <- case from of 123 | (L l (HsOverLit ext (OverLit extlit (HsIntegral (IL text neg val)) witness))) -> do 124 | case to of 125 | (L _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ _ toval)) _))) -> do 126 | let newval = val+1 127 | let newlit = (L l (HsOverLit ext (OverLit extlit (HsIntegral (IL (SourceText (show $ newval)) neg (newval))) witness))) 128 | 129 | let newseq = (ArithSeq xarith synexp (From newlit)) 130 | 131 | if (newval == toval) then 132 | matchPattern (ExplicitList NoExtField Nothing [newlit]) r modu 133 | else 134 | matchPattern (ArithSeq xarith synexp (FromTo newlit to)) r modu 135 | _ -> 136 | return Nothing 137 | 138 | _ -> 139 | return Nothing 140 | 141 | return $ (++) <$> headmap <*> tailmap 142 | 143 | _ -> do 144 | return Nothing 145 | _ -> do 146 | return Nothing 147 | 148 | 149 | matchPattern (HsLit _ str@(HsString _ _ )) (L _(ConPatIn op (InfixCon l r))) modu = do 150 | case (showSDocUnsafe $ ppr op) of 151 | ":" -> do 152 | let s = init $ tail $ showSDocUnsafe $ ppr str 153 | if (null s) 154 | then return Nothing 155 | else do 156 | let headchar = (HsLit NoExtField (HsChar (SourceText $ "'" ++ [(head s)] ++"'") (head s))) :: HsExpr GhcPs 157 | let tailstring = (HsLit NoExtField (HsString (SourceText $ "\"" ++ (tail s) ++ "\"") (mkFastString $ tail s))) :: HsExpr GhcPs 158 | headmap <- matchPattern headchar l modu 159 | tailmap <- matchPattern tailstring r modu 160 | 161 | return $ (++) <$> headmap <*> tailmap 162 | _ -> return Nothing 163 | 164 | --Currently only empty list (and constructors) 165 | matchPattern expr pat@(L _ (ConPatIn op (PrefixCon _ ))) _ = do 166 | case (showSDocUnsafe $ ppr op) of 167 | "[]" -> do 168 | let exprstring = showSDocUnsafe $ ppr expr 169 | if (exprstring == "[]") || (exprstring == "\"\"") 170 | then return (Just []) 171 | else return Nothing 172 | name -> if (name == (showSDocUnsafe $ ppr expr)) then return (Just []) else return Nothing 173 | 174 | matchPattern (ExplicitTuple _ contents _) (L _ (TuplePat _ pats _)) modu = do 175 | let matches = [(con, pat) | ((L _ (Present _ con)), pat) <- zip contents pats ] 176 | 177 | maps <- mapM (\(expr,pattern) -> matchPatternL expr pattern modu) matches 178 | 179 | return $ conMaybes maps 180 | 181 | matchPattern (ExplicitList _ _ exprs) (L _ (ListPat _ pats)) modu = do 182 | maps <- mapM (\(expr,pattern) -> matchPatternL expr pattern modu) (zip exprs pats) 183 | 184 | return $ conMaybes maps 185 | 186 | matchPattern _ (L _ (WildPat _)) _ = return $ Just [] -- Matches against `_` 187 | 188 | matchPattern expr (L _ pat@(NPat _ _ _ _)) _ = do 189 | let exprstr = showSDocUnsafe $ ppr expr 190 | let patstr = showSDocUnsafe $ ppr pat 191 | 192 | if (exprstr == patstr) 193 | then return (Just []) 194 | else return Nothing 195 | 196 | matchPattern expr (L _ (AsPat _ id pat)) modu = do 197 | let leftmap = Just [(showSDocUnsafe $ ppr id, expr)] 198 | 199 | rightmap <- matchPattern expr pat modu 200 | 201 | return $ (++) <$> leftmap <*> rightmap 202 | 203 | matchPattern _ _ _ = return Nothing 204 | 205 | 206 | --For when has located expressions 207 | matchPatternsL :: [LHsExpr GhcPs] -> [LPat GhcPs] -> (ScTypes.ModuleInfo) -> IO(Maybe (Map.Map String (HsExpr GhcPs))) 208 | matchPatternsL exprs patterns modu = do 209 | let exprs' = map (\(L _ expr) -> expr) exprs 210 | matchPatterns exprs' patterns modu 211 | 212 | --Single located expression 213 | matchPatternL :: (LHsExpr GhcPs) -> (LPat GhcPs) -> (ScTypes.ModuleInfo) -> IO(Maybe ([(String, (HsExpr GhcPs))])) 214 | matchPatternL (L _ expr) pattern modu = matchPattern expr pattern modu 215 | 216 | conMaybes :: [Maybe [a]] -> Maybe [a] 217 | conMaybes [] = Just [] 218 | conMaybes (Nothing:_) = Nothing 219 | conMaybes (x:xs) = (++) <$> x <*> (conMaybes xs) 220 | 221 | splitList :: (LHsExpr GhcPs) -> (ScTypes.ModuleInfo) -> IO (Maybe (LHsExpr GhcPs, LHsExpr GhcPs)) 222 | 223 | splitList (L l (ExplicitList xep syn (expr:exprs))) _ = return $ Just (expr, (L l (ExplicitList xep syn exprs))) 224 | 225 | splitList (L l (ArithSeq xarith synexp seqInfo)) _ = do 226 | case seqInfo of 227 | (From expr) -> do 228 | let head = expr 229 | tail <- case expr of 230 | (L _ (HsOverLit ext (OverLit extlit (HsIntegral (IL text neg val)) witness))) -> do 231 | let newseq = (ArithSeq xarith synexp (From (L l (HsOverLit ext (OverLit extlit (HsIntegral (IL (SourceText (show $ val+1)) neg (val+1))) witness))))) 232 | return newseq 233 | return $ Just (head, (L l tail)) 234 | 235 | (FromTo from to) -> do 236 | let head = from 237 | 238 | tail <- case from of 239 | (L l (HsOverLit ext (OverLit extlit (HsIntegral (IL text neg val)) witness))) -> do 240 | case to of 241 | (L _ (HsOverLit _ (OverLit _ (HsIntegral (IL _ _ toval)) _))) -> do 242 | let newval = val+1 243 | let newlit = (L l (HsOverLit ext (OverLit extlit (HsIntegral (IL (SourceText (show $ newval)) neg (newval))) witness))) 244 | 245 | let newseq = (ArithSeq xarith synexp (From newlit)) 246 | 247 | if (newval == toval) then 248 | return $ Just (ExplicitList NoExtField Nothing [newlit]) 249 | else 250 | return $ Just (ArithSeq xarith synexp (FromTo newlit to)) 251 | _ -> return Nothing 252 | case tail of 253 | (Just t) -> return $ Just (head , (L l t)) 254 | _ -> return Nothing 255 | _ -> do 256 | return Nothing 257 | 258 | splitList (L _ (OpApp _ lhs oper rhs)) _ = do 259 | case (showSDocUnsafe $ ppr $ Tools.removeLPars oper) of 260 | "(:)" -> do 261 | return $ Just (lhs, rhs) 262 | _ -> return Nothing 263 | 264 | splitList (L _ (HsPar _ expr)) modu = splitList expr modu 265 | 266 | 267 | splitList _ _ = return Nothing 268 | 269 | couldAllMatch :: [(HsExpr GhcPs)] -> [(LPat GhcPs)] -> IO(Bool) 270 | couldAllMatch exprs pats = and <$> mapM (uncurry couldMatch) (zip exprs pats) 271 | 272 | couldMatch :: (HsExpr GhcPs) -> (LPat GhcPs) -> IO(Bool) 273 | couldMatch expr (L _ (VarPat _ _)) = return True 274 | couldMatch (HsPar _ (L _ expr)) (L _ (ParPat _ pat)) = couldMatch expr pat 275 | couldMatch (HsPar _ (L _ expr)) pat = couldMatch expr pat 276 | couldMatch expr (L _ (ParPat _ pat)) = couldMatch expr pat 277 | couldMatch (ExplicitList xep syn (expr:exprs)) (L _(ConPatIn op (InfixCon l r))) = do 278 | case (showSDocUnsafe $ ppr op) of 279 | ":" -> do 280 | let headexpr = (\(L _ x) -> x) expr 281 | lhs <- couldMatch headexpr l 282 | 283 | let taillist = (ExplicitList xep syn exprs) 284 | rhs <- couldMatch taillist r 285 | 286 | return $ lhs && rhs 287 | 288 | _ -> do 289 | error "Unsupported ConPatIn found" 290 | couldMatch (ExplicitList xep syn []) (L _(ConPatIn op (InfixCon l r))) = do 291 | case (showSDocUnsafe $ ppr op) of 292 | ":" -> return False 293 | _ -> do 294 | error "Unsupported ConPatIn found" 295 | couldMatch (ExplicitList _ _ exprs) (L _ (ListPat _ pats)) = do 296 | if ((length exprs) /= (length pats)) 297 | then return False 298 | else do 299 | results <- mapM (\((L _ expr),pattern) -> couldMatch expr pattern) (zip exprs pats) 300 | return $ and results 301 | 302 | couldMatch (ExplicitList _ _ _) _ = return False 303 | 304 | couldMatch (OpApp xop (L _ lhs) oper (L _ rhs)) pat@(L _(ConPatIn op (InfixCon l r))) = do 305 | case (showSDocUnsafe $ ppr op) of 306 | ":" -> do 307 | case (showSDocUnsafe $ ppr $ Tools.removeLPars oper) of 308 | "(:)" -> do 309 | headresult <- couldMatch lhs l 310 | tailresult <- couldMatch rhs r 311 | return $ headresult && tailresult 312 | "(++)" -> do -- lhs might be empty, and still have a match. 313 | --The lhs *should* be an explicit list with one element. 314 | case lhs of 315 | (HsPar _ lhs') -> couldMatch (OpApp xop lhs' oper (noLoc rhs)) pat 316 | (ExplicitList _ _ [(L _ lhselem)]) -> do 317 | headresult <- couldMatch lhselem l 318 | tailresult <- couldMatch rhs r 319 | return $ headresult && tailresult 320 | (ExplicitList _ _ []) -> couldMatch rhs pat --Check in the rhs for non-empty lists 321 | _ -> return False 322 | _ -> return False 323 | 324 | _ -> do 325 | let opname = "(" ++ (showSDocUnsafe $ ppr op) ++ ")" 326 | if (opname == (showSDocUnsafe $ ppr $ Tools.removeLPars oper)) 327 | then do 328 | headresult <- couldMatch lhs l 329 | tailresult <- couldMatch rhs r 330 | return $ headresult && tailresult 331 | else return False 332 | 333 | --When a constructor has just one component 334 | couldMatch (HsApp xep (L _ lhs) (L _ rhs) ) (L l (ConPatIn op (PrefixCon ([arg])))) = do 335 | let lhsstring = showSDocUnsafe $ ppr lhs 336 | let opstring = showSDocUnsafe $ ppr op 337 | 338 | if (lhsstring == opstring) 339 | then couldMatch rhs arg 340 | else return False 341 | --When it has more than one 342 | couldMatch (HsApp xep (L _ lhs) (L _ rhs) ) (L l (ConPatIn op (PrefixCon args))) = do 343 | if (null args) then return False 344 | else do 345 | innermatch <- couldMatch lhs (L l (ConPatIn op (PrefixCon (init args)))) 346 | outermatch <- couldMatch rhs (last args) 347 | return $ innermatch && outermatch 348 | couldMatch (ArithSeq xarith synexp seqInfo) (L _(ConPatIn op (InfixCon l r))) = do 349 | case (showSDocUnsafe $ ppr op) of 350 | ":" -> do 351 | case seqInfo of 352 | (From (L _ expr)) -> do 353 | headmap <- couldMatch expr l 354 | tailmap <- case expr of 355 | (HsOverLit ext (OverLit extlit (HsIntegral (IL text neg val)) witness)) -> do 356 | let newseq = (ArithSeq xarith synexp (From (noLoc (HsOverLit ext (OverLit extlit (HsIntegral (IL (SourceText (show $ val+1)) neg (val+1))) witness))))) 357 | couldMatch newseq r 358 | _ -> return False 359 | return $ headmap && tailmap 360 | 361 | (FromTo (L _ from) (L _ to)) -> do 362 | headmap <- couldMatch from l 363 | 364 | tailmap <- case from of 365 | (HsOverLit ext (OverLit extlit (HsIntegral (IL text neg val)) witness)) -> do 366 | case to of 367 | (HsOverLit _ (OverLit _ (HsIntegral (IL _ _ toval)) _)) -> do 368 | let newval = val+1 369 | let newlit = (noLoc (HsOverLit ext (OverLit extlit (HsIntegral (IL (SourceText (show $ newval)) neg (newval))) witness))) :: (LHsExpr GhcPs) 370 | 371 | let newseq = (ArithSeq xarith synexp (From newlit)) 372 | 373 | if (newval == toval) then 374 | couldMatch (ExplicitList NoExtField Nothing [newlit]) r 375 | else 376 | couldMatch (ArithSeq xarith synexp (FromTo newlit (noLoc to))) r 377 | _ -> 378 | return False 379 | 380 | _ -> 381 | return False 382 | 383 | return $ headmap && tailmap 384 | 385 | _ -> do 386 | return False 387 | _ -> do 388 | return False 389 | couldMatch seq@(ArithSeq _ _ _ ) pattern = return $ (showSDocUnsafe $ ppr pattern) /= "[]" 390 | --Currently only empty list 391 | couldMatch (HsLit _ str@(HsString _ _)) (L _ (ConPatIn op (PrefixCon _))) = do 392 | let s = showSDocUnsafe $ ppr str 393 | case (showSDocUnsafe $ ppr op) of 394 | "[]" -> return (null s) 395 | _ -> return False 396 | 397 | couldMatch _ (L _ (ConPatIn op (PrefixCon _ ))) = do 398 | case (showSDocUnsafe $ ppr op) of 399 | "[]" -> return True 400 | _ -> return False 401 | couldMatch (ExplicitTuple _ contents _) (L _ (TuplePat _ pats _)) = do 402 | if ((length contents) /= (length pats)) 403 | then return False 404 | else do 405 | let matches = [(con, pat) | ((L _ (Present _ con)), pat) <- zip contents pats ] 406 | 407 | maps <- mapM (\((L _ expr),pattern) -> couldMatch expr pattern) matches 408 | 409 | return $ and maps 410 | 411 | couldMatch _ (L _ (WildPat _)) = return True 412 | --When matching against a literal 413 | couldMatch expr@(HsOverLit _ _) (L _ pat@(NPat _ _ _ _)) = do 414 | let exprstr = showSDocUnsafe $ ppr expr 415 | let patstr = showSDocUnsafe $ ppr pat 416 | 417 | return (exprstr == patstr) 418 | couldMatch expr@(HsLit _ _) (L _ pat@(NPat _ _ _ _)) = do 419 | let exprstr = showSDocUnsafe $ ppr expr 420 | let patstr = showSDocUnsafe $ ppr pat 421 | 422 | return (exprstr == patstr) 423 | 424 | couldMatch (HsLit _ _) _ = return False 425 | couldMatch (HsOverLit _ _) _ = return False 426 | couldMatch _ (L _ (NPat _ _ _ _)) = return True 427 | couldMatch expr (L _ (AsPat _ _ pat)) = couldMatch expr pat 428 | couldMatch expr@(HsVar _ _) pat = return ((showSDocUnsafe $ ppr expr) == (showSDocUnsafe $ ppr pat)) 429 | couldMatch exp _ = return True 430 | 431 | --Takes a part of the pattern and returns it's components 432 | nameFromPatternComponent :: (LPat GhcPs) -> [String] 433 | nameFromPatternComponent (L _ (VarPat _ (L _ name))) = [occNameString $ rdrNameOcc name] -- For single strings? 434 | nameFromPatternComponent (L _ (ConPatIn (L _ name) (InfixCon l r))) = (nameFromPatternComponent l) ++ (nameFromPatternComponent r) -- For (x:xs) patterns 435 | nameFromPatternComponent (L _ (ConPatIn (L _ name) (PrefixCon members))) = concat $ map nameFromPatternComponent members -- For constructor patterns 436 | nameFromPatternComponent (L _ (ConPatIn (L _ name) _)) = [occNameString $ rdrNameOcc name] 437 | nameFromPatternComponent (L _ (ParPat _ name)) = nameFromPatternComponent name --Things in parenthesis 438 | nameFromPatternComponent (L _ (TuplePat _ members _)) = concat $ map nameFromPatternComponent members --Tuples 439 | nameFromPatternComponent (L _ (WildPat (NoExtField))) = [] -- For '_' patterns 440 | nameFromPatternComponent (L _ (LitPat _ _)) = [] -- Literals do not need to be moved in 441 | nameFromPatternComponent (L _ (NPat _ _ _ _)) = [] 442 | nameFromPatternComponent (L _ (ListPat _ pats)) = concat $ map nameFromPatternComponent pats 443 | nameFromPatternComponent e = error $ "Unsupported type in pattern matching :" ++ (showSDocUnsafe $ ppr e) -------------------------------------------------------------------------------- /src/EvalStage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, TypeApplications, TypeFamilies #-} 2 | {-# OPTIONS_GHC -Wno-missing-fields #-} 3 | 4 | module EvalStage where 5 | 6 | import "ghc-lib-parser" GHC.Hs 7 | import "ghc-lib-parser" SrcLoc 8 | import "ghc-lib-parser" RdrName 9 | import "ghc-lib-parser" OccName 10 | import "ghc-lib-parser" Outputable 11 | import "ghc-lib-parser" DynFlags 12 | import "ghc-lib-parser" GHC.Hs.Binds 13 | import "ghc-lib-parser" BasicTypes 14 | import "ghc-lib-parser" TcEvidence 15 | 16 | 17 | import qualified Data.Map.Strict as Map 18 | import Data.List 19 | import Data.Either 20 | import Data.Char 21 | import Data.Maybe 22 | import Bag 23 | import Control.Monad 24 | import Control.Monad.State 25 | 26 | import Tools 27 | import ScTypes 28 | import FormalActualMap 29 | import DefinitionGetter 30 | import NormalFormReducer 31 | import PrepStage 32 | 33 | 34 | --The Integer is how many variables are bound to the Found function 35 | --The String is the name of the function 36 | data TraverseResult = Reduced | NotFound | Found Integer String | Constructor deriving (Eq) 37 | 38 | --Execute the computation fully 39 | execute :: (LHsDecl GhcPs) -> ScTypes.ModuleInfo -> String -> DynFlags -> StateT ScTypes.EvalState IO(LHsDecl GhcPs) 40 | execute decl funMap prevline flags = do 41 | (newdecl, changed) <- EvalStage.evalDecl decl funMap flags 42 | case changed of 43 | Reduced -> do 44 | let newline = (showSDocUnsafe $ ppr newdecl) 45 | 46 | if (newline /= prevline) then do 47 | let newlines = lines newline 48 | liftIO $ putStrLn $ " = " ++ (head newlines) 49 | 50 | liftIO $ mapM_ (\x -> putStrLn (" " ++ x)) (tail newlines) --Print the other lines 51 | 52 | 53 | else do 54 | return () 55 | execute newdecl funMap newline flags 56 | _ -> do 57 | return $ decl 58 | 59 | --Do one stage of evaluation on the Decl -- Has to be IO as we make calls to GHCi 60 | evalDecl :: (LHsDecl GhcPs) -> ScTypes.ModuleInfo -> DynFlags -> StateT ScTypes.EvalState IO(LHsDecl GhcPs, TraverseResult) 61 | evalDecl (L l(SpliceD a (SpliceDecl b (L c (HsUntypedSplice d e f expr)) g ))) modu flags = do 62 | (expr', result) <- evalExpr expr modu Map.empty flags 63 | 64 | --Remove pars if needed 65 | let expr'' = case expr' of (L _ (HsPar _ exp)) -> exp ; _ -> expr' 66 | 67 | let decl' = (L l (SpliceD a (SpliceDecl b (L c (HsUntypedSplice d e f expr'')) g ))) --Return our declaration to the correct context 68 | return (decl', result) 69 | evalDecl _ _ _ = error "Should be evaluating SpliceD" 70 | 71 | --Evaluating an expression 72 | -- Will be evaluating the LHS of any expression first, so only one will be expanded at a time 73 | --Each case will be a bit different 74 | evalExpr :: (LHsExpr GhcPs) -> ScTypes.ModuleInfo -> ScTypes.ModuleInfo -> DynFlags -> StateT ScTypes.EvalState IO(LHsExpr GhcPs, TraverseResult) 75 | 76 | --Found a variable, if it is one of our functions, return we have found it 77 | --If it is one of our varibles then do a substitution for the value 78 | evalExpr var@(L l (HsVar xVar id)) funcMap hidden flags = do 79 | let name = showSDocUnsafe $ ppr id 80 | 81 | if (isUpper $ head $ name) 82 | then return (var, Constructor) 83 | else 84 | if (Map.member name funcMap) 85 | then do 86 | let n = numargs (funcMap Map.! name ) 87 | if (n == 0) 88 | then evalApp (L l (HsVar xVar id)) funcMap hidden flags 89 | else return ((L l (HsVar xVar id)), Found 0 name) --This is a function which requires more arguments 90 | else do 91 | return (var, NotFound) 92 | 93 | --Dealing with 'seq' 94 | evalExpr expression@(L _ (HsApp _ (L _ (HsApp _ func@(L _ (HsVar _ id)) lhs)) rhs)) funcMap hidden flags 95 | | (showSDocUnsafe $ ppr id) == "seq" = do 96 | filename <- snd <$> get 97 | lhsfinished <- lift $ fullyReduced lhs funcMap hidden flags filename 98 | if lhsfinished then return (rhs, Reduced) 99 | else do 100 | (lhs', lhsresult) <- evalExpr lhs funcMap hidden flags 101 | return (noLoc (HsApp NoExtField (noLoc (HsApp NoExtField func lhs'))rhs) , lhsresult) 102 | 103 | --The case of the dot operator 104 | evalExpr (L _ (HsApp _ (L _ (OpApp _ lfunc op rfunc)) rhs)) _ _ _ | (showSDocUnsafe $ ppr op) == "(.)" = do 105 | let new_rhs = noLoc (HsApp NoExtField rfunc rhs) :: LHsExpr GhcPs 106 | let result = noLoc (HsApp NoExtField lfunc (noLoc (HsPar NoExtField new_rhs))) :: LHsExpr GhcPs 107 | 108 | return (result, Reduced) 109 | 110 | --The case of the dot operator (with parenthesis) 111 | evalExpr (L _ (HsApp _ (L _ (HsPar _ (L _ (OpApp _ lfunc op rfunc)))) rhs)) _ _ _ | (showSDocUnsafe $ ppr op) == "(.)" = do 112 | let new_rhs = noLoc (HsApp NoExtField rfunc rhs) :: LHsExpr GhcPs 113 | let result = noLoc (HsApp NoExtField lfunc (noLoc (HsPar NoExtField new_rhs))) :: LHsExpr GhcPs 114 | 115 | return (result, Reduced) 116 | 117 | --Dealing with lambda expressions 118 | evalExpr (L _ (HsApp _ lambda@(L _ (HsPar _ (L _ (HsLam _ (MG _ (L _ [(L _ (Match _ _ [pattern] (GRHSs _ [L _ (GRHS _ _ (L _ def))] _) ))]) _))))) (L _ argument))) modu hidden flags = do 119 | valmap <- lift $ FormalActualMap.matchPattern argument pattern modu 120 | case valmap of 121 | Nothing -> do 122 | (rhs', result) <- evalExpr (noLoc argument) modu hidden flags 123 | 124 | return (noLoc (HsApp NoExtField lambda rhs'), result) 125 | (Just vmap) -> do 126 | let vmap' = Map.fromList vmap 127 | 128 | -- The initial arg counts 129 | let argcounts = countArgs (Map.fromList (zip (Map.keys vmap') (repeat 0))) def 130 | let repeated = Map.keys $ Map.filter (>1) argcounts 131 | 132 | filename <- snd <$> get 133 | --The arguments which need to be bound in a let expression 134 | toBind <- lift $ filterM (\x -> fmap not (fullyReduced (noLoc $ vmap' Map.! x) modu hidden flags filename)) repeated 135 | 136 | --Remove the values which need to be bound 137 | let vmap'' = foldr Map.delete vmap' toBind -- The vmap of expressions that need to be subbed in 138 | 139 | expr' <- subValues def vmap'' True--Substitute formals for actuals 140 | 141 | --Create a let expression for each bound value 142 | expr'' <- foldM (\exp -> (\name -> createLetExpression exp name True (vmap' Map.! name))) expr' toBind 143 | 144 | return (noLoc expr'', Reduced) 145 | 146 | 147 | --Applicaton statement 148 | evalExpr application@(L l (HsApp xApp lhs rhs)) funcMap hidden flags = do 149 | (lhs' , lhsresult) <- evalExpr lhs funcMap hidden flags --Traverse the lhs 150 | (rhs' , rhsresult) <- evalExpr rhs funcMap hidden flags-- Traverse the rhs 151 | case lhsresult of 152 | (Found i name) -> do 153 | argsNeeded <- case (funcMap Map.!? name) of 154 | (Just funcinfo) -> return (numargs funcinfo) 155 | _ -> error $ Tools.errorMessage ++ name ++ " not found in funcMap - evalExpr" 156 | 157 | if (argsNeeded == (i + 1)) -- +1 because including the argument in the rhs of this application 158 | then evalApp application funcMap hidden flags 159 | else return (application, (Found (i+1) name)) --Go up a level and try and find more argument 160 | 161 | NotFound -> do --In this case explore the rhs 162 | case rhsresult of 163 | Reduced -> do 164 | let newApp = (L l (HsApp xApp lhs (removeLPars rhs'))) 165 | return (newApp, rhsresult) 166 | -- Attempt to evaluate 167 | _ -> do 168 | filename <- snd <$> get 169 | collapsed <- lift $ NormalFormReducer.reduceNormalForm application flags filename (Map.keys (Map.union funcMap hidden)) 170 | 171 | case collapsed of 172 | Nothing -> return (application, NotFound) 173 | (Just expr) -> return (expr, Reduced) 174 | 175 | Constructor -> do --In this case a constructor. 176 | case rhsresult of 177 | Reduced -> do 178 | let newApp = (L l (HsApp xApp lhs (removeLPars rhs'))) 179 | return (newApp, Reduced) 180 | _ -> 181 | return (application, Constructor) 182 | 183 | _ -> return ((L l (HsApp xApp lhs' rhs)), lhsresult) 184 | 185 | evalExpr application@(L l (OpApp xop lhs op rhs)) funcMap hidden flags = do 186 | (op', opresult) <- evalExpr op funcMap hidden flags -- Try and reduce the op. 187 | 188 | case opresult of 189 | Reduced -> return ((L l (OpApp xop lhs op' rhs)), Reduced) 190 | (Found i name) -> do 191 | argsNeeded <- case (funcMap Map.!? name) of 192 | (Just funcinfo) -> return (numargs funcinfo) 193 | _ -> error $ Tools.errorMessage ++ name ++ " not found in funcMap - evalExpr" 194 | 195 | if (argsNeeded == (i + 2)) -- +1 because including the argument in the rhs of this application 196 | then evalApp application funcMap hidden flags 197 | else return (application, (Found (i+2) name)) --Go up a level and try and find more argument 198 | 199 | 200 | _ -> do 201 | (lhs' , lhsresult) <- evalExpr lhs funcMap hidden flags--Traverse the lhs 202 | 203 | let thisApp = (L l (OpApp xop lhs' op rhs)) 204 | 205 | (hsapp, found) <- case lhsresult of 206 | Reduced -> return (thisApp, Reduced) 207 | _ -> do 208 | (rhs', rhsresult) <- evalExpr rhs funcMap hidden flags --Traverse rhs 209 | case rhsresult of 210 | Reduced -> do 211 | return (L l (OpApp xop lhs' op rhs'), rhsresult) 212 | _ -> do 213 | let funname = showSDocUnsafe $ ppr $ op 214 | 215 | if (Map.member funname funcMap) 216 | then evalApp (L l (HsApp NoExtField (L l (HsApp NoExtField op lhs)) rhs)) funcMap hidden flags --Treat it as a prefix operation 217 | else do 218 | filename <- snd <$> get 219 | reduced <- lift $ NormalFormReducer.reduceNormalForm application flags filename (Map.keys (Map.union funcMap hidden)) 220 | case reduced of 221 | Nothing -> return (application, NotFound) 222 | (Just normal) -> return (normal, Reduced) 223 | 224 | return (hsapp, found) 225 | 226 | --Deal with parentheses 227 | evalExpr (L l (HsPar xpar expr)) funcMap hidden flags = do 228 | (expr', found) <- evalExpr expr funcMap hidden flags 229 | return ((L l (Tools.removePars (HsPar xpar expr'))), found) 230 | 231 | --Deal with if/else statement 232 | evalExpr orig@(L l (HsIf xif syn cond lhs rhs)) funcMap hidden flags = do 233 | 234 | let condstr = showSDocUnsafe $ ppr $ Tools.removeLPars cond 235 | 236 | case condstr of 237 | "True" -> return (lhs, Reduced) 238 | "False" -> return (rhs, Reduced) 239 | _ -> do 240 | (cond' , replaced) <- evalExpr cond funcMap hidden flags 241 | 242 | case replaced of 243 | Reduced -> return ((L l (HsIf xif syn cond' lhs rhs)), Reduced) 244 | _ -> do 245 | filename <- snd <$> get 246 | collapsed <- lift $ NormalFormReducer.reduceNormalForm cond flags filename (Map.keys (Map.union funcMap hidden)) 247 | case collapsed of 248 | (Just cond'') -> return ((L l (HsIf xif syn cond'' lhs rhs)), Reduced) 249 | _ -> return (orig, NotFound) 250 | 251 | --Deal with lists 252 | evalExpr (L l (ExplicitList xep msyn (expr:exprs))) funcMap hidden flags = do 253 | (expr' , replaced) <- evalExpr expr funcMap hidden flags 254 | 255 | case replaced of 256 | Reduced -> return ((L l (ExplicitList xep msyn (expr':exprs))), Reduced) 257 | 258 | _ -> do 259 | ((L l (ExplicitList _ _ exprs')), replaced') <- evalExpr (L l (ExplicitList xep msyn exprs)) funcMap hidden flags 260 | return ((L l (ExplicitList xep msyn (expr:exprs'))), replaced') 261 | 262 | evalExpr (L l (ExplicitList xep msyn [])) _ _ _ = do 263 | return ((L l (ExplicitList xep msyn [])), NotFound) 264 | 265 | --Deal with tuples 266 | evalExpr (L l (ExplicitTuple xtup (expr:exprs) box)) funcMap hidden flags = do 267 | case expr of 268 | (L l' (Present xpres tupexp)) -> do 269 | (expr' , replaced) <- evalExpr tupexp funcMap hidden flags 270 | case replaced of 271 | Reduced -> do 272 | let tuple = (L l' (Present xpres expr')) 273 | return ((L l (ExplicitTuple xtup (tuple:exprs) box)), Reduced) 274 | 275 | _ -> do 276 | ((L l (ExplicitTuple _ exprs' _)), replaced') <- evalExpr (L l (ExplicitTuple xtup exprs box)) funcMap hidden flags 277 | return ((L l (ExplicitTuple xtup (expr:exprs') box)), replaced') 278 | 279 | _ -> do 280 | ((L l (ExplicitTuple _ exprs' _)), replaced') <- evalExpr (L l (ExplicitTuple xtup exprs box)) funcMap hidden flags 281 | return ((L l (ExplicitTuple xtup (expr:exprs') box)), replaced') 282 | 283 | evalExpr (L l (ExplicitTuple xtup [] box)) _ _ _ = do 284 | return ((L l (ExplicitTuple xtup [] box)), NotFound) 285 | 286 | --List comprehensions 287 | evalExpr comp@(L l (HsDo xDo ListComp (L l' (stmt: stmts)))) funcMap hidden flags = do 288 | case stmt of 289 | 290 | -- Try and pattern match (x:xs) against it. If this fails then attempt to expand it. 291 | -- Need to work out if it is empty? 292 | -- Utilise the definition getter for this work. 293 | 294 | (L l (BindStmt a pat lexpr@(L _ expr) e f)) -> do 295 | filename <- snd <$> get 296 | exprNotEmpty <- lift $ matchesPattern expr "(x:xs)" funcMap filename 297 | 298 | if (not exprNotEmpty) then 299 | -- Returns an empty list. 300 | return ((L l (ExplicitList NoExtField Nothing [])), Reduced) 301 | else do 302 | maybehead <- lift $ FormalActualMap.splitList lexpr funcMap 303 | case maybehead of 304 | Nothing -> do 305 | (newexpr, res) <- evalExpr lexpr funcMap hidden flags 306 | let newstmt = (L l (BindStmt a pat newexpr e f)) 307 | let newcomp = ((L l (HsDo xDo ListComp (L l' (newstmt: stmts))))) 308 | return (newcomp, res) 309 | 310 | Just (headexpr, tailexpr) -> do 311 | let newcomp = (HsDo xDo ListComp (L l' stmts)) 312 | map <- lift $ FormalActualMap.matchPatternL headexpr pat funcMap 313 | 314 | lhs <- case map of 315 | Nothing -> 316 | return (L l (ExplicitList NoExtField Nothing [])) 317 | Just m -> do 318 | -- Create the new lists. 319 | newlistcomps <- subValues newcomp (Map.fromList m) False 320 | return $ listCompFinished $ noLoc newlistcomps 321 | 322 | case (showSDocUnsafe $ ppr tailexpr) of 323 | "[]" -> 324 | return (lhs, Reduced) 325 | _ -> do 326 | let newstmts = (L l (BindStmt a pat tailexpr e f)) : stmts 327 | 328 | let finalexpr = combineLists [lhs, (L l (HsDo xDo ListComp (L l' newstmts)))] 329 | 330 | return (finalexpr, Reduced) 331 | 332 | (L l (BodyStmt ext condition lexpr rexpr)) -> do 333 | (condition', replaced) <- evalExpr condition funcMap hidden flags --Evaluate the condition 334 | 335 | case replaced of 336 | Reduced -> do 337 | let newcond = (L l (BodyStmt ext condition' lexpr rexpr)) 338 | let newcomp = (L l (HsDo xDo ListComp (L l' (newcond: stmts)))) 339 | return (newcomp, Reduced) 340 | _ -> do 341 | let condstring = showSDocUnsafe $ ppr condition' 342 | if condstring == "True" 343 | then do 344 | case stmts of 345 | [(L l (LastStmt _ body _ _))] -> do 346 | return ((L l (ExplicitList NoExtField Nothing [body])), Reduced) 347 | _ -> do 348 | let newcomp = (L l (HsDo xDo ListComp (L l' stmts))) 349 | return (newcomp, Reduced) 350 | else 351 | return ((L l (ExplicitList NoExtField Nothing [])), Reduced) 352 | (L l (LastStmt _ body _ _)) -> do --If only has a body left 353 | return ((L l (ExplicitList NoExtField Nothing [body])), NotFound) 354 | _ -> do 355 | return (comp, NotFound) 356 | 357 | -- Let expressions - currently doesn't support pattern matching in the bind. 358 | evalExpr letexpr@(L l (HsLet xlet (L _ localbinds) lexpr@(L _ expr))) funcMap hidden flags = do 359 | 360 | case localbinds of 361 | HsValBinds a (ValBinds b bag c) -> do --Add the fully reduced expressions to the context 362 | 363 | let expressions = bagToList bag 364 | 365 | let defs = map PrepStage.prepBind expressions 366 | 367 | let names = map (\x -> head $ Map.keys x) defs 368 | let counts = countArgs (Map.fromList $ zip names (repeat 0)) expr 369 | 370 | if (sum $ Map.elems counts) == 0 then return (lexpr, Reduced) 371 | else do 372 | --Remove keys from map which are defined in this let binding 373 | let funcMap' = foldr Map.delete funcMap (concatMap Map.keys defs) 374 | let hidden' = foldr Map.delete hidden (concatMap Map.keys defs) 375 | 376 | filename <- snd <$> get 377 | fullyReducedDefs <- lift $ filterM (\x -> fullyReduced (noLoc $ getDefFromBind x) funcMap hidden flags filename) expressions 378 | nonFullyReducedDefs <- lift $ filterM (\x -> not <$> fullyReduced (noLoc $ getDefFromBind x) funcMap hidden flags filename) expressions 379 | 380 | let newDefs = map PrepStage.prepBind fullyReducedDefs 381 | let newHiddenDefs = map PrepStage.prepBind nonFullyReducedDefs 382 | 383 | let newDefsUnions = Map.union funcMap' (Map.unions newDefs) 384 | let newHiddenDefsUnions = Map.union hidden' (Map.unions newHiddenDefs) 385 | 386 | (lexpr', result) <- evalExpr lexpr newDefsUnions newHiddenDefsUnions flags 387 | 388 | case result of 389 | Reduced -> return ((L l (HsLet xlet (L l localbinds) lexpr')), result) 390 | _ -> do --Reduce an expression in the let (if possible) 391 | let defs = Map.union newDefsUnions (Map.unions newHiddenDefs) -- Including everything defined in this function (because letrecs) 392 | 393 | (expressions', newlets , result') <- evalLetBindings expressions defs hidden' flags 394 | let bag' = listToBag expressions' 395 | let localbinds' = HsValBinds a (ValBinds b bag' c) 396 | 397 | let newlet = (HsLet xlet (L l localbinds') lexpr) 398 | 399 | newlet' <- foldM (\base -> (\(exp,name) -> createLetExpression base name False exp)) newlet newlets 400 | 401 | return (noLoc newlet', result') 402 | 403 | _ -> error "Error in let expression" 404 | 405 | evalExpr lit@(L l (HsLit xlit hslit)) _ _ _ = return (lit, NotFound) 406 | 407 | evalExpr lit@(L l (HsOverLit xlit hslit)) _ _ _ = return (lit, NotFound) 408 | 409 | evalExpr (L l (NegApp xneg expr syn)) funcMap hidden flags = do 410 | (newexp, result) <- evalExpr expr funcMap hidden flags 411 | 412 | return ((L l (NegApp xneg newexp syn)), result) 413 | 414 | evalExpr arith@(L l (ArithSeq xarith syn (From from))) funcMap hidden flags = do 415 | (from', result) <- evalExpr from funcMap hidden flags 416 | return (L l (ArithSeq xarith syn (From from')), result) 417 | 418 | evalExpr arith@(L l (ArithSeq xarith syn (FromTo from to))) funcMap hidden flags = do 419 | (from', result) <- evalExpr from funcMap hidden flags 420 | 421 | case result of 422 | Reduced -> return (L l (ArithSeq xarith syn (FromTo from' to)), result) 423 | _ -> do 424 | (to', result') <- evalExpr to funcMap hidden flags 425 | return (L l (ArithSeq xarith syn (FromTo from to')), result') 426 | 427 | evalExpr arith@(L l (ArithSeq xarith syn (FromThen from to))) funcMap hidden flags = do 428 | (from', result) <- evalExpr from funcMap hidden flags 429 | 430 | case result of 431 | Reduced -> return (L l (ArithSeq xarith syn (FromThen from' to)), result) 432 | _ -> do 433 | (to', result') <- evalExpr to funcMap hidden flags 434 | return (L l (ArithSeq xarith syn (FromThen from to')), result') 435 | 436 | evalExpr arith@(L l (ArithSeq xarith syn (FromThenTo from the to))) funcMap hidden flags = do 437 | (from', result) <- evalExpr from funcMap hidden flags 438 | 439 | case result of 440 | Reduced -> return (L l (ArithSeq xarith syn (FromThenTo from' the to)), result) 441 | _ -> do 442 | (the', result') <- evalExpr the funcMap hidden flags 443 | case result' of 444 | Reduced -> return (L l (ArithSeq xarith syn (FromThenTo from the' to)), result') 445 | _ -> do 446 | (to', result'') <- evalExpr to funcMap hidden flags 447 | return (L l (ArithSeq xarith syn (FromThenTo from the to')), result'') 448 | 449 | evalExpr hscase@(L _ (HsCase xcase (L _ expr) (MG mg_ext (L _ mg_alts) mg_origin))) funcMap hidden flags = do 450 | 451 | --Need to work out if any of the alts can match with the expression, and if so which one. 452 | let patdef = map (\(L _ (Match _ _ [pattern] (GRHSs _ [(L _ (GRHS _ _ (L _ body)))] _))) -> (pattern,body)) mg_alts 453 | 454 | possiblematch <- lift $ needreduce patdef 455 | 456 | case possiblematch of 457 | Nothing -> do 458 | (expr', result) <- evalExpr (noLoc expr) funcMap hidden flags 459 | return ((noLoc (HsCase xcase expr' (MG mg_ext (noLoc mg_alts) mg_origin))), result) 460 | (Just (vmap, def)) -> do 461 | let vmap' = Map.fromList vmap 462 | 463 | -- The initial arg counts 464 | let argcounts = countArgs (Map.fromList (zip (Map.keys vmap') (repeat 0))) def 465 | let repeated = Map.keys $ Map.filter (>1) argcounts 466 | 467 | filename <- snd <$> get 468 | --The arguments which need to be bound in a let expression 469 | toBind <- lift $ filterM (\x -> fmap not (fullyReduced (noLoc $ vmap' Map.! x) funcMap hidden flags filename)) repeated 470 | 471 | --Remove the values which need to be bound 472 | let vmap'' = foldr Map.delete vmap' toBind -- The vmap of expressions that need to be subbed in 473 | 474 | expr' <- subValues def vmap'' True--Substitute formals for actuals 475 | 476 | --Create a let expression for each bound value 477 | expr'' <- foldM (\exp -> (\name -> createLetExpression exp name True (vmap' Map.! name))) expr' toBind 478 | 479 | return (noLoc expr'', Reduced) 480 | 481 | where 482 | needreduce ((pattern, body):xs) = do 483 | canMatch <- FormalActualMap.matchPattern expr pattern (Map.union funcMap hidden) 484 | 485 | case canMatch of 486 | (Just m) -> return $ Just (m, body) 487 | Nothing -> do 488 | couldMatch <- FormalActualMap.couldMatch expr pattern 489 | if couldMatch then return Nothing else needreduce xs 490 | 491 | 492 | needreduce [] = return Nothing 493 | 494 | evalExpr expr modu hidden flags = do --If not defined for then make an attempt to reduce to normal form 495 | filename <- snd <$> get 496 | result <- lift $ NormalFormReducer.reduceNormalForm expr flags filename ((Map.keys modu) ++ (Map.keys hidden)) 497 | 498 | case result of 499 | Nothing -> return (expr, NotFound) 500 | (Just normal) -> return (normal, Reduced) 501 | 502 | --Evaluates a function (one step) 503 | --Presumes it is a function applied to the correct number of args 504 | --Currently assumes the function is not within some parenthesis (bad assumption) 505 | evalApp :: (LHsExpr GhcPs) -> ScTypes.ModuleInfo -> ScTypes.ModuleInfo -> DynFlags -> StateT EvalState IO((LHsExpr GhcPs, TraverseResult)) 506 | evalApp (L _ (OpApp _ lhs op rhs )) modu hidden flags = do 507 | (app', result) <- evalApp (noLoc (HsApp NoExtField (noLoc (HsApp NoExtField op lhs)) rhs)) modu hidden flags 508 | case (app', result) of 509 | ((L _ (HsApp _ (L _ (HsApp _ op' lhs')) rhs')), result) 510 | | (showSDocUnsafe $ ppr op) == (showSDocUnsafe $ ppr op') -> 511 | return (noLoc (OpApp NoExtField lhs' op' rhs'), result) 512 | _ -> return (app', result) 513 | 514 | evalApp lexpr@(L l expr@(HsApp _ lhs rhs)) modu hidden flags = do 515 | let (func, args) = Tools.getFuncArgs lexpr --(head exprs, tail exprs) --Get the expression(s) for the function and the arguments 516 | filename <- snd <$> get 517 | mDef <- lift $ DefinitionGetter.getDef func args (Map.union modu hidden) filename --Get the appropriate rhs given the arguments 518 | case mDef of 519 | Just (def, pattern, pats) -> do 520 | let patterns = reverse $ Map.elems pats 521 | let patstr = showSDocUnsafe $ ppr pattern 522 | let prevpats = takeWhile (\pat -> (showSDocUnsafe $ ppr pat) /= patstr) patterns 523 | 524 | --Need to check if any of the previous patterns could *still* match with the inputs. 525 | prevmatch <- lift $ mapM (\pat -> FormalActualMap.couldAllMatch args pat) prevpats 526 | 527 | if (or prevmatch) then do 528 | --This gets the other possible patterns for each variable 529 | let otherpossiblepatterns = transpose $ map snd $ filter fst (zip prevmatch prevpats) 530 | 531 | --Tuples of, the input, the proper pattern, and the other possible patterns 532 | let varpropother = zip3 args pattern otherpossiblepatterns 533 | 534 | (newargs,result) <- evalAmbiguousArguments varpropother modu hidden flags 535 | 536 | return ((applyArgs func newargs), result) 537 | else do 538 | --Get the appropriate formal-actual mapping given the arguments 539 | --But only if none of the other arguments match 540 | valmap <- lift $ FormalActualMap.matchPatterns args pattern modu 541 | 542 | case valmap of 543 | Nothing -> do 544 | --Try to evaluate the first of the arguments which doesn't pattern match 545 | (newargs, result) <- evalNonMatchingArguments (zip args pattern) modu hidden flags 546 | return ((applyArgs func newargs), result) 547 | 548 | (Just vmap) -> do 549 | -- The initial arg counts 550 | let argcounts = countArgs (Map.fromList (zip (Map.keys vmap) (repeat 0))) def 551 | let repeated = Map.keys $ Map.filter (>1) argcounts 552 | 553 | --The arguments which need to be bound in a let expression 554 | filename <- snd <$> get 555 | toBind <- lift $ filterM (\x -> fmap not (fullyReduced (noLoc $ vmap Map.! x) modu hidden flags filename)) repeated 556 | 557 | --Remove the values which need to be bound 558 | let vmap' = foldr Map.delete vmap toBind -- The vmap of expressions that need to be subbed in 559 | 560 | expr' <- subValues def vmap' True--Substitute formals for actuals 561 | 562 | --Create a let expression for each bound value 563 | expr'' <- foldM (\exp -> (\name -> createLetExpression exp name True (vmap Map.! name))) expr' toBind 564 | 565 | return (noLoc expr'', Reduced) 566 | 567 | _ -> return (lexpr, NotFound) 568 | evalApp lexpr@(L l expr@(HsVar _ _ )) modu hidden _ = do 569 | filename <- snd <$> get 570 | mdef <- lift $ DefinitionGetter.getDef expr [] modu filename 571 | case mdef of 572 | Just (def, _, _) -> return ((L l def), Reduced) 573 | _ -> return (lexpr, NotFound) 574 | 575 | --Substitues actuals into formals. functioncreation is true if being called on function creation, will make difference when creating let statements 576 | subValues :: (HsExpr GhcPs) -> (Map.Map String (HsExpr GhcPs)) -> Bool -> StateT ScTypes.EvalState IO((HsExpr GhcPs)) 577 | subValues (HsVar xvar (L l id)) vmap functioncreation = case possSub of 578 | Nothing -> return (HsVar xvar (L l id)) 579 | (Just value) -> return value 580 | where 581 | name = occNameString $ rdrNameOcc id 582 | possSub = Map.lookup name vmap 583 | 584 | subValues (HsApp xapp (L ll lhs) (L rl rhs)) vmap functioncreation = do 585 | lhs' <- subValues lhs vmap functioncreation 586 | rhs' <- subValues rhs vmap functioncreation 587 | return (HsApp xapp (L ll lhs') (L rl rhs')) 588 | subValues (OpApp xop (L ll l) (L lm m) (L lr r)) vmap functioncreation= do 589 | lhs' <- subValues l vmap functioncreation 590 | rhs' <- subValues r vmap functioncreation 591 | m' <- subValues m vmap functioncreation 592 | return (OpApp xop (L ll lhs' ) (L lm m') (L lr rhs')) 593 | subValues (HsPar xpar (L l exp)) vmap functioncreation = do 594 | exp' <- subValues exp vmap functioncreation 595 | return $ Tools.removePars (HsPar xpar (L l exp')) 596 | subValues (NegApp xneg (L l exp) synt) vmap functioncreation = do 597 | exp' <- subValues exp vmap functioncreation 598 | return (NegApp xneg (L l exp') synt) 599 | subValues (ExplicitTuple xtup elems box) vmap functioncreation = do 600 | elems' <- mapM (\expr -> subValuesTuple expr vmap functioncreation) elems 601 | return (ExplicitTuple xtup elems' box) 602 | subValues (ExplicitList xlist syn exprs) vmap functioncreation = do 603 | exprs' <- mapM (\(L l expr) -> (noLoc <$> (subValues expr vmap functioncreation))) exprs 604 | return (ExplicitList xlist syn exprs') 605 | subValues (HsIf xif syn (L _ cond) (L _ lhs) (L _ rhs)) vmap functioncreation = do 606 | lhs' <- subValues lhs vmap functioncreation 607 | rhs' <- subValues rhs vmap functioncreation 608 | cond' <- subValues cond vmap functioncreation 609 | return (HsIf xif syn (noLoc cond') (noLoc lhs') (noLoc rhs')) 610 | subValues (HsDo xdo ListComp (L l stmts)) vmap functioncreation = do 611 | stmts' <- mapM (\stmt -> subValuesLStmts stmt vmap functioncreation) stmts 612 | return (HsDo xdo ListComp (L l stmts')) 613 | subValues (SectionL xSection (L ll lhs) (L rl rhs)) vmap functioncreation = do 614 | lhs' <- subValues lhs vmap functioncreation 615 | rhs' <- subValues rhs vmap functioncreation 616 | return (SectionL xSection (L ll lhs') (L rl rhs')) 617 | subValues (SectionR xSection (L ll lhs) (L rl rhs)) vmap functioncreation = do 618 | lhs' <- subValues lhs vmap functioncreation 619 | rhs' <- subValues rhs vmap functioncreation 620 | return (SectionL xSection (L ll lhs') (L rl rhs')) 621 | subValues (ArithSeq xarith syn seqinfo) vmap functioncreation = do 622 | seqinfo' <- subValuesArithSeq seqinfo vmap functioncreation 623 | return (ArithSeq xarith syn seqinfo') 624 | subValues (HsCase xcase (L _ expr) (MG mg_ext (L _ mg_alts) mg_origin)) vmap functioncreation = do 625 | expr' <- subValues expr vmap functioncreation 626 | 627 | mg_alts' <- mapM subdef mg_alts 628 | 629 | return (HsCase xcase (noLoc expr') (MG mg_ext (noLoc mg_alts) mg_origin)) 630 | 631 | where 632 | subdef :: LMatch GhcPs (LHsExpr GhcPs) -> StateT EvalState IO(LMatch GhcPs (LHsExpr GhcPs)) 633 | subdef (L l (Match m_ext m_ctxt [pattern] (GRHSs grhssExt [(L _ (GRHS xgrhs guards (L _ body) ))] grhssLocalBinds))) = do 634 | let vmap' = foldr Map.delete vmap (FormalActualMap.nameFromPatternComponent pattern) 635 | 636 | body' <- subValues body vmap' functioncreation 637 | 638 | return (L l (Match m_ext m_ctxt [pattern] (GRHSs grhssExt [noLoc (GRHS xgrhs guards (noLoc body'))] grhssLocalBinds))) 639 | 640 | subValues (HsLet xLet localbinds (L _ expr)) vmap functioncreation = do 641 | expr' <- subValues expr vmap functioncreation 642 | 643 | expr'' <- case localbinds of 644 | (L _ (HsValBinds a (ValBinds b bag c))) -> do 645 | let expressions = bagToList bag 646 | let defs = Map.elems $ Map.unions $ map PrepStage.prepBind expressions --The list of expressions defined by this let. 647 | let names = map (\def -> if functioncreation then takeWhile (/='_') $ name def else name def) defs 648 | exprs <- mapM (\def -> subValues (Tools.getFirstDef $ definition def) vmap functioncreation) defs 649 | 650 | foldM (\exp -> (\(name, def) -> createLetExpression exp name functioncreation def)) expr' (zip names exprs) 651 | _ -> error "Non-supported let statement" 652 | 653 | return expr'' 654 | subValues (HsLam _ (MG mg_ext (L _ [(L _ (Match m_ext m_ctxt [pattern] (GRHSs grhssExt [L _ (GRHS body guard (L _ def))] grhssLocalBinds) ))]) mg_origin)) vmap functioncreation = do 655 | let names = FormalActualMap.nameFromPatternComponent pattern 656 | let vmap' = foldr Map.delete vmap names 657 | def' <- subValues def vmap' functioncreation 658 | return (HsLam NoExtField (MG mg_ext (noLoc [noLoc (Match m_ext m_ctxt [pattern] (GRHSs grhssExt [noLoc (GRHS body guard (noLoc def'))] grhssLocalBinds))]) mg_origin)) 659 | subValues expr _ _ = return expr 660 | 661 | subValuesTuple :: (LHsTupArg GhcPs) -> (Map.Map String (HsExpr GhcPs)) -> Bool -> StateT ScTypes.EvalState IO((LHsTupArg GhcPs)) 662 | subValuesTuple (L l (Present xpres (L l' expr))) vmap functioncreation = do 663 | expr' <- subValues expr vmap functioncreation 664 | return (L l (Present xpres (L l' expr'))) 665 | subValuesTuple tup _ _= return tup 666 | 667 | subValuesLStmts :: (ExprLStmt GhcPs) -> (Map.Map String (HsExpr GhcPs)) -> Bool -> StateT ScTypes.EvalState IO((ExprLStmt GhcPs)) 668 | subValuesLStmts (L l (BindStmt ext pat (L l' body) lexpr rexpr)) vmap functioncreation = do 669 | body' <- subValues body vmap functioncreation 670 | return (L l (BindStmt ext pat (L l' body') lexpr rexpr)) 671 | subValuesLStmts (L l (BodyStmt ext (L l' body) lexpr rexpr)) vmap functioncreation = do 672 | body' <- subValues body vmap functioncreation 673 | return (L l (BodyStmt ext (L l' body') lexpr rexpr)) 674 | subValuesLStmts (L l (LastStmt ext (L l' body) b expr)) vmap functioncreation = do 675 | body' <- subValues body vmap functioncreation 676 | return (L l (LastStmt ext (L l' body') b expr)) 677 | 678 | subValuesLStmts stmt _ _ = return stmt 679 | 680 | subValuesArithSeq (From (L l expr)) vmap functioncreation = do 681 | expr' <- subValues expr vmap functioncreation 682 | return (From (L l expr')) 683 | subValuesArithSeq (FromThen (L l lhs) (L _ rhs)) vmap functioncreation= do 684 | lhs' <- subValues lhs vmap functioncreation 685 | rhs' <- subValues rhs vmap functioncreation 686 | return (FromThen (L l lhs') (L l rhs')) 687 | subValuesArithSeq (FromTo (L l lhs) (L _ rhs)) vmap functioncreation = do 688 | lhs' <- subValues lhs vmap functioncreation 689 | rhs' <- subValues rhs vmap functioncreation 690 | return (FromTo (L l lhs') (L l rhs')) 691 | subValuesArithSeq (FromThenTo (L l lhs) (L _ mid) (L _ rhs)) vmap functioncreation = do 692 | lhs' <- subValues lhs vmap functioncreation 693 | rhs' <- subValues rhs vmap functioncreation 694 | mid' <- subValues mid vmap functioncreation 695 | return (FromThenTo (L l lhs') (L l mid') (L l rhs')) 696 | 697 | --Counts the args which appear in the input map in this expression 698 | countArgs :: (Map.Map String Integer) -> (HsExpr GhcPs) -> (Map.Map String Integer) 699 | countArgs m (HsVar xvar (L l id)) = case (Map.lookup name m) of 700 | Nothing -> m 701 | (Just count) -> Map.insert name (count+1) m 702 | where 703 | name = occNameString $ rdrNameOcc id 704 | 705 | countArgs m (HsApp _ (L _ lhs) (L _ rhs)) = Map.unionsWith (+) [countArgs m' lhs, countArgs m' rhs, m] 706 | where m' = emptycountmap m 707 | countArgs m (OpApp _ (L _ lhs) (L _ op) (L _ rhs)) = Map.unionsWith (+) [countArgs m' op, countArgs m' lhs, countArgs m' rhs, m] 708 | where m' = emptycountmap m 709 | countArgs m (HsPar _ (L _ exp)) = countArgs m exp 710 | countArgs m (NegApp _ (L _ exp) _) = countArgs m exp 711 | countArgs m (ExplicitTuple _ exprs _) = Map.unionsWith (+) (m:[countArgs m' exp | (L _ (Present _ (L _ exp))) <- exprs]) 712 | where m' = emptycountmap m 713 | countArgs m (ExplicitList _ _ exprs) = Map.unionsWith (+) (m:(map (\(L _ exp) -> countArgs m' exp) exprs)) 714 | where m' = emptycountmap m 715 | countArgs m (HsIf _ _ (L _ cond) (L _ lhs) (L _ rhs)) = Map.unionsWith (+) [countArgs m' cond, countArgs m' lhs, countArgs m' rhs, m] 716 | where m' = emptycountmap m 717 | countArgs m (HsDo _ ListComp (L _ stmts)) = Map.unionsWith (+) (m:(map (countArgsLStmt m') stmts)) 718 | where m' = emptycountmap m 719 | countArgs m (SectionL _ (L _ lhs) (L _ rhs)) = Map.unionsWith (+) [countArgs m' lhs, countArgs m' rhs, m] 720 | where m' = emptycountmap m 721 | countArgs m (SectionR _ (L _ lhs) (L _ rhs)) = Map.unionsWith (+) [countArgs m' lhs, countArgs m' rhs, m] 722 | where m' = emptycountmap m 723 | countArgs m (ArithSeq _ _ seqinfo) = countArgsArithSeq m seqinfo 724 | countArgs m (HsLet _ (L _ (HsValBinds _ (ValBinds _ bag _))) (L _ expr)) = Map.unionsWith (+) ([m, countArgs m' expr] ++ (map (countArgs m) rhss)) 725 | where 726 | expressions = bagToList bag 727 | defs = map PrepStage.prepBind expressions 728 | names = Map.keys $ Map.unions defs 729 | rhss = map getDefFromBind expressions 730 | m' = emptycountmap $ foldr Map.delete m names 731 | countArgs m (HsLet _ _ (L _ expr)) = countArgs m expr 732 | countArgs m (HsLam _ (MG _ (L _ [(L _ (Match _ _ [pattern] (GRHSs _ [L _ (GRHS _ _ (L _ def))] _) ))]) _)) = Map.unionWith (+) m (countArgs m' def) 733 | where 734 | names = FormalActualMap.nameFromPatternComponent pattern 735 | m' = emptycountmap (foldr Map.delete m names) 736 | countArgs m _ = m 737 | 738 | countArgsArithSeq m (From (L _ expr)) = countArgs m expr 739 | countArgsArithSeq m (FromThen (L _ lhs) (L _ rhs)) = Map.unionsWith (+) [countArgs m' lhs, countArgs m' rhs, m] 740 | where m' = emptycountmap m 741 | countArgsArithSeq m (FromTo (L _ lhs) (L _ rhs)) = Map.unionsWith (+) [countArgs m' lhs, countArgs m' rhs, m] 742 | where m' = emptycountmap m 743 | countArgsArithSeq m (FromThenTo (L _ lhs) (L _ mid) (L _ rhs)) = Map.unionsWith (+) [countArgs m' lhs, countArgs m' rhs, countArgs m' mid, m] 744 | where m' = emptycountmap m 745 | 746 | countArgsLStmt :: (Map.Map String Integer) -> (ExprLStmt GhcPs) -> (Map.Map String Integer) 747 | countArgsLStmt m (L _ (BindStmt _ _ (L _ body) _ _)) = countArgs m body 748 | countArgsLStmt m (L _ (BodyStmt _ (L _ body) _ _)) = countArgs m body 749 | countArgsLStmt m (L _ (LastStmt _ (L _ body) _ _)) = countArgs m body 750 | countArgsLStmt m _ = m 751 | 752 | emptycountmap m = Map.fromList $ zip (Map.keys m) (repeat 0) 753 | 754 | getBind :: [ExprLStmt GhcPs] -> (Maybe ((ExprLStmt GhcPs)), [ExprLStmt GhcPs]) 755 | getBind (((L l (BindStmt ext pat body lexpr rexpr))):exprs) = ((Just (L l (BindStmt ext pat body lexpr rexpr))), exprs) 756 | getBind (expr:exprs) = (bind, expr:exprs') 757 | where (bind, exprs') = getBind exprs 758 | getBind [] = (Nothing, []) 759 | 760 | getBody :: [ExprLStmt GhcPs] -> (Maybe (LHsExpr GhcPs), [ExprLStmt GhcPs]) 761 | getBody (((L l (BodyStmt ext body lexpr rexpr))):exprs) = (Just body, exprs) 762 | getBody (expr:exprs) = (bind, expr:exprs') 763 | where (bind, exprs') = getBody exprs 764 | getBody [] = (Nothing, []) 765 | 766 | --Combines lists together 767 | combineLists :: [LHsExpr GhcPs] -> (LHsExpr GhcPs) 768 | combineLists [expr] = expr 769 | combineLists (expr:exprs) = noLoc (OpApp NoExtField expr op rhs) 770 | where rhs = combineLists exprs 771 | op = noLoc (Tools.stringtoId "++") 772 | 773 | --If the list comp is finished, return it as a list, else return it as (the same) list comp 774 | listCompFinished :: (LHsExpr GhcPs) -> (LHsExpr GhcPs) 775 | listCompFinished (L l (HsDo xDo ListComp (L l' stmts))) = 776 | case bind of 777 | (Just _) -> (L l (HsDo xDo ListComp (L l' stmts))) --In this case there are still more expansions to be done 778 | _ -> case body of 779 | (Just _) -> (L l (HsDo xDo ListComp (L l' stmts))) -- Still have more conditions to deal with 780 | _ -> (L l (ExplicitList NoExtField Nothing elements)) --Have nothing else to do so just return a list 781 | where 782 | (bind, nonbinds) = getBind stmts 783 | (body, nonbody) = getBody stmts 784 | elements = map (\(L l (LastStmt _ body _ _)) -> body) stmts 785 | 786 | --Check to see if an expression is fully reduced 787 | fullyReduced :: (LHsExpr GhcPs) -> ScTypes.ModuleInfo -> ScTypes.ModuleInfo -> DynFlags -> String -> IO(Bool) 788 | fullyReduced lexpr@(L _ expr) funcMap hidden flags filename = do 789 | case expr of 790 | (HsLit _ _) -> return True 791 | (HsOverLit _ _) -> return True 792 | (HsVar _ _) -> do --Might not always work, but checking to see if it is in the context. 793 | case ((Map.union funcMap hidden) Map.!? (showSDocUnsafe $ ppr expr)) of 794 | (Just definition) -> if ((numargs definition) == 0) then return False else return True 795 | _ -> return True 796 | (HsIf _ _ _ _ _) -> return False 797 | (HsLet _ _ _) -> return False 798 | (HsDo _ _ _) -> return False 799 | (HsPar _ exp) -> fullyReduced exp funcMap hidden flags filename 800 | (ExplicitList _ _ []) -> return True 801 | (OpApp _ lhs@(L _ (HsVar _ _)) _ rhs@(L _ (HsVar _ _))) -> return True -- This might need changes 802 | (OpApp _ _ op _) -> return ((showSDocUnsafe $ ppr op) == "(.)") -- Consider fully reduced 803 | (HsApp _ lhs rhs) -> do 804 | let (func, args) = Tools.getFuncArgs lexpr 805 | if (isUpper $ head $ showSDocUnsafe $ ppr func) 806 | then and <$> (mapM (\x -> fullyReduced (noLoc x) funcMap hidden flags filename) args) 807 | else return False 808 | _ -> do 809 | ((_, result), _) <- runStateT (evalExpr lexpr funcMap hidden flags) (Map.empty, filename) 810 | case result of 811 | Reduced -> return False 812 | _ -> return True 813 | 814 | --Try and reduce the first let binding which can be reduced 815 | evalLetBindings :: [(LHsBindLR GhcPs GhcPs)] -> ScTypes.ModuleInfo -> ScTypes.ModuleInfo -> DynFlags -> StateT EvalState IO([(LHsBindLR GhcPs GhcPs)],[(HsExpr GhcPs, String)] ,TraverseResult) 816 | evalLetBindings [] _ _ _ = return ([], [], NotFound) -- Base case, nothing to do here 817 | evalLetBindings (orig@(L l (FunBind fun_ext fun_id (MG c (L _ ((L _ (Match x y z (GRHSs g ((L _ (GRHS o p expr) ):bodies) h))):defs)) d ) e f)):xs) modu hidden flags = do 818 | case expr of 819 | (L _ (HsPar _ expr')) -> do 820 | let orig' = noLoc (FunBind fun_ext fun_id (MG c (L l ((L l (Match x y z (GRHSs g ((L l (GRHS o p expr') ):bodies) h))):defs)) d ) e f) 821 | evalLetBindings (orig':xs) modu hidden flags 822 | (L _ (OpApp _ (L _ lhs) op (L _ rhs))) | ((showSDocUnsafe $ ppr op) == "(:)" || (showSDocUnsafe $ ppr op) == ":" ) -> do --Split a concat into two parts 823 | --Get the numberings of these new names 824 | let head_name = takeWhile (/= '_') $ showSDocUnsafe $ ppr fun_id 825 | 826 | var_numberings <- fst <$> get 827 | filename <- snd <$> get 828 | let head_numbering = case var_numberings Map.!? head_name of 829 | Nothing -> 0 830 | Just i -> i 831 | 832 | --Update the numberings 833 | put (Map.insert head_name (head_numbering +2) var_numberings, filename) 834 | 835 | --Generate the proper names 836 | let final_head_name = head_name ++ "_" ++ (show head_numbering) 837 | let final_tail_name = head_name ++ "_" ++ (show (head_numbering+1)) 838 | 839 | --Create the new defines to be in this let expression. 840 | let main_expr = L l (OpApp NoExtField (L l (HsVar NoExtField (noLoc $ mkRdrUnqual $ mkVarOcc $ final_head_name))) op (L l (HsVar NoExtField (noLoc $ mkRdrUnqual $ mkVarOcc $ final_tail_name)))) 841 | let main_expr_par = noLoc (HsPar NoExtField main_expr) 842 | let main = (L l (FunBind fun_ext fun_id (MG c (L l ((L l (Match x y z (GRHSs g ((L l (GRHS o p main_expr_par)):bodies) h))):defs)) d ) e f)) :: (LHsBindLR GhcPs GhcPs) 843 | 844 | return (main:xs, reverse [(lhs, final_head_name), (rhs, final_tail_name)], Reduced) 845 | _ -> do 846 | --Check to see if the first can be reduced 847 | (expr', reduced) <- evalExpr expr modu hidden flags 848 | case reduced of 849 | Reduced -> do 850 | let neworig = noLoc (FunBind fun_ext fun_id (MG c (L l ((L l (Match x y z (GRHSs g ((L l (GRHS o p expr') ):bodies) h))):defs)) d ) e f) 851 | return ((neworig:xs), [], Reduced) 852 | _ -> do --Instead reduce the tail 853 | (xs', newlets, tailreduced) <- evalLetBindings xs modu hidden flags 854 | return (orig:xs', newlets, tailreduced) 855 | 856 | --Creates a let expression 857 | --A bit complicated as it has to create an entire function! 858 | createLetExpression :: (HsExpr GhcPs) -> String -> Bool -> (HsExpr GhcPs) -> StateT EvalState IO(HsExpr GhcPs) 859 | createLetExpression expr varname makenewname varvalue = do 860 | 861 | var_numberings <- fst <$> get 862 | 863 | --The variables `shown` by let expressions will be given numberings 864 | --This will help users differentiate them 865 | let var_numbering = case var_numberings Map.!? varname of 866 | Nothing -> 0 867 | Just i -> i 868 | 869 | --Need to create a new variable name from this 870 | let new_var_name = if makenewname then varname ++ "_" ++ (show var_numbering) else varname 871 | 872 | 873 | let fun_id = (mkRdrUnqual $ mkVarOcc new_var_name) :: (IdP GhcPs) 874 | let m_ctxt = FunRhs (noLoc fun_id) Prefix NoSrcStrict 875 | let m_pats = [] 876 | let grhs = GRHS NoExtField [] (noLoc varvalue) :: GRHS GhcPs (LHsExpr GhcPs) 877 | let m_grhss = GRHSs NoExtField [noLoc grhs] (noLoc (EmptyLocalBinds NoExtField)) 878 | let match_group = Match NoExtField m_ctxt [] m_grhss 879 | 880 | let fun_matches = (MG NoExtField (noLoc [noLoc match_group]) Generated) :: MatchGroup GhcPs (LHsExpr GhcPs) 881 | let fun_co_fn = WpHole 882 | let fun_tick = [] 883 | let function = (FunBind NoExtField (noLoc fun_id) fun_matches fun_co_fn fun_tick) :: (HsBindLR GhcPs GhcPs) 884 | 885 | let contents = listToBag [noLoc function] 886 | let valbinds = (ValBinds NoExtField contents []) :: (HsValBindsLR GhcPs GhcPs) 887 | let hsvalbinds = HsValBinds NoExtField valbinds 888 | 889 | filename <- snd <$> get 890 | 891 | --Increment the number of the variable we've created the let statement for. 892 | if makenewname then put (Map.insert varname (var_numbering +1) var_numberings, filename) else return () 893 | 894 | --Substitute the new_var_name into the expression 895 | new_expr <- subValues expr (Map.fromList [(varname, (HsVar NoExtField (noLoc fun_id)))]) False 896 | 897 | return (HsLet NoExtField (noLoc hsvalbinds) (noLoc new_expr)) 898 | 899 | 900 | --Evaluates ambiguous arguments 901 | evalAmbiguousArguments :: [(HsExpr GhcPs, LPat GhcPs, [LPat GhcPs])] -> ScTypes.ModuleInfo -> ScTypes.ModuleInfo -> DynFlags -> StateT EvalState IO([(HsExpr GhcPs)], TraverseResult) 902 | evalAmbiguousArguments ((expr, pattern, patterns): args) modu hidden flags = do 903 | 904 | --Check to see which of the patterns 905 | let patstring = showSDocUnsafe $ ppr pattern 906 | if (or $ map (\pat -> (let newpatstr = (showSDocUnsafe $ ppr pat) in (newpatstr == patstring) || (newpatstr == "_"))) patterns) 907 | then do --Go and check the other results. 908 | (newargs, result) <- evalAmbiguousArguments args modu hidden flags 909 | return (expr:newargs, result) 910 | else do 911 | ((L _ newarg), result) <- evalExpr (noLoc expr) modu hidden flags 912 | case result of 913 | Reduced -> return (newarg:(map (\(x,_,_)->x) args), Reduced) 914 | _ -> do 915 | (newargs, result) <- evalAmbiguousArguments args modu hidden flags 916 | return (expr:newargs, result) 917 | evalAmbiguousArguments [] _ _ _ = return ([], NotFound) 918 | 919 | --Evaluate the first argument which doesn't pattern match with the proper pattern 920 | evalNonMatchingArguments :: [(HsExpr GhcPs, LPat GhcPs)] -> ScTypes.ModuleInfo -> ScTypes.ModuleInfo -> DynFlags -> StateT EvalState IO([(HsExpr GhcPs)], TraverseResult) 921 | evalNonMatchingArguments ((expr, pattern): args) modu hidden flags = do 922 | possiblematch <- lift $ FormalActualMap.matchPattern expr pattern modu 923 | case possiblematch of 924 | Nothing -> do 925 | ((L _ newarg), result) <- evalExpr (noLoc expr) modu hidden flags 926 | return (newarg:(map fst args), result) 927 | _ -> do 928 | (newargs, result) <- evalNonMatchingArguments args modu hidden flags 929 | return (expr:newargs, result) 930 | evalNonMatchingArguments [] _ _ _ = return ([], NotFound) --------------------------------------------------------------------------------