refactoring

2 files changed, 46 insertions, 42 deletions

diff --git a/src/LambdaCube/Compiler.hs b/src/LambdaCube/Compiler.hs
index 31a5d4a2..ecb33167 100644
--- a/src/LambdaCube/Compiler.hs
+++ b/src/LambdaCube/Compiler.hs
@@ -39,11 +39,7 @@ import Control.DeepSeq
 import Control.Monad.Catch
 import Control.Exception hiding (catch, bracket, finally, mask)
 import Control.Arrow hiding ((<+>))
-import System.Directory
 import System.FilePath
-import qualified Data.Text as T
-import qualified Data.Text.IO as TIO
-import qualified Text.Show.Pretty as PP
 --import Debug.Trace
 
 import LambdaCube.IR as IR
@@ -53,6 +49,7 @@ import LambdaCube.Compiler.Parser (runDefParser, parseLC, DesugarInfo, Module)
 import LambdaCube.Compiler.Infer (inference, GlobalEnv, initEnv)
 import LambdaCube.Compiler.CoreToIR
 
+import LambdaCube.Compiler.Utils
 import LambdaCube.Compiler.DesugaredSource as Exported (FileInfo(..), Range(..), SPos(..), SIName(..), pattern SIName, sName)
 import LambdaCube.Compiler.Infer as Exported (Infos, Info(..), listAllInfos, listTypeInfos, listTraceInfos, errorRange, Exp, outputType, boolType, trueExp, unfixlabel)
 
@@ -61,38 +58,6 @@ import Paths_lambdacube_compiler (getDataDir)
 
 --------------------------------------------------------------------------------
 
-readFileStrict :: FilePath -> IO String
-readFileStrict = fmap T.unpack . TIO.readFile
-
-readFile' :: FilePath -> IO (Maybe (IO String))
-readFile' fname = do
-    b <- doesFileExist fname
-    return $ if b then Just $ readFileStrict fname else Nothing
-
-instance MonadMask m => MonadMask (ExceptT e m) where
-    mask f = ExceptT $ mask $ \u -> runExceptT $ f (mapExceptT u)
-    uninterruptibleMask = error "not implemented: uninterruptibleMask for ExcpetT"
-
-prettyShowUnlines :: Show a => a -> String
-prettyShowUnlines = goPP 0 . PP.ppShow
-  where
-    goPP _ [] = []
-    goPP n ('"':xs) | isMultilineString xs = "\"\"\"\n" ++ indent ++ go xs where
-        indent = replicate n ' '
-        go ('\\':'n':xs) = "\n" ++ indent ++ go xs
-        go ('\\':c:xs) = '\\':c:go xs
-        go ('"':xs) = "\n" ++ indent ++ "\"\"\"" ++ goPP n xs
-        go (x:xs) = x : go xs
-    goPP n (x:xs) = x : goPP (if x == '\n' then 0 else n+1) xs
-
-    isMultilineString ('\\':'n':xs) = True
-    isMultilineString ('\\':c:xs) = isMultilineString xs
-    isMultilineString ('"':xs) = False
-    isMultilineString (x:xs) = isMultilineString xs
-    isMultilineString [] = False
-
---------------------------------------------------------------------------------
-
 type MName = String
 type SName = String
 type SourceCode = String
@@ -125,7 +90,7 @@ ioFetch :: MonadIO m => [FilePath] -> ModuleFetcher (MMT m x)
 ioFetch paths' imp n = do
     preludePath <- (</> "lc") <$> liftIO getDataDir
     let paths = paths' ++ [preludePath]
-        find ((x, mn): xs) = liftIO (readFile' x) >>= maybe (find xs) (\src -> return $ Right (x, mn, liftIO src))
+        find ((x, mn): xs) = liftIO (readFileIfExists x) >>= maybe (find xs) (\src -> return $ Right (x, mn, liftIO src))
         find [] = return $ Left $ "can't find" <+> either (("lc file" <+>) . text) (("module" <+>) . text) n
                                   <+> "in path" <+> hsep (map text (paths' ++ ["<<installed-prelude-path>>"]{-todo-}))
     find $ nubBy ((==) `on` fst) $ map (first normalise . lcModuleFile) paths
@@ -169,8 +134,6 @@ data Modules x = Modules
     , nextMId   :: !Int
     }
 
-(<&>) = flip (<$>)
-
 loadModule :: MonadMask m => ((Infos, [Stmt]) -> x) -> Maybe FilePath -> Either FilePath MName -> MMT m x (Either Doc (FilePath, Module' x))
 loadModule ex imp mname_ = do
   r <- ask >>= \fetch -> fetch imp mname_
diff --git a/src/LambdaCube/Compiler/Utils.hs b/src/LambdaCube/Compiler/Utils.hs
index 71e4081b..f59f7a7b 100644
--- a/src/LambdaCube/Compiler/Utils.hs
+++ b/src/LambdaCube/Compiler/Utils.hs
@@ -4,6 +4,14 @@
 module LambdaCube.Compiler.Utils where
 
 import qualified Data.IntSet as IS
+import qualified Data.Text as T
+import qualified Text.Show.Pretty as PP
+import Control.Monad.Catch
+import Control.Monad.Except
+import System.Directory
+import qualified Data.Text.IO as TIO
+
+------------------------------------------------------- general functions
 
 (<&>) = flip (<$>)
 
@@ -13,7 +21,7 @@ iterateN n f e = iterate f e !! n
 unfoldNat z s 0         = z
 unfoldNat z s n | n > 0 = s $ unfoldNat z s (n-1)
 
-----------------------
+------------------------------------------------------- Void data type
 
 data Void
 
@@ -23,7 +31,7 @@ instance Eq Void where x == y = elimVoid x
 elimVoid :: Void -> a
 elimVoid v = case v of
 
-----------------------
+------------------------------------------------------- supplementary data wrapper
 
 -- supplementary data: data with no semantic relevance
 newtype SData a = SData a
@@ -32,7 +40,7 @@ instance Show (SData a) where show _ = "SData"
 instance Eq (SData a) where _ == _ = True
 instance Ord (SData a) where _ `compare` _ = EQ
 
------------------------------------------------------------------------- strongly connected component calculation
+------------------------------------------------------- strongly connected component calculation
 
 type Children k = k -> [k]
 
@@ -63,5 +71,38 @@ scc key children revChildren
             | not (key h `IS.member` s) = collect s acc t
             | otherwise = collect (IS.delete (key h) s) (h: acc) (children h ++ t)
 
+------------------------------------------------------- wrapped pretty show
+
+prettyShowUnlines :: Show a => a -> String
+prettyShowUnlines = goPP 0 . PP.ppShow
+  where
+    goPP _ [] = []
+    goPP n ('"':xs) | isMultilineString xs = "\"\"\"\n" ++ indent ++ go xs where
+        indent = replicate n ' '
+        go ('\\':'n':xs) = "\n" ++ indent ++ go xs
+        go ('\\':c:xs) = '\\':c:go xs
+        go ('"':xs) = "\n" ++ indent ++ "\"\"\"" ++ goPP n xs
+        go (x:xs) = x : go xs
+    goPP n (x:xs) = x : goPP (if x == '\n' then 0 else n+1) xs
+
+    isMultilineString ('\\':'n':xs) = True
+    isMultilineString ('\\':c:xs) = isMultilineString xs
+    isMultilineString ('"':xs) = False
+    isMultilineString (x:xs) = isMultilineString xs
+    isMultilineString [] = False
+
+------------------------------------------------------- file handling
+
+readFileStrict :: FilePath -> IO String
+readFileStrict = fmap T.unpack . TIO.readFile
+
+readFileIfExists :: FilePath -> IO (Maybe (IO String))
+readFileIfExists fname = do
+    b <- doesFileExist fname
+    return $ if b then Just $ readFileStrict fname else Nothing
+
+instance MonadMask m => MonadMask (ExceptT e m) where
+    mask f = ExceptT $ mask $ \u -> runExceptT $ f (mapExceptT u)
+    uninterruptibleMask = error "not implemented: uninterruptibleMask for ExcpetT"