From 76c3c3c4fcabe720d64fb234761623e0383dd232 Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Tue, 18 Feb 2025 17:16:18 +0100 Subject: [PATCH] Monad transformers for the first time :OO --- app/Main.hs | 1 + package.yaml | 2 ++ src/Ubc/Parse/Syntax.hs | 7 ++++++ src/Ubc/Parse/Syntax/Config.hs | 13 +++++++--- src/Ubc/Parse/Syntax/Import.hs | 46 ++++++++++++++++++++++++++-------- ubcc.cabal | 7 ++++++ 6 files changed, 63 insertions(+), 13 deletions(-) create mode 100644 src/Ubc/Parse/Syntax.hs diff --git a/app/Main.hs b/app/Main.hs index 3900d7f..0996528 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,5 +5,6 @@ import qualified Ubc.Parse.Syntax.File as File main :: IO () main = do text <- getContents + -- fixme: handle errors? print $ Parsec.parse (File.parse "" <* Parsec.eof) "" text diff --git a/package.yaml b/package.yaml index a5b2696..113d1ab 100644 --- a/package.yaml +++ b/package.yaml @@ -25,9 +25,11 @@ dependencies: - directory - exceptions - filepath +- mtl - os-string - path - parsec +- transformers ghc-options: - -Wall diff --git a/src/Ubc/Parse/Syntax.hs b/src/Ubc/Parse/Syntax.hs new file mode 100644 index 0000000..9afeb5a --- /dev/null +++ b/src/Ubc/Parse/Syntax.hs @@ -0,0 +1,7 @@ +module Ubc.Parse.Syntax +(Transformer) +where +import Control.Monad.Reader (ReaderT) +import Ubc.Parse.Syntax.Config (Config) + +type Transformer = ReaderT Config IO diff --git a/src/Ubc/Parse/Syntax/Config.hs b/src/Ubc/Parse/Syntax/Config.hs index 1d1edbf..204ddd4 100644 --- a/src/Ubc/Parse/Syntax/Config.hs +++ b/src/Ubc/Parse/Syntax/Config.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} module Ubc.Parse.Syntax.Config ( Config(..) , defaultConfig @@ -5,12 +8,16 @@ module Ubc.Parse.Syntax.Config where import Data.Set (Set) -import qualified Data.Set as Set + +import Path (Path, Abs, Dir) +import GHC.Generics (Generic, Generically(..)) data Config = Config - { includePaths :: Set FilePath + { includePaths :: Set (Path Abs Dir) } + deriving stock (Generic, Show) + deriving (Semigroup, Monoid) via Generically Config defaultConfig :: Config -defaultConfig = Config (Set.singleton ".") +defaultConfig = mempty diff --git a/src/Ubc/Parse/Syntax/Import.hs b/src/Ubc/Parse/Syntax/Import.hs index bd631de..6812310 100644 --- a/src/Ubc/Parse/Syntax/Import.hs +++ b/src/Ubc/Parse/Syntax/Import.hs @@ -1,20 +1,34 @@ module Ubc.Parse.Syntax.Import ( -parse) +parse2) where import Control.Monad.Catch ( SomeException () ) +import Control.Monad.Trans.Except () import Data.Functor ((<&>)) import Data.List.NonEmpty (NonEmpty) import Text.Parsec (sepBy1, ParsecT, anyChar, many, char, choice, notFollowedBy, oneOf) -import Path as Path ( Path, File, parseRelFile, Rel, parseRelDir, Dir ) +import Path as Path ( Path, File, parseRelFile, Rel, parseRelDir, Dir, Abs, (), fromAbsFile ) import qualified Ubc.Parse.Syntax.Language as UbcLanguage import qualified Data.List.NonEmpty as NonEmpty -import Control.Monad (liftM2) +import Ubc.Parse.Syntax (Transformer) +import Control.Monad.Trans.Reader (ReaderT, asks) +import Ubc.Parse.Syntax.Config (Config) +import qualified Ubc.Parse.Syntax.Config as Config +import qualified Data.Set as Set +import Control.Arrow ((>>>)) +import qualified Data.List as List +import Control.Monad.Trans (lift) +import qualified System.Directory as IO +import Control.Monad (filterM) + +data Import + = Failed SomeException + | Finished importPath :: Monad m => ParsecT String u m (NonEmpty String) importPath = UbcLanguage.angles (many importChar `sepBy1` char '/') @@ -26,15 +40,27 @@ importChar = choice , notFollowedBy (oneOf ">/") >> anyChar ] -parse :: ParsecT String u IO [String] -parse = do +parse2 :: ParsecT String u Transformer Import +parse2 = do UbcLanguage.reserved "import" fragments <- importPath - let name = Path.parseRelFile $ NonEmpty.last fragments :: Either SomeException (Path Rel File) - let dirPath = mapM Path.parseRelDir . NonEmpty.init $ fragments :: Either SomeException [Path Rel Dir] + either (pure . Failed) (lift . resolvePaths . uncurry constructPaths) $ do + name <- Path.parseRelFile $ NonEmpty.last fragments + dirPath <- mapM Path.parseRelDir . NonEmpty.init $ fragments + pure (name, dirPath) - case liftM2 (,) name dirPath of - Left err -> pure [] - Right success -> pure [] +resolvePaths :: Transformer [Path Abs File] -> Transformer Import +resolvePaths paths = do + existingPaths <- paths >>= filterM (lift . IO.doesFileExist . Path.fromAbsFile) + pure Finished + +constructPaths :: Path Rel File -> [Path Rel Dir] -> Transformer ([Path Abs File]) +constructPaths file dirs = do + paths <- asks Config.includePaths + Set.toList + >>> List.map (flip (foldl' ()) dirs) + >>> List.map ( file) + >>> pure + $ paths diff --git a/ubcc.cabal b/ubcc.cabal index 3aee142..59c091a 100644 --- a/ubcc.cabal +++ b/ubcc.cabal @@ -25,6 +25,7 @@ source-repository head library exposed-modules: + Ubc.Parse.Syntax Ubc.Parse.Syntax.Config Ubc.Parse.Syntax.Enumeration Ubc.Parse.Syntax.Expression @@ -50,9 +51,11 @@ library , directory , exceptions , filepath + , mtl , os-string , parsec , path + , transformers default-language: Haskell2010 executable ubcc-exe @@ -70,9 +73,11 @@ executable ubcc-exe , directory , exceptions , filepath + , mtl , os-string , parsec , path + , transformers , ubcc default-language: Haskell2010 @@ -92,8 +97,10 @@ test-suite ubcc-test , directory , exceptions , filepath + , mtl , os-string , parsec , path + , transformers , ubcc default-language: Haskell2010