From e39e14e91c0afbdafd7aca26a32936be690d6877 Mon Sep 17 00:00:00 2001
From: Joshua Simmons <joshua.simmons@emptypath.com>
Date: Wed, 16 Dec 2015 23:09:53 -0700
Subject: [PATCH] change the type of TemplateName to handle URLs too

---
 src/Stack/Types/TemplateName.hs | 40 ++++++++++++++++++++++-----------
 stack.cabal                     |  1 +
 2 files changed, 28 insertions(+), 13 deletions(-)

diff --git a/src/Stack/Types/TemplateName.hs b/src/Stack/Types/TemplateName.hs
index 66da7058f1..94fd4c4b0e 100644
--- a/src/Stack/Types/TemplateName.hs
+++ b/src/Stack/Types/TemplateName.hs
@@ -7,18 +7,30 @@
 
 module Stack.Types.TemplateName where
 
+import           Control.Error.Safe (justErr)
+import           Data.Foldable (asum)
 import           Data.Monoid
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           Language.Haskell.TH
+import           Network.HTTP.Client (parseUrl)
 import qualified Options.Applicative as O
 import           Path
 import           Path.Internal
 
 -- | A template name.
-data TemplateName = TemplateName !Text !(Either (Path Abs File) (Path Rel File))
+data TemplateName = TemplateName !Text !TemplatePath
   deriving (Ord,Eq,Show)
 
+data TemplatePath = AbsPath (Path Abs File)
+                  -- ^ an absolute path on the filesystem
+                  | RelPath (Path Rel File)
+                  -- ^ a relative path on the filesystem, or relative to
+                  -- the template repository
+                  | UrlPath String
+                  -- ^ a full URL
+  deriving (Eq, Ord, Show)
+
 -- | An argument which accepts a template name of the format
 -- @foo.hsfiles@ or @foo@, ultimately normalized to @foo@.
 templateNameArgument :: O.Mod O.ArgumentFields TemplateName
@@ -46,16 +58,17 @@ templateParamArgument =
 parseTemplateNameFromString :: String -> Either String TemplateName
 parseTemplateNameFromString fname =
     case T.stripSuffix ".hsfiles" (T.pack fname) of
-        Nothing -> parseValidFile (T.pack fname) (fname <> ".hsfiles")
-        Just prefix -> parseValidFile prefix fname
+        Nothing -> parseValidFile (T.pack fname) (fname <> ".hsfiles") fname
+        Just prefix -> parseValidFile prefix fname fname
   where
-    parseValidFile prefix str =
-        case parseRelFile str of
-            Nothing ->
-                case parseAbsFile str of
-                    Nothing -> Left expected
-                    Just fp -> return (TemplateName prefix (Left fp))
-            Just fp -> return (TemplateName prefix (Right fp))
+    parseValidFile prefix hsf orig = justErr expected
+                                           $ asum (validParses prefix hsf orig)
+    validParses prefix hsf orig =
+        -- NOTE: order is important
+        [ TemplateName (T.pack orig) . UrlPath <$> (parseUrl orig *> Just orig)
+        , TemplateName prefix        . AbsPath <$> parseAbsFile hsf
+        , TemplateName prefix        . RelPath <$> parseRelFile hsf
+        ]
     expected = "Expected a template filename like: foo or foo.hsfiles"
 
 -- | Make a template name.
@@ -67,13 +80,14 @@ mkTemplateName s =
             [|TemplateName (T.pack prefix) $(pn)|]
             where pn =
                       case p of
-                          Left (Path fp) -> [|Left (Path fp)|]
-                          Right (Path fp) -> [|Right (Path fp)|]
+                          AbsPath (Path fp) -> [|AbsPath (Path fp)|]
+                          RelPath (Path fp) -> [|RelPath (Path fp)|]
+                          UrlPath fp -> [|UrlPath fp|]
 
 -- | Get a text representation of the template name.
 templateName :: TemplateName -> Text
 templateName (TemplateName prefix _) = prefix
 
 -- | Get the path of the template.
-templatePath :: TemplateName -> Either (Path Abs File) (Path Rel File)
+templatePath :: TemplateName -> TemplatePath
 templatePath (TemplateName _ fp) = fp
diff --git a/stack.cabal b/stack.cabal
index 99b211ede2..e6a81521e5 100644
--- a/stack.cabal
+++ b/stack.cabal
@@ -151,6 +151,7 @@ library
                    , edit-distance >= 0.2
                    , either
                    , enclosed-exceptions
+                   , errors
                    , exceptions >= 0.8.0.2
                    , extra
                    , fast-logger >= 2.3.1