
   0 | module Idris.Package.Init
   1 | 
   2 | import Core.FC
   3 | import Core.Name.Namespace
   4 | import Core.Directory
   5 | 
   6 | import Data.Maybe
   7 | import Data.String
   8 | 
   9 | import Idris.Package.Types
  10 | import System.Directory
  11 | import Control.App.FileIO
  12 | 
  13 | import Libraries.Utils.Path
  14 | import Libraries.System.Directory.Tree
  15 | 
  16 | %default total
  17 | 
  18 | isModuleIdent : String -> Bool
  19 | isModuleIdent str = case unpack str of
  20 |   [] => False
  21 |   cs@(hd :: _) => isUpper hd && all isAlphaNum cs
  22 | 
  23 | packageTree : (root : Path) -> IO (Tree root)
  24 | packageTree root = filter validFile validDirectory <$> explore root where
  25 | 
  26 |   validFile : {root : _} -> FileName root -> Bool
  27 |   validFile f
  28 |     = case splitIdrisFileName (fileName f) of
  29 |         Nothing => False
  30 |         Just (fname, fext) => isModuleIdent fname
  31 | 
  32 |   validDirectory : {root : _} -> FileName root -> Bool
  33 |   validDirectory = isModuleIdent . fileName
  34 | 
  35 | covering
  36 | findModules : (start : Maybe String) -> IO (List (ModuleIdent, String))
  37 | findModules start = do
  38 |   let prfx = fromMaybe "" start
  39 |   Just dir <- maybe currentDir (pure . Just) start
  40 |     | Nothing => pure []
  41 |   let root = parse dir
  42 |   tree <- packageTree root
  43 |   mods <- go [] [([], (root ** pure tree))]
  44 |   pure (sortBy (\ a, b => compare (snd a) (snd b)) mods)
  45 | 
  46 |   where
  47 | 
  48 |     go : List (ModuleIdent, String) ->
  49 |          List (List String, (root : Path ** IO (Tree root))) ->
  50 |          IO (List (ModuleIdent, String))
  51 |     go acc [] = pure acc
  52 |     go acc ((path, (root ** iot)) :: iots) = do
  53 |       t <- liftIO iot
  54 |       let mods = flip map t.files $ \ entry =>
  55 |                    let fname = fst (splitExtensions (fileName entry)) in
  56 |                    let mod = unsafeFoldModuleIdent (fname :: path) in
  57 |                    let fp  = toFilePath entry in
  58 |                    (mod, fp)
  59 |       let dirs = flip map t.subTrees $ \ (dir ** iot) =>
  60 |                    (fileName dir :: path, (_ ** iot))
  61 |       go (mods ++ acc) (dirs ++ iots)
  62 | 
  63 | prompt : String -> IO String
  64 | prompt p = putStr p >> fflush stdout >> getLine
  65 | 
  66 | export
  67 | covering
  68 | interactive : IO (Maybe PkgDesc)
  69 | interactive = do
  70 |   pname <- prompt "Package name: "
  71 |   let True = checkPackageName $ fastUnpack pname
  72 |     | False => pure Nothing
  73 |   pauthors <- prompt "Package authors: "
  74 |   poptions <- prompt "Package options: "
  75 |   psource  <- prompt "Source directory: "
  76 |   let sourcedir = mstring psource
  77 |   modules  <- findModules sourcedir
  78 |   let pkg : PkgDesc =
  79 |         { authors   := mstring pauthors
  80 |         , options   := (emptyFC,) <$> mstring poptions
  81 |         , modules   := modules
  82 |         , sourcedir := sourcedir
  83 |         } (initPkgDesc (fromMaybe "project" (mstring pname)))
  84 |   pure $ Just pkg
  85 | 
  86 |   where
  87 | 
  88 |     mstring : String -> Maybe String
  89 |     mstring str = case trim str of
  90 |       "" => Nothing
  91 |       str => Just str
  92 | 
  93 |     isIdentStart : Char -> Bool
  94 |     isIdentStart '_' = True
  95 |     isIdentStart x   = isUpper x ||
  96 |                        isAlpha x ||
  97 |                        x > chr 160
  98 | 
  99 |     isIdentTrailing : List Char -> Bool
 100 |     isIdentTrailing []      = True
 101 |     isIdentTrailing (x::xs) = case isAlphaNum x ||
 102 |                                    x > chr 160  ||
 103 |                                    x == '-'     ||
 104 |                                    x == '_'     ||
 105 |                                    x == '\'' of
 106 |                                 False => False
 107 |                                 True  => isIdentTrailing xs
 108 | 
 109 |     checkPackageName : List Char -> Bool
 110 |     checkPackageName []      = True
 111 |     checkPackageName (x::xs) = isIdentStart x &&
 112 |                                isIdentTrailing xs
 113 |